[graphic-forms-cvs] r58 - in trunk: . src src/intrinsics/datastructs src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 20 20:48:20 UTC 2006
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+))
, at 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))
, at 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"))
, at 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))
More information about the Graphic-forms-cvs
mailing list