Author: junrue Date: Mon Mar 20 15:48:16 2006 New Revision: 58

Added: trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/native-object.lisp trunk/src/uitoolkit/system/system-classes.lisp trunk/src/uitoolkit/system/system-generics.lisp Removed: trunk/src/intrinsics/datastructs/datastruct-classes.lisp trunk/src/intrinsics/datastructs/datastruct.lisp trunk/src/intrinsics/system/clib.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 Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/windlg.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/graphics/magick-core-api.lisp trunk/src/uitoolkit/system/system-conditions.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-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.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: collapsed intrinsics package into uitoolkit.system

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 15:48:16 2006 @@ -46,31 +46,22 @@ ((:module "src" :components ((:file "packages") - (:module "intrinsics" - :depends-on ("packages") - :components - ((:module "datastructs" - :components - ((:file "datastruct-classes") - (:file "datastruct"))) - (:module "system" - :components - ((:file "native-classes") - (:file "native-conditions") - (:file "native-object-generics") - (:file "clib") - (:file "native-object"))))) (:module "uitoolkit" - :depends-on ("intrinsics") + :depends-on ("packages") :components ((:module "system" :components ((:file "system-constants") + (:file "system-classes") (:file "system-conditions") + (:file "system-generics") (:file "system-types") + (:file "datastructs") + (:file "clib") (:file "gdi32") (:file "kernel32") (:file "user32") + (:file "native-object") (:file "system-utils"))) (:module "graphics" :depends-on ("system")

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 15:48:16 2006 @@ -41,10 +41,11 @@ (:use #:common-lisp))

;;; -;;; package for fundamental stuff shared across the library +;;; package for system-level functionality ;;; -(defpackage #:graphic-forms.intrinsics - (:nicknames #:gfi) +(defpackage #:graphic-forms.uitoolkit.system + (:nicknames #:gfs) + (:shadow #:atom #:boolean) (:use #:common-lisp) (:export

@@ -57,7 +58,8 @@

;; constants

-;; methods, functions, and macros +;; methods, functions, macros + #:detail #:dispose #:disposed-p #:handle @@ -77,28 +79,7 @@ #:span-end

;; conditions - #:disposed-error)) - -;;; -;;; package for system-level functionality -;;; -(defpackage #:graphic-forms.uitoolkit.system - (:nicknames #:gfs) - (:shadow #:atom #:boolean) - (:use #:common-lisp) - (:export - -;; classes and structs - -;; constants - -;; methods, functions, macros - #:detail - #:with-compatible-dcs - #:with-hfont-selected - #:with-retrieved-dc - -;; conditions + #:disposed-error #:toolkit-error #:toolkit-warning #:win32-error

Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 15:48:16 2006 @@ -41,7 +41,7 @@ (defun exit-event-tester () (let ((w *event-tester-window*)) (setf *event-tester-window* nil) - (gfi:dispose w)) + (gfs:dispose w)) (gfw:shutdown 0))

(defclass event-tester-window-events (gfw:event-dispatcher) ()) @@ -51,7 +51,7 @@ (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) - (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) + (pnt (gfs:make-point :x 0 :y (floor (/ (gfs:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt)))

(defmethod gfw:event-close ((d event-tester-window-events) widget time) @@ -77,8 +77,8 @@ (incf *event-counter*) action button - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs: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) - (gfi:size-width size) - (gfi:size-height size) + (gfs:size-width size) + (gfs:size-height size) time (text-for-modifiers)))

@@ -115,8 +115,8 @@ (format nil "~a move point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) time (text-for-modifiers)))

Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 15:48:16 2006 @@ -39,22 +39,22 @@

(defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore time)) - (gfi:dispose window) + (gfs:dispose window) (gfw:shutdown 0))

(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) (declare (ignore time)) - (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) - (gfg:draw-text gc "Hello World!" (gfi:make-point))) + (gfg:draw-text gc "Hello World!" (gfs:make-point)))

(defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) - (gfi:dispose *hello-win*) + (gfs:dispose *hello-win*) (setf *hello-win* nil) (gfw:shutdown 0))

Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 15:48:16 2006 @@ -41,55 +41,55 @@ (defclass image-events (gfw:event-dispatcher) ())

(defun dispose-images () - (gfi:dispose *happy-image*) + (gfs:dispose *happy-image*) (setf *happy-image* nil) - (gfi:dispose *bw-image*) + (gfs:dispose *bw-image*) (setf *bw-image* nil) - (gfi:dispose *true-image*) + (gfs:dispose *true-image*) (setf *true-image* nil))

(defmethod gfw:event-close ((d image-events) window time) (declare (ignore window time)) (dispose-images) - (gfi:dispose *image-win*) + (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0))

(defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) - (let ((pnt (gfi:make-point)) - (pixel-pnt1 (gfi:make-point)) - (pixel-pnt2 (gfi:make-point :x 0 :y 15))) + (let ((pnt (gfs:make-point)) + (pixel-pnt1 (gfs:make-point)) + (pixel-pnt2 (gfs:make-point :x 0 :y 15)))

(gfg:draw-image gc *happy-image* pnt) - (incf (gfi:point-x pnt) 36) + (incf (gfs:point-x pnt) 36) (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) - (incf (gfi:point-x pnt) 36) + (incf (gfs:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt))

- (setf (gfi:point-x pnt) 0) - (incf (gfi:point-y pnt) 36) + (setf (gfs:point-x pnt) 0) + (incf (gfs:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) - (incf (gfi:point-x pnt) 24) + (incf (gfs:point-x pnt) 24) (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) - (incf (gfi:point-x pnt) 24) + (incf (gfs:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt))

- (setf (gfi:point-x pnt) 0) - (incf (gfi:point-y pnt) 20) + (setf (gfs:point-x pnt) 0) + (incf (gfs:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) - (incf (gfi:point-x pnt) 20) + (incf (gfs:point-x pnt) 20) (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) - (incf (gfi:point-x pnt) 20) + (incf (gfs:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt))))

(defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) (dispose-images) - (gfi:dispose *image-win*) + (gfs:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0))

@@ -103,7 +103,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) - (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) + (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn))))))

Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Mon Mar 20 15:48:16 2006 @@ -49,24 +49,24 @@ 0 0 (logior gfs::+lr-loadfromfile+ gfs::+lr-createdibsection+)))) - (if (gfi:null-handle-p hbmp) + (if (gfs:null-handle-p hbmp) (error 'gfs:win32-error :detail "load-image failed")) (setf d2 (gfg::image->data hbmp)) (assert-equal (gfg:depth d1) (gfg:depth d2) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d2))) - (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) - (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) + (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) (gfg:load im path) (setf d3 (gfg:data-obj im)) (assert-equal (gfg:depth d1) (gfg:depth d3) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d3))) - (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) - (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) - (unless (gfi:disposed-p im) - (gfi:dispose im)) - (unless (gfi:null-handle-p hbmp) + (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) + (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) + (unless (gfs:disposed-p im) + (gfs:dispose im)) + (unless (gfs:null-handle-p hbmp) (gfs::delete-object hbmp))))))

(define-test image-data-loading-test

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 15:48:16 2006 @@ -46,7 +46,7 @@ (defun exit-layout-tester () (let ((w *layout-tester-win*)) (setf *layout-tester-win* nil) - (gfi:dispose w)) + (gfs:dispose w)) (gfw:shutdown 0))

(defclass layout-tester-events (gfw:event-dispatcher) ()) @@ -74,7 +74,7 @@

(defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (gfi:make-size :width 45 :height 45)) + (gfs:make-size :width 45 :height 45))

(defmethod gfw:text ((win test-panel)) (declare (ignore win)) @@ -151,7 +151,7 @@ do (if (string= (gfw:text k) text) (setf victim k)))) (unless (null victim) - (gfi:dispose victim) + (gfs:dispose victim) (gfw:layout *layout-tester-win*))))

(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())

Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Mon Mar 20 15:48:16 2006 @@ -33,7 +33,7 @@

(in-package :graphic-forms.uitoolkit.tests)

-(defvar *minsize1* (gfi:make-size :width 20 :height 10)) +(defvar *minsize1* (gfs:make-size :width 20 :height 10)) (defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *minsize1*) (make-instance 'mock-widget :min-size *minsize1*) (make-instance 'mock-widget :min-size *minsize1*))) @@ -41,12 +41,12 @@ (defun validate-layout-rects (entries expected-rects) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) - (let ((pnt-a (gfi:location actual)) - (sz-a (gfi:size actual))) - (assert-equal (gfi:point-x pnt-a) (first expected)) - (assert-equal (gfi:point-y pnt-a) (second expected)) - (assert-equal (gfi:size-width sz-a) (third expected)) - (assert-equal (gfi:size-height sz-a) (fourth expected)))) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (gfs:point-x pnt-a) (first expected)) + (assert-equal (gfs:point-y pnt-a) (second expected)) + (assert-equal (gfs:size-width sz-a) (third expected)) + (assert-equal (gfs:size-height sz-a) (fourth expected)))) expected-rects actual-rects)))

@@ -62,8 +62,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfi:size-width size)) - (assert-equal 10 (gfi:size-height size)) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

(define-test flow-layout-test2 @@ -78,8 +78,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfi:size-width size)) - (assert-equal 30 (gfi:size-height size)) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

(define-test flow-layout-test3 @@ -146,8 +146,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfi:size-width size)) - (assert-equal 10 (gfi:size-height size)) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

(define-test flow-layout-test8 @@ -162,8 +162,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfi:size-width size)) - (assert-equal 38 (gfi:size-height size)) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

(define-test flow-layout-test9 @@ -207,8 +207,8 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfi:size-width size)) - (assert-equal 13 (gfi:size-height size)) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

(define-test flow-layout-test12 @@ -226,6 +226,6 @@ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfi:size-width size)) - (assert-equal 33 (gfi:size-height size)) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) (validate-layout-rects data expected-rects)))

Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Mar 20 15:48:16 2006 @@ -47,32 +47,32 @@ (actual-size :accessor actual-size-of :initarg :actual-size - :initform (gfi:make-size)) + :initform (gfs:make-size)) (max-size :accessor max-size-of :initarg :max-size - :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+)) + :initform (gfs:make-size :width +max-widget-size+ :height +max-widget-size+)) (min-size :accessor min-size-of :initarg :min-size - :initform (gfi:make-size)))) + :initform (gfs:make-size))))

(defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) + (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF)))

(defmethod gfw:minimum-size ((widget mock-widget)) - (gfi:make-size :width (gfi:size-width (min-size-of widget)) - :height (gfi:size-height (min-size-of widget)))) + (gfs:make-size :width (gfs:size-width (min-size-of widget)) + :height (gfs:size-height (min-size-of widget))))

(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) - (let ((size (gfi:make-size)) + (let ((size (gfs:make-size)) (min-size (min-size-of widget))) (if (< width-hint 0) - (setf (gfi:size-width size) (gfi:size-width min-size)) - (setf (gfi:size-width size) width-hint)) + (setf (gfs:size-width size) (gfs:size-width min-size)) + (setf (gfs:size-width size) width-hint)) (if (< height-hint 0) - (setf (gfi:size-height size) (gfi:size-height min-size)) - (setf (gfi:size-height size) height-hint)) + (setf (gfs:size-height size) (gfs:size-height min-size)) + (setf (gfs:size-height size) height-hint)) size))

(defmethod gfw:visible-p ((widget mock-widget))

Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 15:48:16 2006 @@ -40,14 +40,14 @@ (defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) (setf *main-win* nil) - (gfi:dispose window) + (gfs:dispose window) (gfw:shutdown 0))

(defclass test-win-events (gfw:event-dispatcher) ())

(defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) - (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) @@ -56,21 +56,21 @@

(defmethod gfw:event-close ((d test-mini-events) window time) (declare (ignore time)) - (gfi:dispose window)) + (gfs:dispose window))

(defclass test-borderless-events (test-win-events) ())

(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) (declare (ignore time point button)) - (gfi:dispose window)) + (gfs:dispose window))

(defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:style-borderless)))) - (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) - (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (setf (gfw:location window) (gfs:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) (gfw:show window t)))

(defun create-miniframe-win (disp item time rect) @@ -78,8 +78,8 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :style '(:style-miniframe)))) - (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") (gfw:show window t)))

@@ -88,14 +88,14 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) :owner *main-win* :style '(:style-palette)))) - (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:location window) (gfs:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfs:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") (gfw:show window t)))

(defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) - (gfi:dispose *main-win*) + (gfs:dispose *main-win*) (setf *main-win* nil) (gfw:shutdown 0))

Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Mon Mar 20 15:48:16 2006 @@ -37,8 +37,8 @@ ;;; methods ;;;

-(defmethod gfi:dispose ((fn font)) - (let ((hgdi (gfi:handle fn))) - (unless (gfi:null-handle-p hgdi) +(defmethod gfs:dispose ((fn font)) + (let ((hgdi (gfs:handle fn))) + (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value fn 'gfi:handle) nil)) + (setf (slot-value fn 'gfs: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 Mon Mar 20 15:48:16 2006 @@ -76,16 +76,16 @@ (direct nil) (table nil))) ; vector of COLOR structs

-(defclass image-data (gfi:native-object) () +(defclass image-data (gfs:native-object) () (:documentation "This class maintains image attributes, color, and pixel data."))

-(defclass font (gfi:native-object) () +(defclass font (gfs:native-object) () (:documentation "This class encapsulates a realized native font."))

-(defclass graphics-context (gfi:native-object) () +(defclass graphics-context (gfs:native-object) () (:documentation "This class represents the context associated with drawing primitives."))

-(defclass image (gfi:native-object) +(defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel @@ -116,8 +116,8 @@ (defmacro color-table (data) `(gfg::palette-table ,data))

-(defclass pattern (gfi:native-object) () +(defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush."))

-(defclass transform (gfi:native-object) () +(defclass transform (gfs: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 Mon Mar 20 15:48:16 2006 @@ -41,41 +41,41 @@ ;;; methods ;;;

-(defmethod gfi:dispose ((gc graphics-context)) - (gfs::delete-dc (gfi:handle gc)) - (setf (slot-value gc 'gfi:handle) nil)) +(defmethod gfs:dispose ((gc graphics-context)) + (gfs::delete-dc (gfs:handle gc)) + (setf (slot-value gc 'gfs:handle) nil))

(defmethod background-color ((gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (gfs::get-bk-color (gfi:handle gc))) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (gfs::get-bk-color (gfs:handle gc)))

(defmethod (setf background-color) ((clr color) (gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb)))

-(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) - (pnt (gfi:location rect)) - (size (gfi:size rect))) +(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) + (pnt (gfs:location rect)) + (size (gfs:size rect))) (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::top (gfi:point-y pnt)) - (setf gfs::left (gfi:point-x pnt)) - (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size))) - (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size))) + (setf gfs::top (gfs:point-y pnt)) + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))) + (setf gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) (gfs::ext-text-out hdc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::+eto-opaque+ rect-ptr "" @@ -85,19 +85,19 @@ ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; -(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)) - (let ((gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) +(defmethod draw-image ((gc graphics-context) (im image) (pnt gfs:point)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (if (gfs:disposed-p im) + (error 'gfs:disposed-error)) + (let ((gc-dc (gfs:handle gc)) + (himage (gfs:handle im)) (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (if (not (null (transparency-pixel-of im))) - (let ((hmask (gfi:handle (transparency-mask im))) + (let ((hmask (gfs:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) (black (make-color :red 0 :green 0 :blue 0)) @@ -113,15 +113,15 @@ memdc 0 0 gfs::+blt-srcand+) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc 0 0 gfs::+blt-srcand+) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc2 @@ -129,29 +129,29 @@ (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) gfs::width gfs::height memdc 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc)))

-(defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) +(defmethod draw-text ((gc graphics-context) text (pnt gfs:point)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) (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::top (gfi:point-y pnt)) - (gfs::draw-text (gfi:handle gc) + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::top (gfs:point-y pnt)) + (gfs::draw-text (gfs:handle gc) text -1 rect-ptr (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) (cffi:null-pointer)) - (gfs::draw-text (gfi:handle gc) + (gfs::draw-text (gfs:handle gc) text (length text) rect-ptr @@ -162,14 +162,14 @@ (cffi:null-pointer)))))

(defmethod foreground-color ((gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (gfs::get-text-color (gfi:handle gc))) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (gfs::get-text-color (gfs:handle gc)))

(defmethod (setf foreground-color) ((clr color) (gc graphics-context)) - (if (gfi:disposed-p gc) - (error 'gfi:disposed-error)) - (let ((hdc (gfi:handle gc)) + (if (gfs:disposed-p gc) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle gc)) (hpen (gfs::get-stock-object gfs::+dc-pen+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hpen)

Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 15:48:16 2006 @@ -63,10 +63,10 @@ bc-ptr 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 sz (gfs: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 byte-count (* (bmp-pixel-row-length (gfs:size-width sz) (bits-per-pixel data)) + (gfs:size-height sz))) (setf raw-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize @@ -79,14 +79,14 @@ 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::biwidth (gfs:size-width sz)) + (setf gfs::biheight (gfs: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 (gfi:size-height sz) + 0 (gfs:size-height sz) raw-bits bi-ptr gfs::+dib-rgb-colors+)) @@ -140,14 +140,14 @@ gfs::biclrimp gfs::bmicolors) bi-ptr gfs::bitmapinfo) - (let* ((handle (gfi:handle data)) + (let* ((handle (gfs:handle data)) (sz (size data)) - (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) + (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) - (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (- 0 (gfi:size-height sz))) + (setf gfs::biwidth (gfs:size-width sz)) + (setf gfs::biheight (- 0 (gfs:size-height sz))) (setf gfs::biplanes 1) (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not (setf gfs::bicompression gfs::+bi-rgb+) @@ -166,12 +166,12 @@ pix-bits-ptr (cffi:null-pointer) 0)) - (if (gfi:null-handle-p hbmp) + (if (gfs:null-handle-p hbmp) (error 'gfs:win32-error :detail "create-dib-section failed"))

;; update the RGBQUADs ;; - (let ((tmp (get-image-pixels handle 0 0 (gfi:size-width sz) (gfi:size-height sz))) + (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) (ptr (cffi:mem-ref pix-bits-ptr :pointer))) (dotimes (i pix-count) (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved) @@ -190,17 +190,17 @@ ;;;

(defmethod depth ((data image-data)) - (let ((handle (gfi:handle data))) + (let ((handle (gfs:handle data))) (if (null handle) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (cffi:foreign-slot-value handle 'magick-image 'depth)))

-(defmethod gfi:dispose ((data image-data)) - (let ((victim (gfi:handle data))) +(defmethod gfs:dispose ((data image-data)) + (let ((victim (gfs:handle data))) (if (null victim) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (destroy-image victim)) - (setf (slot-value data 'gfi:handle) nil)) + (setf (slot-value data 'gfs:handle) nil))

(defmethod load ((data image-data) path) (setf path (cond @@ -208,10 +208,10 @@ ((typep path 'string) path) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let ((handle (gfi:handle data))) + (let ((handle (gfs:handle data))) (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) (destroy-image handle) - (setf (slot-value data 'gfi:handle) nil) + (setf (slot-value data 'gfs:handle) nil) (setf handle nil)) (with-image-path (path info ex) (setf handle (read-image info ex)) @@ -221,48 +221,48 @@ (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value data 'gfi:handle) handle)))) + (setf (slot-value data 'gfs:handle) handle))))

(defmethod size ((data image-data)) - (let ((handle (gfi:handle data)) - (size (gfi:make-size))) + (let ((handle (gfs:handle data)) + (size (gfs:make-size))) (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((rows columns) handle magick-image) - (setf (gfi:size-height size) rows) - (setf (gfi:size-width size) columns)) + (setf (gfs:size-height size) rows) + (setf (gfs:size-width size) columns)) size))

(defmethod (setf size) (size (data image-data)) - (let ((handle (gfi:handle data)) + (let ((handle (gfs:handle data)) (new-handle (cffi:null-pointer)) (ex (acquire-exception-info))) (if (or (null handle) (cffi:null-pointer-p handle)) - (error 'gfi:disposed-error)) + (error 'gfs:disposed-error)) (unwind-protect (progn (setf new-handle (resize-image handle - (gfi:size-width size) - (gfi:size-height size) + (gfs:size-width size) + (gfs:size-height size) (cffi:foreign-enum-value 'filter-types :lanczos) 1.0 ex)) - (if (gfi:null-handle-p new-handle) + (if (gfs:null-handle-p new-handle) (error 'gfs:toolkit-error :detail (format nil "could not resize: ~a" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (setf (slot-value data 'gfi:handle) new-handle) + (setf (slot-value data 'gfs:handle) new-handle) (destroy-image handle)) (destroy-exception-info ex))))

(defmethod print-object ((data image-data) stream) - (if (or (null (gfi:handle data)) (cffi:null-pointer-p (gfi:handle data))) - (error 'gfi:disposed-error)) + (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data))) + (error 'gfs:disposed-error)) (let ((size (size data))) (print-unreadable-object (data stream :type t) ;; FIXME: dump palette info, too ;; - (format stream "width: ~a " (gfi:size-width size)) - (format stream "height: ~a " (gfi:size-height size)) + (format stream "width: ~a " (gfs:size-width size)) + (format stream "height: ~a " (gfs:size-height size)) (format stream "bits per pixel: ~a " (depth data)))))

Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 15:48:16 2006 @@ -49,7 +49,7 @@ (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) (nptr (cffi:null-pointer))) - (gfs:with-compatible-dcs (nptr memdc-src memdc-dest) + (gfs::with-compatible-dcs (nptr memdc-src memdc-dest) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -65,21 +65,21 @@ ;;; methods ;;;

-(defmethod gfi:dispose ((im image)) - (let ((hgdi (gfi:handle im))) - (unless (gfi:null-handle-p hgdi) +(defmethod gfs:dispose ((im image)) + (let ((hgdi (gfs:handle im))) + (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value im 'gfi:handle) nil)) + (setf (slot-value im 'gfs:handle) nil))

(defmethod data-obj ((im image)) - (when (gfi:disposed-p im) - (error 'gfi:disposed-error)) - (image->data (gfi:handle im))) + (when (gfs:disposed-p im) + (error 'gfs:disposed-error)) + (image->data (gfs:handle im)))

(defmethod (setf data-obj) ((id image-data) (im image)) - (unless (gfi:disposed-p im) - (gfi:dispose im)) - (setf (slot-value im 'gfi:handle) (data->image id))) + (unless (gfs:disposed-p im) + (gfs:dispose im)) + (setf (slot-value im 'gfs:handle) (data->image id)))

(defmethod load ((im image) path) (let ((data (make-instance 'image-data))) @@ -88,24 +88,24 @@ data))

(defmethod transparency-mask ((im image)) - (if (gfi:disposed-p im) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p im) + (error 'gfs:disposed-error)) (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfi:handle im)) + (hbmp (gfs:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) (unless (null pixel-pnt) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfi:null-handle-p hmask) + (if (gfs:null-handle-p hmask) (error 'gfs:win32-error :detail "create-bitmap failed")) (gfs::with-compatible-dcs (nptr memdc1 memdc2) (gfs::select-object memdc1 hbmp) (setf old-bg (gfs::set-bk-color memdc1 - (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::get-pixel memdc1 (gfs:point-x pixel-pnt) (gfs:point-y pixel-pnt)))) (gfs::select-object memdc2 hmask) (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) (gfs::set-bk-color memdc1 old-bg))))

Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Mon Mar 20 15:48:16 2006 @@ -190,7 +190,7 @@ (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) (unwind-protect (cffi:with-foreign-string (str ,path) - (gfi::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) + (gfs::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) str (1- +magick-max-text-extent+)) ,@body))

Added: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/clib.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; clib.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(defcfun + ("strncpy" strncpy) + :pointer + (dest :pointer) + (src :pointer) + (count :unsigned-int))

Added: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,55 @@ +;;;; +;;;; datastructs.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(defstruct point (x 0) (y 0) (z 0)) + +(defstruct size (width 0) (height 0) (depth 0)) + +(defstruct span (start 0) (end 0)) + +(defclass rectangle () + ((location + :accessor location + :initarg :location + :initform (make-point)) + (size + :accessor size + :initarg :size + :initform (make-size))) + (:documentation "Describes the perimeter of a rectangular region in a given coordinate system.")) + +(defmethod print-object ((obj rectangle) stream) + (print-unreadable-object (obj stream :type t) + (format stream "location: ~a size: ~a" (location obj) (size obj))))

Added: trunk/src/uitoolkit/system/native-object.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/native-object.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; native-object.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(defmethod disposed-p ((obj native-object)) + (null (handle obj))) + +(defmacro null-handle-p (handle) + `(cffi:null-pointer-p ,handle))

Added: trunk/src/uitoolkit/system/system-classes.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/system-classes.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,41 @@ +;;;; +;;;; system-classes.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(defclass native-object () + ((handle + :reader handle + :initarg :handle + :initform nil)) + (:documentation "This is the base class for all objects that have a native handle representation at the system level."))

Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Mon Mar 20 15:48:16 2006 @@ -47,6 +47,8 @@ (print-unreadable-object (obj stream :type t) (format stream "~s" (detail obj))))

+(define-condition disposed-error (error) ()) + (define-condition win32-error (toolkit-error) ((code :reader code :initarg :code :initform (get-last-error))))

Added: trunk/src/uitoolkit/system/system-generics.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/system-generics.lisp Mon Mar 20 15:48:16 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; system-generics.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.system) + +(defgeneric dispose (native-object) + (:documentation "Discards native resources and executes other cleanup code.")) + +(defgeneric disposed-p (native-object) + (:documentation "Returns T if the target has had dispose called; nil otherwise."))

Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 15:48:16 2006 @@ -44,7 +44,7 @@ (progn (setf ,hfont-old (gfs::select-object ,hdc ,hfont)) ,@body) - (unless (gfi:null-handle-p ,hfont-old) + (unless (gfs:null-handle-p ,hfont-old) (gfs::select-object ,hdc ,hfont-old))))))

(defmacro with-retrieved-dc ((hwnd hdc-var) &body body) @@ -52,7 +52,7 @@ (unwind-protect (progn (setf ,hdc-var (gfs::get-dc ,hwnd)) - (if (gfi:null-handle-p ,hdc-var) + (if (gfs:null-handle-p ,hdc-var) (error 'gfs:win32-error :detail "get-dc failed")) ,@body) (gfs::release-dc ,hwnd ,hdc-var))))

Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Mar 20 15:48:16 2006 @@ -68,22 +68,22 @@ (compute-style-flags btn style) (let ((hwnd (create-window gfs::+button-classname+ " " - (gfi:handle parent) + (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfi:handle) hwnd))) + (setf (slot-value btn 'gfs:handle) hwnd))) (init-control btn))

(defmethod preferred-size ((btn button) width-hint height-hint) (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) (if (>= width-hint 0) - (setf (gfi:size-width sz) width-hint) - (setf (gfi:size-width sz) (+ (gfi:size-width sz) 14))) + (setf (gfs:size-width sz) width-hint) + (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) (if (>= height-hint 0) - (setf (gfi:size-height sz) height-hint) - (setf (gfi:size-height sz) (+ (gfi:size-height sz) 10))) + (setf (gfs:size-height sz) height-hint) + (setf (gfs:size-height sz) (+ (gfs:size-height sz) 10))) sz))

(defmethod text ((btn button))

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Mar 20 15:48:16 2006 @@ -38,11 +38,11 @@ ;;;

(defun init-control (ctrl) - (let ((hwnd (gfi:handle ctrl))) + (let ((hwnd (gfs:handle ctrl))) (subclass-wndproc hwnd) (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) - (unless (gfi:null-handle-p hfont) + (unless (gfs:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) @@ -54,10 +54,10 @@ ;;;

(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p parent) + (error 'gfs:disposed-error)))

(defmethod preferred-size :before ((ctrl control) width-hint height-hint) (declare (ignorable width-hint height-hint)) - (if (gfi:disposed-p ctrl) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error)))

Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Mon Mar 20 15:48:16 2006 @@ -35,7 +35,7 @@

(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:item integer gfi:rectangle)))) + (gfw:event-select . (gfw:item integer gfs:rectangle))))

(defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info)))

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Mar 20 15:48:16 2006 @@ -102,8 +102,8 @@ (w (get-widget tc hwnd)) (pnt (mouse-event-pnt tc))) (when w - (setf (gfi:point-x pnt) (lo-word lparam)) - (setf (gfi:point-y pnt) (hi-word lparam)) + (setf (gfs:point-x pnt) (lo-word lparam)) + (setf (gfs:point-y pnt) (hi-word lparam)) (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol))) 0)

@@ -150,7 +150,7 @@ (event-select (dispatcher item) item (event-time tc) - (make-instance 'gfi:rectangle))))) ; FIXME + (make-instance 'gfs:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t @@ -161,7 +161,7 @@ (event-select (dispatcher w) w (event-time tc) - (make-instance 'gfi:rectangle)))))) ; FIXME + (make-instance 'gfs:rectangle)))))) ; FIXME (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)

@@ -284,17 +284,17 @@ (w (get-widget tc hwnd)) (gc (make-instance 'gfg:graphics-context))) (if w - (let ((rct (make-instance 'gfi:rectangle))) + (let ((rct (make-instance 'gfs: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 + (setf (slot-value gc 'gfs:handle) (gfs::begin-paint hwnd ps-ptr)) + (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) - (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width + (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (unwind-protect (event-paint (dispatcher w) w (event-time tc) gc rct) @@ -355,6 +355,6 @@ ;;; event-dispatcher methods ;;;

-(defmethod gfi:dispose ((d event-source)) +(defmethod gfs:dispose ((d event-source)) (setf (dispatcher d) nil) (call-next-method))

Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 20 15:48:16 2006 @@ -48,24 +48,24 @@ (when (or (visible-p kid) (not win-visible)) (if vert-orient (progn - (incf total (gfi:size-height size)) - (if (< max (gfi:size-width size)) - (setf max (gfi:size-width size)))) + (incf total (gfs:size-height size)) + (if (< max (gfs:size-width size)) + (setf max (gfs:size-width size)))) (progn - (incf total (gfi:size-width size)) - (if (< max (gfi:size-height size)) - (setf max (gfi:size-height size)))))))) + (incf total (gfs:size-width size)) + (if (< max (gfs:size-height size)) + (setf max (gfs:size-height size)))))))) (unless (null kids) (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient (progn (incf max (+ (left-margin-of layout) (right-margin-of layout))) (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfi:make-size :width max :height total)) + (gfs:make-size :width max :height total)) (progn (incf total (+ (left-margin-of layout) (right-margin-of layout))) (incf max (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfi:make-size :width total :height max))))) + (gfs:make-size :width total :height max)))))

(defun flow-container-layout (layout visible kids width-hint height-hint) (let* ((flows nil) @@ -79,14 +79,14 @@ (wrap-coord (if vert-orient (left-margin-of layout) (top-margin-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid -1 -1)) - (pnt (gfi:make-point))) + (pnt (gfs:make-point))) (when (or (visible-p kid) (not visible)) (if vert-orient (progn (when (and wrap (>= height-hint 0) (> (+ next-coord - (gfi:size-height size) + (gfs:size-height size) (bottom-margin-of layout)) height-hint)) (push (reverse curr-flow) flows) @@ -94,16 +94,16 @@ (setf next-coord (top-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) - (setf (gfi:point-x pnt) wrap-coord) - (setf (gfi:point-y pnt) next-coord) - (if (< max-size (gfi:size-width size)) - (setf max-size (gfi:size-width size))) - (incf next-coord (+ (gfi:size-height size) spacing))) + (setf (gfs:point-x pnt) wrap-coord) + (setf (gfs:point-y pnt) next-coord) + (if (< max-size (gfs:size-width size)) + (setf max-size (gfs:size-width size))) + (incf next-coord (+ (gfs:size-height size) spacing))) (progn (when (and wrap (>= width-hint 0) (> (+ next-coord - (gfi:size-width size) + (gfs:size-width size) (right-margin-of layout)) width-hint)) (push (reverse curr-flow) flows) @@ -111,12 +111,12 @@ (setf next-coord (left-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) - (setf (gfi:point-x pnt) next-coord) - (setf (gfi:point-y pnt) wrap-coord) - (if (< max-size (gfi:size-height size)) - (setf max-size (gfi:size-height size))) - (incf next-coord (+ (gfi:size-width size) spacing)))) - (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) + (setf (gfs:point-x pnt) next-coord) + (setf (gfs:point-y pnt) wrap-coord) + (if (< max-size (gfs:size-height size)) + (setf max-size (gfs:size-height size))) + (incf next-coord (+ (gfs:size-width size) spacing)))) + (push (cons kid (make-instance 'gfs:rectangle :size size :location pnt)) curr-flow)))) (unless (null curr-flow) (push (reverse curr-flow) flows)) (loop for flow in (nreverse flows) append flow)))

Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Mar 20 15:48:16 2006 @@ -38,5 +38,5 @@

(defmethod check :before ((it item) flag) (declare (ignore flag)) - (if (gfi:null-handle-p (gfi:handle it)) + (if (gfs:null-handle-p (gfs:handle it)) (error 'gfs:toolkit-error :detail "null owner handle")))

Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 15:48:16 2006 @@ -79,17 +79,17 @@ (compute-style-flags label style) (let ((hwnd (create-window gfs::+static-classname+ " " - (gfi:handle parent) + (gfs:handle parent) (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfi:handle) hwnd))) + (setf (slot-value label 'gfs:handle) hwnd))) (init-control label))

(defmethod preferred-size ((label label) width-hint height-hint) - (let* ((hwnd (gfi:handle label)) + (let* ((hwnd (gfs:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) (sz nil) @@ -99,11 +99,11 @@ (setf flags (logior flags gfs::+dt-wordbreak+))) (setf sz (widget-text-size label flags width-hint)) (if (>= width-hint 0) - (setf (gfi:size-width sz) width-hint)) + (setf (gfs:size-width sz) width-hint)) (if (>= height-hint 0) - (setf (gfi:size-height sz) height-hint)) - (incf (gfi:size-width sz) (* b-width 2)) - (incf (gfi:size-height sz) (* b-width 2)) + (setf (gfs:size-height sz) height-hint)) + (incf (gfs:size-width sz) (* b-width 2)) + (incf (gfs:size-height sz) (* b-width 2)) sz))

(defmethod text ((label label))

Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Mar 20 15:48:16 2006 @@ -48,23 +48,23 @@ (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) - (sz (gfi:size rect)) - (pnt (gfi:location rect))) - (if (gfi:null-handle-p hdwp) - (gfs::set-window-pos (gfi:handle (car k)) + (sz (gfs:size rect)) + (pnt (gfs:location rect))) + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) +window-pos-flags+) (setf hdwp (gfs::defer-window-pos hdwp - (gfi:handle (car k)) + (gfs:handle (car k)) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) +window-pos-flags+))))) - (unless (gfi:null-handle-p hdwp) + (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))))

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Mar 20 15:48:16 2006 @@ -185,44 +185,44 @@ ;;;

(defmethod check ((it menu-item) flag) - (let ((hmenu (gfi:handle it))) + (let ((hmenu (gfs:handle it))) (check-menuitem hmenu (item-id it) flag)))

(defmethod checked-p ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (is-menuitem-checked hmenu (item-id it))))

-(defmethod gfi:dispose ((it menu-item)) +(defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) (let ((id (item-id it)) (owner (item-owner it))) (unless (null owner) - (gfs::remove-menu (gfi:handle owner) id gfs::+mf-bycommand+) + (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfi:dispose child-menu)))) + (gfs:dispose child-menu)))) (setf (item-id it) 0) - (setf (slot-value it 'gfi:handle) nil))) + (setf (slot-value it 'gfs:handle) nil)))

(defmethod enable ((it menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfi:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle it) (item-id it) bits)))

(defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfi:handle it) (item-id it)) + (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) gfs::+mfs-enabled+) gfs::+mfs-enabled+))

(defmethod item-owner ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (let ((m (get-widget (thread-context) hmenu))) (if (null m) @@ -230,13 +230,13 @@ m)))

(defmethod text ((it menu-item)) - (let ((hmenu (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs: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 (gfi:handle it))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs:handle it))) + (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) (set-menuitem-text hmenu (item-id it) str)))

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Mar 20 15:48:16 2006 @@ -204,10 +204,10 @@ (defmethod define-separator ((gen win32-menu-generator)) (let* ((owner (first (menu-stack-of gen))) (it (make-instance 'menu-item)) - (hmenu (gfi:handle owner))) + (hmenu (gfs:handle owner))) (put-menuitem (thread-context) it) (insert-separator hmenu) - (setf (slot-value it 'gfi:handle) hmenu) + (setf (slot-value it 'gfs:handle) hmenu) (vector-push-extend it (items owner))))

(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)

Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Mar 20 15:48:16 2006 @@ -111,10 +111,10 @@ (error 'gfs::win32-error :detail "insert-menu-item failed"))))

(defun sub-menu (m index) - (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)) + (if (gfs:disposed-p m) + (error 'gfs:disposed-error)) + (let ((hwnd (gfs::get-submenu (gfs:handle m) index))) + (if (not (gfs:null-handle-p hwnd)) (get-widget (thread-context) hwnd) nil)))

@@ -133,7 +133,7 @@ (defmethod append-item ((owner menu) text image disp) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) - (hmenu (gfi:handle owner)) + (hmenu (gfs:handle owner)) (item (create-menuitem-with-callback hmenu disp))) (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) @@ -142,12 +142,12 @@ item))

(defmethod append-submenu ((parent menu) text (submenu menu) disp) - (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) - (error 'gfi:disposed-error)) + (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) + (error 'gfs:disposed-error)) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) - (hparent (gfi:handle parent)) - (hmenu (gfi:handle submenu)) + (hparent (gfs:handle parent)) + (hmenu (gfs:handle submenu)) (item (make-instance 'menu-item :handle hparent))) (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) @@ -168,14 +168,14 @@

(defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) - (remove-widget tc (gfi:handle menu)) + (remove-widget tc (gfs:handle menu)) (remove-menuitem tc item)))

-(defmethod gfi:dispose ((m menu)) +(defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfi:handle m))) + (let ((hwnd (gfs:handle m))) (remove-widget (thread-context) hwnd) - (if (not (gfi:null-handle-p hwnd)) + (if (not (gfs: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)) + (setf (slot-value m 'gfs:handle) nil))

Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Mar 20 15:48:16 2006 @@ -64,8 +64,8 @@ (defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p parent) + (error 'gfs:disposed-error)) (if (not (listp style)) (setf style (list style))) (init-window win +panel-window-classname+ #'register-panel-window-class style parent ""))

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Mar 20 15:48:16 2006 @@ -41,10 +41,10 @@ (event-time :initform 0 :accessor event-time) (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) - (mouse-event-pnt :initform (gfi:make-point) :accessor mouse-event-pnt) - (move-event-pnt :initform (gfi:make-point) :accessor move-event-pnt) + (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) + (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-menuitem-id :initform 10000 :reader next-menuitem-id) - (size-event-size :initform (gfi:make-size) :accessor size-event-size) + (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -91,14 +91,14 @@ "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) (when tmp-widget - (setf (slot-value tmp-widget 'gfi:handle) hwnd) + (setf (slot-value tmp-widget 'gfs:handle) hwnd) (return-from get-widget tmp-widget))) - (unless (gfi:null-handle-p hwnd) + (unless (gfs:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))

(defmethod put-widget ((tc thread-context) (w widget)) "Add the specified widget to the widget table using its native handle as the key." - (setf (gethash (cffi:pointer-address (gfi:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) + (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w))

(defmethod remove-widget ((tc thread-context) hwnd) "Remove the widget object corresponding to the specified native window handle."

Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Mar 20 15:48:16 2006 @@ -110,17 +110,17 @@ (flatten style)) (values std-flags ex-flags)))

-(defmethod gfi:dispose ((win top-level)) +(defmethod gfs:dispose ((win top-level)) (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfi:handle m)))) + (remove-widget (thread-context) (gfs:handle m)))) (call-next-method))

(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) (unless (null owner) - (if (gfi:disposed-p owner) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error))) (if (null title) (setf title +default-window-title+)) (if (not (listp style)) @@ -128,12 +128,12 @@ (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title))

(defmethod menu-bar :before ((win top-level)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)))

(defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfi:handle win)))) - (if (gfi:null-handle-p hmenu) + (let ((hmenu (gfs::get-menu (gfs:handle win)))) + (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) (if (null m) @@ -142,31 +142,31 @@

(defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)))

(defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfi:handle win)) + (let* ((hwnd (gfs:handle win)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) - (unless (gfi:null-handle-p hmenu) + (unless (gfs:null-handle-p hmenu) (gfs::destroy-menu hmenu)) (unless (null old-menu) - (gfi:dispose old-menu)) - (gfs::set-menu hwnd (gfi:handle m)) + (gfs:dispose old-menu)) + (gfs::set-menu hwnd (gfs:handle m)) (gfs::draw-menu-bar hwnd)))

(defmethod text :before ((win top-level)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)))

(defmethod text ((win top-level)) (get-widget-text win))

(defmethod (setf text) :before (str (win top-level)) (declare (ignore str)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)))

(defmethod (setf text) (str (win top-level)) (set-widget-text win str))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 15:48:16 2006 @@ -36,7 +36,7 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects."))

-(defclass event-source (gfi:native-object) +(defclass event-source (gfs:native-object) ((dispatcher :accessor dispatcher :initarg :dispatcher

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 15:48:16 2006 @@ -57,7 +57,7 @@ (defun clear-all (w) (let ((count (gfw:item-count w))) (unless (zerop count) - (gfw:clear-span w (gfi:make-span :start 0 :end (1- count)))))) + (gfw:clear-span w (gfs: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) @@ -84,10 +84,10 @@ (mapcan (function flatten) tree)))

(defun get-widget-text (w) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) (let* ((text "") - (hwnd (gfi:handle w)) + (hwnd (gfs:handle w)) (len (gfs::get-window-text-length hwnd))) (unless (zerop len) (incf len) @@ -105,10 +105,10 @@ 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)) + (when (zerop (gfs::get-window-info (gfs: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)))) + (setf (gfs:point-x pnt) gfs::windowleft) + (setf (gfs:point-y pnt) gfs::windowtop))))

(defun outer-size (w sz) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -119,26 +119,26 @@ 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)) + (when (zerop (gfs::get-window-info (gfs: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))))) + (setf (gfs:size-width sz) (- gfs::windowright gfs::windowleft)) + (setf (gfs:size-height sz) (- gfs::windowbottom gfs::windowtop)))))

(defun set-widget-text (w str) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (gfs::set-window-text (gfi:handle w) str)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) + (gfs::set-window-text (gfs:handle w) str))

(defun widget-text-size (widget dt-flags width-hint) - (let* ((hwnd (gfi:handle widget)) + (let* ((hwnd (gfs:handle widget)) (str (text widget)) (len (length str)) - (sz (gfi:make-size)) + (sz (gfs:make-size)) (hfont nil)) (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) - (gfs:with-retrieved-dc (hwnd hdc) + (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) - (gfs:with-hfont-selected (hdc hfont) + (gfs::with-hfont-selected (hdc hfont) (when (> len 0) (cffi:with-foreign-object (rect-ptr 'gfs::rect) (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) @@ -146,13 +146,13 @@ (if (> width-hint 0) (setf gfs::right width-hint)) (gfs::draw-text hdc str -1 rect-ptr dt-flags (cffi:null-pointer)) - (setf (gfi:size-width sz) (- gfs::right gfs::left)) - (setf (gfi:size-height sz) (- gfs::bottom gfs::top))))) - (when (or (zerop len) (zerop (gfi:size-height sz))) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))) + (when (or (zerop len) (zerop (gfs:size-height sz))) (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) (if (zerop (gfs::get-text-metrics hdc tm-ptr)) (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfi:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) + (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) sz))

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Mar 20 15:48:16 2006 @@ -35,57 +35,57 @@

(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher)) (declare (ignore text image disp)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod clear-item :before ((w widget-with-items) index) (declare (ignore index)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod clear-item ((w widget-with-items) index) (let ((it (item-at w index))) (delete it (items w) :test #'items-equal-p) - (if (gfi:disposed-p it) - (error 'gfi:disposed-error)) - (gfi:dispose it))) + (if (gfs:disposed-p it) + (error 'gfs:disposed-error)) + (gfs:dispose it)))

-(defmethod clear-span :before ((w widget-with-items) (sp gfi:span)) +(defmethod clear-span :before ((w widget-with-items) (sp gfs:span)) (declare (ignore sp)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

-(defmethod clear-span ((w widget-with-items) (sp gfi:span)) - (dotimes (i (1+ (- (gfi:span-end sp) (gfi:span-start sp)))) - (clear-item w (gfi:span-start sp)))) +(defmethod clear-span ((w widget-with-items) (sp gfs:span)) + (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) + (clear-item w (gfs:span-start sp))))

(defmethod item-at :before ((w widget-with-items) index) (declare (ignore index)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod item-at ((w widget-with-items) index) (elt (items w) index))

(defmethod (setf item-at) :before (index (it item) (w widget-with-items)) (declare (ignorable index it)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod (setf item-at) (index (it item) (w widget-with-items)) (error 'gfs:toolkit-error :detail "not yet implemented"))

(defmethod item-count :before ((w widget-with-items)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod item-count ((w widget-with-items)) (length (items w)))

(defmethod item-index :before ((w widget-with-items) (it item)) (declare (ignore it)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod item-index ((w widget-with-items) (it item)) (let ((pos (position it (items w) :test #'items-equal-p)))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Mar 20 15:48:16 2006 @@ -42,24 +42,24 @@ ;;;

(defmethod ancestor-p :before ((ancestor widget) (descendant widget)) - (if (or (gfi:disposed-p ancestor) (gfi:disposed-p descendant)) - (error 'gfi:disposed-error))) + (if (or (gfs:disposed-p ancestor) (gfs:disposed-p descendant)) + (error 'gfs:disposed-error)))

(defmethod ancestor-p ((ancestor widget) (descendant widget)) - (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) + (let* ((parent-hwnd (gfs::get-ancestor (gfs:handle descendant) gfs::+ga-parent+)) (parent (get-widget (thread-context) parent-hwnd))) - (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) + (if (cffi:pointer-eq (gfs:handle ancestor) parent-hwnd) (return-from ancestor-p t)) (if (null parent) (error 'gfs:toolkit-error :detail "no widget for parent handle")) (ancestor-p ancestor parent)))

(defmethod border-width :before ((widget widget)) - (if (gfi:disposed-p widget) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)))

(defmethod border-width ((widget widget)) - (let* ((hwnd (gfi:handle widget)) + (let* ((hwnd (gfs:handle widget)) (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) (when (logand bits gfs::+ws-ex-clientedge+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -71,16 +71,16 @@ 0))

(defmethod checked-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod checked-p ((w widget)) (declare (ignore w)) nil)

(defmethod client-size :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -91,38 +91,38 @@ 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)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) - (gfi:make-size :width (- gfs::clientright gfs::clientleft) + (gfs:make-size :width (- gfs::clientright gfs::clientleft) :height (- gfs::clientbottom gfs::clienttop)))))

-(defmethod gfi:dispose ((w widget)) +(defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) (event-dispose (dispatcher w) w 0)) - (let ((hwnd (gfi:handle w))) - (if (not (gfi:null-handle-p hwnd)) + (let ((hwnd (gfs:handle w))) + (if (not (gfs: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)) + (setf (slot-value w 'gfs:handle) nil))

(defmethod enable :before ((w widget) flag) (declare (ignore flag)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod enable ((w widget) flag) - (gfs::enable-window (gfi:handle w) (if (null flag) 0 1))) + (gfs::enable-window (gfs:handle w) (if (null flag) 0 1)))

(defmethod enabled-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod enabled-p ((w widget)) - (not (zerop (gfs::is-window-enabled (gfi:handle w))))) + (not (zerop (gfs::is-window-enabled (gfs:handle w)))))

(defmethod location :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod location ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) @@ -131,98 +131,98 @@ gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfi:handle w) pnt-ptr) - (gfi:make-point :x gfs::x :y gfs::y)))))) + (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs:make-point :x gfs::x :y gfs::y))))))

-(defmethod (setf location) :before ((pnt gfi:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (w widget)) (declare (ignore pnt)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

-(defmethod (setf location) ((pnt gfi:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfi:handle w) +(defmethod (setf location) ((pnt gfs:point) (w widget)) + (if (zerop (gfs::set-window-pos (gfs:handle w) (cffi:null-pointer) - (gfi:point-x pnt) - (gfi:point-y pnt) + (gfs:point-x pnt) + (gfs:point-y pnt) 0 0 gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed")))

(defmethod pack :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1)))

(defmethod redraw :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod redraw ((w widget)) - (let ((hwnd (gfi:handle w))) - (unless (gfi:null-handle-p hwnd) + (let ((hwnd (gfs:handle w))) + (unless (gfs:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1))))

(defmethod selected-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod selected-p ((w widget)) (declare (ignore w)) nil)

(defmethod size :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod size ((w widget)) (client-size w))

-(defmethod (setf size) :before ((sz gfi:size) (w widget)) +(defmethod (setf size) :before ((sz gfs:size) (w widget)) (declare (ignore sz)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

-(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) +(defmethod (setf size) ((sz gfs:size) (w widget)) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)) + (if (zerop (gfs::set-window-pos (gfs:handle w) (cffi:null-pointer) 0 0 - (gfi:size-width sz) - (gfi:size-height sz) + (gfs:size-width sz) + (gfs:size-height sz) gfs::+swp-nomove+)) (error 'gfs:win32-error :detail "set-window-pos failed")))

(defmethod show :before ((w widget) flag) (declare (ignore flag)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod show ((w widget) flag) - (gfs::show-window (gfi:handle w) + (gfs::show-window (gfs:handle w) (if flag gfs::+sw-showna+ gfs::+sw-hide+)))

(defmethod update :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod update ((w widget)) - (let ((hwnd (gfi:handle w))) - (unless (gfi:null-handle-p hwnd) + (let ((hwnd (gfs:handle w))) + (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd))))

(defmethod visible-p :before ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p w) + (error 'gfs:disposed-error)))

(defmethod visible-p ((w widget)) - (not (zerop (gfs::is-window-visible (gfi:handle w))))) + (not (zerop (gfs::is-window-visible (gfs:handle w)))))

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Mar 20 15:48:16 2006 @@ -45,11 +45,11 @@ (compute-style-flags win style) (create-window classname text - (if (null parent) (cffi:null-pointer) (gfi:handle parent)) + (if (null parent) (cffi:null-pointer) (gfs:handle parent)) std-style ex-style)) (clear-widget-in-progress tc) - (let ((hwnd (gfi:handle win))) + (let ((hwnd (gfs:handle win))) (if (not hwnd) ; handle slot should have been set during create-window (error 'gfs:win32-error :detail "create-window failed")) (put-widget tc win)))) @@ -84,17 +84,17 @@ (let ((tc (thread-context))) (push-child-visitor-func tc func) (unwind-protect -#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) +#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfi:handle win))) + (cffi:pointer-address (gfs:handle win))) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (setf ptr (ffi:set-foreign-pointer (ffi:unsigned-foreign-address - (cffi:pointer-address (gfi:handle win))) + (cffi:pointer-address (gfs:handle win))) ptr)) (gfs::enum-child-windows ptr #'child_window_visitor - (cffi:pointer-address (gfi:handle win)))) + (cffi:pointer-address (gfs:handle win)))) (pop-child-visitor-func tc))) nil)

@@ -152,40 +152,40 @@ ;; (let ((client-sz (client-size win)) (outer-sz (size win)) - (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) - :height (gfi:size-height desired-client-size)))) - (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz) - (gfi:size-width client-sz))) - (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz) - (gfi:size-height client-sz))) + (trim-sz (gfs:make-size :width (gfs:size-width desired-client-size) + :height (gfs:size-height desired-client-size)))) + (incf (gfs:size-width trim-sz) (- (gfs:size-width outer-sz) + (gfs:size-width client-sz))) + (incf (gfs:size-height trim-sz) (- (gfs:size-height outer-sz) + (gfs:size-height client-sz))) trim-sz))

(defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)))

(defmethod enable-layout ((win window) flag) (setf (slot-value win 'layout-p) flag) (if flag (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz))))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))))

(defmethod event-resize ((d event-dispatcher) (win window) time size type) (declare (ignorable d time size type)) (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))

(defmethod location ((win window)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error)) - (let ((pnt (gfi:make-point))) + (if (gfs:disposed-p win) + (error 'gfs:disposed-error)) + (let ((pnt (gfs:make-point))) (outer-location win pnt) pnt))

(defmethod layout ((win window)) (let ((sz (client-size win))) - (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) + (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))

(defmethod pack ((win window)) (perform-layout win -1 -1) @@ -201,9 +201,9 @@ (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) - (gfs::update-window (gfi:handle win))) + (gfs::update-window (gfs:handle win)))

(defmethod size ((win window)) - (let ((sz (gfi:make-size))) + (let ((sz (gfs:make-size))) (outer-size win sz) sz))