February 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r8 - in trunk: . src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Feb '06

13 Feb '06

Author: junrue Date: Mon Feb 13 00:52:17 2006 New Revision: 8 Added: trunk/src/uitoolkit/widgets/thread-context.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: moved majority of global data into pre-thread data structure Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Feb 13 00:52:17 2006 @@ -87,6 +87,7 @@ :components ((:file "widget-constants") (:file "widget-classes") + (:file "thread-context") (:file "message-generics") (:file "event-generics") (:file "layout-generics") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Feb 13 00:52:17 2006 @@ -82,12 +82,6 @@ ;; methods, functions, macros #:detail - #:get-menuitem-text - #:insert-menuitem - #:insert-separator - #:insert-submenu - #:process-message - #:register-window-class #:with-retrieved-dc ;; conditions Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Mon Feb 13 00:52:17 2006 @@ -306,6 +306,14 @@ (remove-msg UINT)) (defcfun + ("PostMessageA" post-message) + BOOL + (hwnd HANDLE) + (msg UINT) + (wparam WPARAM) + (lparam LPARAM)) + +(defcfun ("PostQuitMessage" post-quit-message) :void (exit-code INT)) @@ -339,8 +347,8 @@ LRESULT (hwnd HANDLE) (msg UINT) - (wp WPARAM) - (lp WPARAM)) + (wparam WPARAM) + (lparam WPARAM)) (defcfun ("SetMenu" set-menu) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Feb 13 00:52:17 2006 @@ -51,7 +51,7 @@ (defmethod realize :after ((ctl control) parent &rest style) (let ((hwnd (gfi:handle ctl))) (subclass-wndproc hwnd) - (put-widget ctl) + (put-widget (thread-context) ctl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfi:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Feb 13 00:52:17 2006 @@ -38,12 +38,6 @@ gfs::+pm-qs-input+ gfs::+pm-qs-postmessage+)) -(defvar *last-event-time* 0) -(defvar *last-virtual-key* 0) -(defvar *mouse-event-pnt* (gfi:make-point)) -(defvar *move-event-pnt* (gfi:make-point)) -(defvar *size-event-size* (gfi:make-size)) - ;;; ;;; window procedures ;;; @@ -79,7 +73,7 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf *last-event-time* gfs::time) + (setf (event-time (thread-context)) gfs::time) (when (zerop gm) (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) @@ -103,11 +97,12 @@ (= (gfs::get-key-state key-code) 1)) (defun process-mouse-message (fn hwnd lparam btn-symbol) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (when w - (setf (gfi:point-x *mouse-event-pnt*) (lo-word lparam)) - (setf (gfi:point-y *mouse-event-pnt*) (hi-word lparam)) - (funcall fn (dispatcher w) *last-event-time* *mouse-event-pnt* btn-symbol))) + (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam)) + (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam)) + (funcall fn (dispatcher w) (event-time tc) (mouse-event-pnt tc) btn-symbol))) 0) (defun get-class-wndproc (hwnd) @@ -132,35 +127,37 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (if w - (event-close (dispatcher w) *last-event-time*) + (event-close (dispatcher w) (event-time tc)) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) - (let ((wparam-hi (hi-word wparam)) - (owner (get-widget hwnd))) + (let* ((tc (thread-context)) + (wparam-hi (hi-word wparam)) + (owner (get-widget tc hwnd))) (if owner (cond ((zerop lparam) - (let ((item (get-menuitem (lo-word wparam)))) + (let ((item (get-menuitem tc (lo-word wparam)))) (if (null item) (error 'gfs:toolkit-error :detail "no menu item for id")) (unless (null (dispatcher item)) (event-select (dispatcher item) - *last-event-time* + (event-time tc) item (make-instance 'gfi:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t - (let ((w (get-widget (cffi:make-pointer lparam)))) + (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) (error 'gfs:toolkit-error :detail "no object for hwnd")) (unless (null (dispatcher w)) (event-select (dispatcher w) - *last-event-time* + (event-time tc) w (make-instance 'gfi:rectangle)))))) ; FIXME (error 'gfs:toolkit-error :detail "no object for hwnd"))) @@ -168,58 +165,63 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignorable hwnd lparam)) - (let ((menu (get-widget (cffi:make-pointer wparam)))) + (let* ((tc (thread-context)) + (menu (get-widget tc (cffi:make-pointer wparam)))) (unless (null menu) (let ((d (dispatcher menu))) (unless (null d) - (event-activate d *last-event-time*))))) + (event-activate d (event-time tc)))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignorable hwnd lparam)) ; FIXME: handle system menus - (let ((item (get-menuitem (lo-word wparam)))) + (let* ((tc (thread-context)) + (item (get-menuitem tc (lo-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d) - (event-arm d *last-event-time* item))))) + (event-arm d (event-time tc) item))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (declare (ignorable wparam lparam)) - (get-widget hwnd) ; has side-effect of setting handle slot + (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) - (let ((w (get-widget hwnd)) - (ch (code-char (lo-word wparam)))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (ch (code-char (lo-word wparam)))) (when w - (event-key-down (dispatcher w) *last-event-time* *last-virtual-key* ch))) + (event-key-down (dispatcher w) (event-time tc) (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) - (let* ((wparam-lo (lo-word wparam)) + (let* ((tc (thread-context)) + (wparam-lo (lo-word wparam)) (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget hwnd))) - (setf *last-virtual-key* wparam-lo) + (w (get-widget tc hwnd))) + (setf (virtual-key tc) wparam-lo) (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) - (event-key-down (dispatcher w) *last-event-time* wparam-lo (code-char ch)))) + (event-key-down (dispatcher w) (event-time tc) wparam-lo (code-char ch)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) - (unless (zerop *last-virtual-key*) - (let* ((wparam-lo (lo-word wparam)) - (ch (gfs::map-virtual-key wparam-lo 2)) - (w (get-widget hwnd))) - (when w - (event-key-up (dispatcher w) *last-event-time* wparam-lo (code-char ch))))) - (setf *last-virtual-key* 0) + (let ((tc (thread-context))) + (unless (zerop (virtual-key tc)) + (let* ((wparam-lo (lo-word wparam)) + (ch (gfs::map-virtual-key wparam-lo 2)) + (w (get-widget tc hwnd))) + (when w + (event-key-up (dispatcher w) (event-time tc) wparam-lo (code-char ch))))) + (setf (virtual-key tc) 0)) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam) @@ -259,23 +261,26 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) (when w - (outer-location w *move-event-pnt*) - (event-move (dispatcher w) *last-event-time* *move-event-pnt*))) + (outer-location w (move-event-pnt tc)) + (event-move (dispatcher w) (event-time tc) (move-event-pnt tc)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) - (if (and w (event-pre-move (dispatcher w) *last-event-time*)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) + (if (and w (event-pre-move (dispatcher w) (event-time tc))) 1 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd)) - (gc (make-instance 'gfg:graphics-context))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (gc (make-instance 'gfg:graphics-context))) (if w (let ((rct (make-instance 'gfi:rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) @@ -290,7 +295,7 @@ (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (unwind-protect - (event-paint (dispatcher w) *last-event-time* gc rct) + (event-paint (dispatcher w) (event-time tc) gc rct) (gfs::end-paint hwnd ps-ptr))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) @@ -309,21 +314,23 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) - (let ((w (get-widget hwnd)) - (type (cond - ((= wparam gfs::+size-maximized+) 'maximized) - ((= wparam gfs::+size-minimized+) 'minimized) - ((= wparam gfs::+size-restored+) 'restored) - (t nil)))) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd)) + (type (cond + ((= wparam gfs::+size-maximized+) 'maximized) + ((= wparam gfs::+size-minimized+) 'minimized) + ((= wparam gfs::+size-restored+) 'restored) + (t nil)))) (when w - (outer-size w *size-event-size*) - (event-resize (dispatcher w) *last-event-time* *size-event-size* type))) + (outer-size w (size-event-size tc)) + (event-resize (dispatcher w) (event-time tc) (size-event-size tc) type))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) (declare (ignorable wparam lparam)) - (let ((w (get-widget hwnd))) - (if (and w (event-pre-resize (dispatcher w) *last-event-time*)) + (let* ((tc (thread-context)) + (w (get-widget tc hwnd))) + (if (and w (event-pre-resize (dispatcher w) (event-time tc))) 1 0))) @@ -339,7 +346,7 @@ (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) (call-next-method)) ;;; Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Feb 13 00:52:17 2006 @@ -33,10 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defparameter *next-menuitem-id* 10000) - -(defvar *menuitems-by-id* (make-hash-table :test #'eql)) - ;;; ;;; helper functions ;;; @@ -177,7 +173,7 @@ (error 'gfi:disposed-error)) (let ((hwnd (gfs::get-submenu (gfi:handle m) index))) (if (not (gfi:null-handle-p hwnd)) - (get-widget hwnd) + (get-widget (thread-context) hwnd) nil))) (defun visit-menu-tree (menu fn) @@ -193,28 +189,30 @@ ;;; (defun menu-cleanup-callback (menu item) - (remove-widget (gfi:handle menu)) - (remove-menuitem item)) + (let ((tc (thread-context))) + (remove-widget tc (gfi:handle menu)) + (remove-menuitem tc item))) (defmethod gfi:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) (let ((hwnd (gfi:handle m))) - (remove-widget hwnd) + (remove-widget (thread-context) hwnd) (if (not (gfi:null-handle-p hwnd)) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) (setf (slot-value m 'gfi:handle) nil)) (defmethod item-append ((m menu) (it menu-item)) - (let ((id *next-menuitem-id*) - (hmenu (gfi:handle m))) + (let* ((tc (thread-context)) + (id (next-menuitem-id tc)) + (hmenu (gfi:handle m))) (if (gfi:null-handle-p hmenu) (error 'gfi:disposed-error)) - (setf *next-menuitem-id* (1+ id)) + (increment-menuitem-id tc) (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) (setf (item-id it) id) (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem it) + (put-menuitem tc it) (call-next-method))) ;;; @@ -223,7 +221,7 @@ (defmethod gfi:dispose ((it menu-item)) (setf (dispatcher it) nil) - (remove-menuitem it) + (remove-menuitem (thread-context) it) (let ((id (item-id it)) (owner (item-owner it))) (unless (null owner) @@ -239,7 +237,7 @@ (let ((hmenu (gfi:handle it))) (if (gfi:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget hmenu))) + (let ((m (get-widget (thread-context) hmenu))) (if (null m) (error 'gfs:toolkit-error :detail "no owner menu")) m))) @@ -444,19 +442,20 @@ (defmethod initialize-instance :after ((gen menu-generator) &key) (let ((m (make-instance 'menu :handle (gfs::create-menu)))) - (put-widget m) + (put-widget (thread-context) m) (setf (menu-stack gen) (list m)))) (defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image) - (let* ((owner (first (menu-stack gen))) + (let* ((tc (thread-context)) + (owner (first (menu-stack gen))) (it (make-instance 'menu-item :dispatcher dispatcher)) - (id *next-menuitem-id*) + (id (next-menuitem-id tc)) (hmenu (gfi:handle owner))) - (setf *next-menuitem-id* (1+ id)) + (increment-menuitem-id tc) (insert-menuitem hmenu id label (cffi:null-pointer)) (setf (item-id it) id) (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem it) + (put-menuitem tc it) (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image) @@ -467,22 +466,23 @@ (let* ((owner (first (menu-stack gen))) (it (make-instance 'menu-item)) (hmenu (gfi:handle owner))) - (put-menuitem it) + (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfi:handle) hmenu) (vector-push-extend it (items owner)))) (defmethod define-menu ((gen menu-generator) label dispatcher) - (let* ((m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) + (let* ((tc (thread-context)) + (m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) (it (make-instance 'menu-item :handle (gfi:handle parent) :dispatcher dispatcher)) - (id *next-menuitem-id*)) - (setf *next-menuitem-id* (1+ id)) + (id (next-menuitem-id tc))) + (increment-menuitem-id tc) (insert-submenu (gfi:handle parent) id label (cffi:null-pointer) (gfi:handle m)) (setf (item-id it) id) (vector-push-extend it (items parent)) (push m (menu-stack gen)) - (put-widget m) + (put-widget tc m) m)) (defmethod complete-menu ((gen menu-generator)) @@ -493,21 +493,3 @@ `(let ((,gen (make-instance 'menu-generator))) (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp) (first (menu-stack ,gen))))) - -;;; -;;; menuitems table management -;;; - -(defun get-menuitem (id) - (gethash id *menuitems-by-id*)) - -(defun put-menuitem (it) - (setf (gethash (item-id it) *menuitems-by-id*) it)) - -(defun remove-menuitem (it) - (maphash - #'(lambda (k v) - (declare (ignore v)) - (if (eql k (item-id it)) - (remhash k *menuitems-by-id*))) - *menuitems-by-id*)) Added: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Feb 13 00:52:17 2006 @@ -0,0 +1,133 @@ +;;;; +;;;; thread-context.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.widgets) + +(defclass thread-context () + ((child-visitor-stack :initform nil) + (image-loaders-by-type :initform (make-hash-table :test #'equal)) + (job-table :initform (make-hash-table :test #'equal)) + (job-table-lock :initform nil) + (event-time :initform 0 :accessor event-time) + (virtual-key :initform 0 :accessor virtual-key) + (menuitems-by-id :initform (make-hash-table :test #'equal)) + (mouse-event-pnt :initform (gfi:make-point) :accessor mouse-event-pnt) + (move-event-pnt :initform (gfi:make-point) :accessor move-event-pnt) + (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (size-event-size :initform (gfi:make-size) :accessor size-event-size) + (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (wip :initform nil)) + (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) + +;; TODO: change this when CLISP acquires MT support +;; +#+clisp (defvar *the-thread-context* nil) + +#+clisp (defun thread-context () + *the-thread-context*) + +#+lispworks (defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) + tc)) + +(defmethod call-child-visitor-func ((tc thread-context) parent child) + "Call the closure at the top of the child window visitor function stack." + (let ((fn (first (slot-value tc 'child-visitor-stack)))) + (if (null fn) + (error 'gfs:toolkit-error :detail "child visitor function stack is empty")) + (funcall fn parent child))) + +(defmethod push-child-visitor-func ((tc thread-context) func) + "Push the supplied closure onto the child window visitor function stack." + (if (not (functionp func)) + (error 'gfs:toolkit-error :detail "function argument required")) + (push func (slot-value tc 'child-visitor-stack)) + nil) + +(defmethod pop-child-visitor-func ((tc thread-context)) + "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." + (pop (slot-value tc 'child-visitor-stack))) + +(defmethod get-widget ((tc thread-context) hwnd) + "Return the widget object corresponding to the specified native window handle." + (let ((tmp-widget (slot-value tc 'wip))) + (when tmp-widget + (setf (slot-value tmp-widget 'gfi:handle) hwnd) + (return-from get-widget tmp-widget))) + (unless (gfi:null-handle-p hwnd) + (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) + +(defmethod put-widget ((tc thread-context) (w widget)) + "Add the specified widget to the widget table using its native handle as the key." + (setf (gethash (cffi:pointer-address (gfi:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) + +(defmethod remove-widget ((tc thread-context) hwnd) + "Remove the widget object corresponding to the specified native window handle." + (when (not (slot-value tc 'wip)) + (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) + +(defmethod widget-in-progress ((tc thread-context)) + "Return the widget currently under construction." + (slot-value tc 'wip)) + +(defmethod (setf widget-in-progress) ((w widget) (tc thread-context)) + "Store the widget currently under construction." + (setf (slot-value tc 'wip) w)) + +(defmethod clear-widget-in-progress ((tc thread-context)) + "Store the widget currently under construction." + (setf (slot-value tc 'wip) nil)) + +(defmethod get-menuitem ((tc thread-context) id) + "Returns the menu item identified by id." + (gethash id (slot-value tc 'menuitems-by-id))) + +(defmethod put-menuitem ((tc thread-context) (it menu-item)) + "Stores a menu item using its id as the key." + (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) + +(defmethod remove-menuitem ((tc thread-context) (it menu-item)) + "Removes the menu item using its id as the key." + (maphash + #'(lambda (k v) + (declare (ignore v)) + (if (eql k (item-id it)) + (remhash k (slot-value tc 'menuitems-by-id)))) + (slot-value tc 'menuitems-by-id))) + +(defmethod increment-menuitem-id ((tc thread-context)) + "Bump up the next menu item ID." + (incf (slot-value tc 'next-menuitem-id))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Feb 13 00:52:17 2006 @@ -35,6 +35,7 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) + (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn)) #+lispworks (defun startup (thread-name start-fn) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Feb 13 00:52:17 2006 @@ -42,7 +42,7 @@ (defmethod clear-span ((w widget-with-items) (sp gfi:span)) (loop for index from (gfi:span-start sp) to (gfi:span-end sp) - collect (clear-item w index))) + collect (clear-item w 0))) (defmethod item-append ((w widget-with-items) (i item)) (vector-push-extend i (items w))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 13 00:52:17 2006 @@ -33,10 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defvar *widgets-by-hwnd* (make-hash-table :test #'equal)) - -(defvar *widget-in-progress* nil) - ;;; ;;; helper functions ;;; @@ -47,7 +43,7 @@ (defmethod ancestor-p ((ancestor widget) (descendant widget)) (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) - (parent (get-widget parent-hwnd))) + (parent (get-widget (thread-context) parent-hwnd))) (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) (return-from ancestor-p t)) (if (null parent) @@ -136,27 +132,3 @@ (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) (gfs::update-window hwnd)))) - -;;; -;;; widget table management -;;; - -(defun clear-widget-in-progress () - (setf *widget-in-progress* nil)) - -(defun set-widget-in-progress (w) - (setf *widget-in-progress* w)) - -(defun get-widget (hwnd) - (when *widget-in-progress* - (setf (slot-value *widget-in-progress* 'gfi:handle) hwnd) - (return-from get-widget *widget-in-progress*)) - (unless (gfi:null-handle-p hwnd) - (gethash (cffi:pointer-address hwnd) *widgets-by-hwnd*))) - -(defun put-widget (w) - (setf (gethash (cffi:pointer-address (gfi:handle w)) *widgets-by-hwnd*) w)) - -(defun remove-widget (hwnd) - (when (not *widget-in-progress*) - (remhash (cffi:pointer-address hwnd) *widgets-by-hwnd*))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Feb 13 00:52:17 2006 @@ -37,8 +37,6 @@ (defconstant +default-window-title+ "New Window") -(defvar *child-visiting-functions* nil) - ;;; ;;; helper functions ;;; @@ -48,18 +46,20 @@ ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let ((child (get-widget hwnd)) - (parent (get-widget (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) parent child))) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (call-child-visitor-func tc parent child))) 1) #+clisp (defun child_window_visitor (hwnd lparam) - (let ((child (get-widget hwnd)) - (parent (get-widget (cffi:make-pointer lparam)))) - (unless (or (null child) (null parent) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) parent child))) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null child) (null parent)) + (call-child-visitor-func tc parent child))) 1) (defun visit-child-widgets (win func) @@ -68,8 +68,9 @@ ;; parent window object ;; current child widget ;; - (push func *child-visiting-functions*) - (unwind-protect + (let ((tc (thread-context))) + (push-child-visitor-func tc func) + (unwind-protect #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address (gfi:handle win))) @@ -81,7 +82,8 @@ (gfs::enum-child-windows ptr #'child_window_visitor (cffi:pointer-address (gfi:handle win)))) - (pop *child-visiting-functions*))) + (pop-child-visitor-func tc))) + nil) (defun register-window-class (class-name proc-ptr st) (let ((retval 0)) @@ -192,7 +194,7 @@ (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (gfi:handle m)))) + (remove-widget (thread-context) (gfi:handle m)))) (call-next-method)) (defmethod hide ((win window)) @@ -209,7 +211,7 @@ (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) (return-from menu-bar nil)) - (let ((m (get-widget hmenu))) + (let ((m (get-widget (thread-context) hmenu))) (if (null m) (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) @@ -217,7 +219,7 @@ (defmethod (setf menu-bar) ((m menu) (win window)) (let* ((hwnd (gfi:handle win)) (hmenu (gfs::get-menu hwnd)) - (old-menu (get-widget hmenu))) + (old-menu (get-widget (thread-context) hmenu))) (unless (gfi:null-handle-p hmenu) (gfs::destroy-menu hmenu)) (unless (null old-menu) @@ -230,29 +232,30 @@ (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) - (set-widget-in-progress win) - (register-workspace-window-class) - (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) - (create-window +workspace-window-classname+ - +default-window-title+ - (cffi:null-pointer) - std-style - ex-style)) - (clear-widget-in-progress) - (let ((hwnd (gfi:handle win))) - (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfs:win32-error :detail "create-window failed")) - (put-widget win))) + (let ((tc (thread-context))) + (setf (widget-in-progress tc) win) + (register-workspace-window-class) + (multiple-value-bind (std-style ex-style) + (compute-style-flags win style) + (create-window +workspace-window-classname+ + +default-window-title+ + (cffi:null-pointer) + std-style + ex-style)) + (clear-widget-in-progress tc) + (let ((hwnd (gfi:handle win))) + (if (not hwnd) ; handle slot should have been set during create-window + (error 'gfs:win32-error :detail "create-window failed")) + (put-widget tc win)))) (defmethod show ((win window)) (let ((hwnd (gfi:handle win))) (gfs::show-window hwnd gfs::+sw-shownormal+) (gfs::update-window hwnd))) -(defmethod size ((w widget)) - (if (gfi:disposed-p w) +(defmethod size ((win window)) + (if (gfi:disposed-p win) (error 'gfi:disposed-error)) (let ((sz (gfi:make-size))) - (outer-size w sz) + (outer-size win sz) sz))

1 0

[graphic-forms-cvs] r7 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 13 Feb '06

13 Feb '06

Author: junrue Date: Sun Feb 12 19:25:36 2006 New Revision: 7 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: now mapping widget screen coordinates to parent window coordinates; implemented enum windows callback with vendor-specific FFI because CFFI does not yet support stdcall as a language type Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Feb 12 19:25:36 2006 @@ -290,6 +290,7 @@ #:accelerator #:active #:alignment + #:ancestor-p #:append-item #:background-color #:background-pattern @@ -390,7 +391,6 @@ #:key-down-p #:key-toggled-p #:layout - #:layout-children #:layout-manager #:layout-p #:lines-visible-p @@ -458,6 +458,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-children ;; conditions )) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 12 19:25:36 2006 @@ -33,8 +33,10 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defconstant +btn-text-1+ "Push Me") -(defconstant +btn-text-2+ "Again!") +(defconstant +btn-text-before+ "Push Me") +(defconstant +btn-text-after+ "Again!") + +(defvar *button-counter* 0) (defparameter *layout-tester-win* nil) @@ -50,18 +52,55 @@ (declare (ignore time)) (exit-layout-tester)) -(defclass layout-tester-btn-events (gfw:event-dispatcher) - ((button - :accessor button - :initarg :button +(defclass layout-tester-widget-events (gfw:event-dispatcher) + ((widget + :accessor widget + :initarg :widget :initform nil) (toggle-fn :accessor toggle-fn - :initform nil))) + :initform nil) + (id + :accessor id + :initarg :id + :initform 0))) + +(defun add-layout-tester-widget (primary-type sub-type) + (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) + (w (make-instance primary-type :dispatcher be))) + (setf (widget be) w) + (cond + ((eql sub-type :push-button) + (setf (toggle-fn be) (let ((flag nil)) + #'(lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) + (incf *button-counter*))) + (gfw:realize w *layout-tester-win* sub-type) + (setf (gfw:text w) (funcall (toggle-fn be))) + (let ((pnt (gfi:make-point))) + (gfw:with-children (*layout-tester-win* child-list) + (let ((last-child (car (last (cdr child-list))))) + (unless (null last-child) +(format t "****~%") +(format t "widget: ~a~%" (gfw:text last-child)) +(format t "location: ~a~%" (gfw:location last-child)) +(format t "size: ~a~%" (gfw:size last-child)) + (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child)) + (gfi:size-width (gfw:size last-child))))))) + (setf (gfw:location w) pnt) +(format t "++++~%") +(format t "location: ~a~%" (gfw:location w))) + (setf (gfw:size w) (gfw:preferred-size w -1 -1)))) -(defmethod gfw:event-select ((d layout-tester-btn-events) time item rect) +(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect)) - (let ((btn (button d))) + (let ((btn (widget d))) (setf (gfw:text btn) (funcall (toggle-fn d))))) (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) @@ -71,13 +110,12 @@ (let* ((mb (gfw:menu-bar *layout-tester-win*)) (menu (gfw:sub-menu mb 1))) (gfw:clear-all menu) - (gfw::visit-child-widgets *layout-tester-win* - #'(lambda (child val) - (declare (ignore val)) - (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) - (setf (gfw:text it) (gfw:text child)))) - 0))) + (gfw:with-children (*layout-tester-win* child-list) + (mapc #'(lambda (child) + (let ((it (make-instance 'gfw:menu-item))) + (gfw:item-append menu it) + (setf (gfw:text it) (gfw:text child)))) + child-list)))) (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -86,33 +124,21 @@ (exit-layout-tester)) (defun run-layout-tester-internal () + (setf *button-counter* 0) (let* ((menubar nil) (fed (make-instance 'layout-tester-exit-dispatcher)) - (be (make-instance 'layout-tester-btn-events)) - (cmd (make-instance 'layout-tester-child-menu-dispatcher)) - (btn (make-instance 'gfw:button :dispatcher be))) - (setf (button be) btn) - (setf (toggle-fn be) (let ((flag nil)) - #'(lambda () - (if (null flag) - (progn - (setf flag t) - +btn-text-1+) - (progn - (setf flag nil) - +btn-text-2+))))) + (cmd (make-instance 'layout-tester-child-menu-dispatcher))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events))) (gfw:realize *layout-tester-win* nil :style-workspace) - (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 200 :height 150)) + (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150)) (setf menubar (gfw:defmenusystem `(((:menu "&File") (:menuitem "E&xit" :dispatcher ,fed)) ((:menu "&Children" :dispatcher ,cmd) (:menuitem :separator))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) - (gfw:realize btn *layout-tester-win* :push-button) - (setf (gfw:text btn) (funcall (toggle-fn be))) - (setf (gfw:location btn) (gfi:make-point)) - (setf (gfw:size btn) (gfw:preferred-size btn -1 -1)) + (add-layout-tester-widget 'gfw:button :push-button) + (add-layout-tester-widget 'gfw:button :push-button) + (add-layout-tester-widget 'gfw:button :push-button) (gfw:show *layout-tester-win*) (gfw:run-default-message-loop))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Feb 12 19:25:36 2006 @@ -172,6 +172,10 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +ga-parent+ 1) +(defconstant +ga-root+ 2) +(defconstant +ga-rootowner+ 3) + (defconstant +gclp-menuname+ -8) (defconstant +gclp-hbrbackground+ -10) (defconstant +gclp-hcursor+ -12) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 12 19:25:36 2006 @@ -39,6 +39,12 @@ (load-foreign-library "user32.dll") (defcfun + ("GetAncestor" get-ancestor) + HANDLE + (hwnd HANDLE) + (flags UINT)) + +(defcfun ("BeginPaint" begin-paint) HANDLE (hwnd HANDLE) @@ -323,6 +329,12 @@ (flags UINT)) (defcfun + ("ScreenToClient" screen-to-client) + BOOL + (hwnd HANDLE) + (pnt :pointer)) + +(defcfun ("SendMessageA" send-message) LRESULT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Feb 12 19:25:36 2006 @@ -42,6 +42,9 @@ (defgeneric alignment (object) (:documentation "Returns an integer describing the position of internal content within the object.")) +(defgeneric ancestor-p (ancestor descendant) + (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) + (defgeneric append-item (object new-item) (:documentation "Adds the new item to the end of the object's list.")) @@ -219,9 +222,6 @@ (defgeneric layout (object) (:documentation "Set the size and location of this object's children.")) -(defgeneric layout-children (object) - (:documentation "Return the children of this object which are organized via a layout manager.")) - (defgeneric layout-manager (object) (:documentation "Returns the layout manager associated with this object.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Feb 12 19:25:36 2006 @@ -45,6 +45,15 @@ ;;; widget methods ;;; +(defmethod ancestor-p ((ancestor widget) (descendant widget)) + (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) + (parent (get-widget parent-hwnd))) + (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd) + (return-from ancestor-p t)) + (if (null parent) + (error 'gfs:toolkit-error :detail "no widget for parent handle")) + (ancestor-p ancestor parent))) + (defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -57,7 +66,7 @@ (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (gfi:make-size :width (- gfs::clientright gfs::clientleft) - :height (- gfs::clientbottom gfs::clienttop))))) + :height (- gfs::clientbottom gfs::clienttop))))) (defmethod gfi:dispose ((w widget)) (unless (null (dispatcher w)) @@ -73,11 +82,21 @@ (error 'gfi:disposed-error))) (defmethod location ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (let ((pnt (gfi:make-point))) - (outer-location w pnt) - pnt)) + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize + gfs::clientleft + gfs::clienttop) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (error 'gfs:win32-error :detail "get-window-info failed")) + (cffi:with-foreign-object (pnt-ptr 'gfs::point) + (cffi:with-foreign-slots ((gfs::x gfs::y) + pnt-ptr gfs::point) + (setf gfs::x gfs::clientleft) + (setf gfs::y gfs::clienttop) + (gfs::screen-to-client (gfi:handle w) pnt-ptr) + (gfi:make-point :x gfs::x :y gfs::y)))))) (defmethod (setf location) ((pnt gfi:point) (w widget)) (if (gfi:disposed-p w) @@ -96,11 +115,7 @@ (gfs::invalidate-rect hwnd nil 1)))) (defmethod size ((w widget)) - (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) - (let ((sz (gfi:make-size))) - (outer-size w sz) - sz)) + (client-size w)) (defmethod (setf size) ((sz gfi:size) (w widget)) (if (gfi:disposed-p w) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 12 19:25:36 2006 @@ -48,29 +48,31 @@ ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (let ((w (get-widget hwnd))) - (unless (or (null w) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) w lparam))) + (let ((child (get-widget hwnd)) + (parent (get-widget (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child) (null *child-visiting-functions*)) + (funcall (first *child-visiting-functions*) parent child))) 1) #+clisp (defun child_window_visitor (hwnd lparam) - (let ((w (get-widget hwnd))) - (unless (or (null w) (null *child-visiting-functions*)) - (funcall (first *child-visiting-functions*) w lparam))) + (let ((child (get-widget hwnd)) + (parent (get-widget (cffi:make-pointer lparam)))) + (unless (or (null child) (null parent) (null *child-visiting-functions*)) + (funcall (first *child-visiting-functions*) parent child))) 1) -(defun visit-child-widgets (win func val) +(defun visit-child-widgets (win func) ;; - ;; supplied closure should accept two parameters: + ;; supplied closure should expect two parameters: + ;; parent window object ;; current child widget - ;; long value passed to visit-child-windows ;; (push func *child-visiting-functions*) (unwind-protect #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) (fli:make-pointer :symbol-name "child_window_visitor") - 0) + (cffi:pointer-address (gfi:handle win))) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (setf ptr (ffi:set-foreign-pointer (ffi:unsigned-foreign-address @@ -78,7 +80,7 @@ ptr)) (gfs::enum-child-windows ptr #'child_window_visitor - 0)) + (cffi:pointer-address (gfi:handle win)))) (pop *child-visiting-functions*))) (defun register-window-class (class-name proc-ptr st) @@ -117,6 +119,13 @@ retval (error 'gfs::win32-error :detail "register-class failed"))))))) +(defmacro with-children ((win var) &body body) + `(let ((,var nil)) + (visit-child-widgets ,win #'(lambda (parent child) + (if (gfw:ancestor-p parent child) + (push child ,var)))) + ,@body)) + (defun register-workspace-window-class () (register-window-class +workspace-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) @@ -189,6 +198,13 @@ (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+)) +(defmethod location ((w window)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((pnt (gfi:make-point))) + (outer-location w pnt) + pnt)) + (defmethod menu-bar ((win window)) (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) @@ -233,3 +249,10 @@ (let ((hwnd (gfi:handle win))) (gfs::show-window hwnd gfs::+sw-shownormal+) (gfs::update-window hwnd))) + +(defmethod size ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((sz (gfi:make-size))) + (outer-size w sz) + sz))

1 0

[graphic-forms-cvs] r6 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 12 Feb '06

12 Feb '06

Author: junrue Date: Sun Feb 12 02:29:46 2006 New Revision: 6 Modified: trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: cannot specific stdcall for CFFI callable funcs, use vendor-specific FFI instead for visit-child-widgets Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 12 02:29:46 2006 @@ -116,12 +116,40 @@ (hwnd HANDLE) (ps LPTR)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| (defcfun ("EnumChildWindows" enum-child-windows) BOOL (hwnd HANDLE) (func :pointer) (lparam LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-child-windows "EnumChildWindows" :result-type :int) + ((hwnd :pointer) + (func :pointer) + (lparam :long))) + +#+clisp +(ffi:def-call-out enum-child-windows + (:name "EnumChildWindows") + (:library "user32.dll") + (:language :stdc) + (:arguments (hwnd ffi:c-pointer) + (func (ffi:c-function + (:arguments + (hwnd ffi:c-pointer) + (lparam ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (lparam ffi:long)) + (:return-type ffi:int)) (defcfun ("GetAsyncKeyState" get-async-key-state) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Feb 12 02:29:46 2006 @@ -79,6 +79,7 @@ (hwnd (gfi:handle w)) (len (gfs::get-window-text-length hwnd))) (unless (zerop len) + (incf len) (let ((str-ptr (cffi:foreign-alloc :char :count len))) (unwind-protect (unless (zerop (gfs::get-window-text hwnd str-ptr len)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 12 02:29:46 2006 @@ -43,15 +43,21 @@ ;;; helper functions ;;; -;; FIXME: causes GPF -;; -(cffi:defcallback child_hwnd_collector - gfs::BOOL - ((hwnd gfs::HANDLE) - (lparam gfs::LPARAM)) +#+lispworks +(fli:define-foreign-callable + ("child_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) (let ((w (get-widget hwnd))) (unless (or (null w) (null *child-visiting-functions*)) - (funcall (car *child-visiting-functions*) w lparam))) + (funcall (first *child-visiting-functions*) w lparam))) + 1) + +#+clisp +(defun child_window_visitor (hwnd lparam) + (let ((w (get-widget hwnd))) + (unless (or (null w) (null *child-visiting-functions*)) + (funcall (first *child-visiting-functions*) w lparam))) 1) (defun visit-child-widgets (win func val) @@ -62,7 +68,17 @@ ;; (push func *child-visiting-functions*) (unwind-protect - (gfs::enum-child-windows (gfi:handle win) (cffi:get-callback 'child_hwnd_collector) val) +#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win))) + (fli:make-pointer :symbol-name "child_window_visitor") + 0) +#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (setf ptr (ffi:set-foreign-pointer + (ffi:unsigned-foreign-address + (cffi:pointer-address (gfi:handle win))) + ptr)) + (gfs::enum-child-windows ptr + #'child_window_visitor + 0)) (pop *child-visiting-functions*))) (defun register-window-class (class-name proc-ptr st)

1 0

[graphic-forms-cvs] r5 - in trunk: . src src/intrinsics/datastructs src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 11 Feb '06

11 Feb '06

Author: junrue Date: Sat Feb 11 00:39:07 2006 New Revision: 5 Modified: trunk/README.txt trunk/build.lisp trunk/src/intrinsics/datastructs/datastruct-classes.lisp trunk/src/intrinsics/system/native-classes.lisp trunk/src/intrinsics/system/native-conditions.lisp trunk/src/intrinsics/system/native-object-generics.lisp trunk/src/intrinsics/system/native-object.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: package consolidation Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sat Feb 11 00:39:07 2006 @@ -23,7 +23,7 @@ Execute the following forms from your REPL: (load "build.lisp") - (graphic-forms-system::build) + (gfsys::build) How To Run Tests And Samples Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sat Feb 11 00:39:07 2006 @@ -32,7 +32,7 @@ ;;;; (defpackage #:graphic-forms-system - (:nicknames #:gfs) + (:nicknames #:gfsys) (:use :common-lisp :asdf)) (in-package #:graphic-forms-system) Modified: trunk/src/intrinsics/datastructs/datastruct-classes.lisp ============================================================================== --- trunk/src/intrinsics/datastructs/datastruct-classes.lisp (original) +++ trunk/src/intrinsics/datastructs/datastruct-classes.lisp Sat Feb 11 00:39:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; datastruct-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.intrinsics.datastructs) +(in-package :graphic-forms.intrinsics) (defstruct point (x 0) (y 0) (z 0)) Modified: trunk/src/intrinsics/system/native-classes.lisp ============================================================================== --- trunk/src/intrinsics/system/native-classes.lisp (original) +++ trunk/src/intrinsics/system/native-classes.lisp Sat Feb 11 00:39:07 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.intrinsics.system) +(in-package :graphic-forms.intrinsics) (defclass native-object () ((handle Modified: trunk/src/intrinsics/system/native-conditions.lisp ============================================================================== --- trunk/src/intrinsics/system/native-conditions.lisp (original) +++ trunk/src/intrinsics/system/native-conditions.lisp Sat Feb 11 00:39:07 2006 @@ -31,6 +31,6 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.intrinsics.system) +(in-package :graphic-forms.intrinsics) (define-condition disposed-error (error) ()) Modified: trunk/src/intrinsics/system/native-object-generics.lisp ============================================================================== --- trunk/src/intrinsics/system/native-object-generics.lisp (original) +++ trunk/src/intrinsics/system/native-object-generics.lisp Sat Feb 11 00:39:07 2006 @@ -31,7 +31,7 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.intrinsics.system) +(in-package :graphic-forms.intrinsics) (defgeneric dispose (native-object) (:documentation "Discards native resources and executes other cleanup code.")) Modified: trunk/src/intrinsics/system/native-object.lisp ============================================================================== --- trunk/src/intrinsics/system/native-object.lisp (original) +++ trunk/src/intrinsics/system/native-object.lisp Sat Feb 11 00:39:07 2006 @@ -31,7 +31,10 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.intrinsics.system) +(in-package :graphic-forms.intrinsics) (defmethod disposed-p ((obj native-object)) (null (handle obj))) + +(defmacro null-handle-p (handle) + `(cffi:null-pointer-p ,handle)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Feb 11 00:39:07 2006 @@ -33,12 +33,13 @@ (in-package #:graphic-forms-system) -(defpackage #:graphic-forms.intrinsics.datastructs - (:nicknames #:gfid) +(defpackage #:graphic-forms.intrinsics + (:nicknames #:gfi) (:use #:common-lisp) (:export ;; classes and structs + #:native-object #:point #:rectangle #:size @@ -47,10 +48,14 @@ ;; constants ;; methods, functions, and macros + #:dispose + #:disposed-p + #:handle #:location #:make-point #:make-size #:make-span + #:null-handle-p #:point-x #:point-y #:point-z @@ -64,26 +69,8 @@ ;; conditions #:disposed-error)) -(defpackage #:graphic-forms.intrinsics.system - (:nicknames #:gfis) - (:use #:common-lisp) - (:export - -;; classes and structs - #:native-object - -;; constants - -;; methods, functions, and macros - #:dispose - #:disposed-p - #:handle - -;; conditions - #:disposed-error)) - (defpackage #:graphic-forms.uitoolkit.system - (:nicknames #:gfus) + (:nicknames #:gfs) (:shadow #:atom #:boolean) (:use #:common-lisp) (:export @@ -99,7 +86,6 @@ #:insert-menuitem #:insert-separator #:insert-submenu - #:null-handle-p #:process-message #:register-window-class #:with-retrieved-dc @@ -111,7 +97,7 @@ #:win32-warning)) (defpackage #:graphic-forms.uitoolkit.graphics - (:nicknames #:gfug) + (:nicknames #:gfg) (:shadow #:load #:type) (:use #:common-lisp) (:export @@ -215,7 +201,7 @@ )) (defpackage #:graphic-forms.uitoolkit.widgets - (:nicknames #:gfuw) + (:nicknames #:gfw) (:use #:common-lisp) (:export Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sat Feb 11 00:39:07 2006 @@ -41,35 +41,35 @@ (defun exit-event-tester () (let ((w *event-tester-window*)) (setf *event-tester-window* nil) - (gfis:dispose w)) - (gfuw:shutdown 0)) + (gfi:dispose w)) + (gfw:shutdown 0)) -(defclass event-tester-window-events (gfuw:event-dispatcher) ()) +(defclass event-tester-window-events (gfw:event-dispatcher) ()) -(defmethod gfuw:event-paint ((d event-tester-window-events) time gc rect) +(defmethod gfw:event-paint ((d event-tester-window-events) time gc rect) (declare (ignorable time rect)) - (setf (gfug:background-color gc) gfug:+color-white+) - (setf (gfug:foreground-color gc) gfug:+color-blue+) - (let* ((sz (gfuw:client-size *event-tester-window*)) - (pnt (gfid:make-point :x 0 :y (floor (/ (gfid:size-height sz) 2))))) - (gfug:draw-text gc *event-tester-text* pnt))) + (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:foreground-color gc) gfg:+color-blue+) + (let* ((sz (gfw:client-size *event-tester-window*)) + (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) + (gfg:draw-text gc *event-tester-text* pnt))) -(defmethod gfuw:event-close ((d event-tester-window-events) time) +(defmethod gfw:event-close ((d event-tester-window-events) time) (declare (ignore time)) (exit-event-tester)) (defun text-for-modifiers () (format nil "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" - (not (gfuw:key-down-p gfuw:+vk-shift+)) - (not (gfuw:key-down-p gfuw:+vk-control+)) - (not (gfuw:key-down-p gfuw:+vk-alt+)) - (not (gfuw:key-down-p gfuw:+vk-left-win+)) - (not (gfuw:key-down-p gfuw:+vk-right-win+)) - (not (gfuw:key-toggled-p gfuw:+vk-escape+)) - (not (gfuw:key-toggled-p gfuw:+vk-caps-lock+)) - (not (gfuw:key-toggled-p gfuw:+vk-num-lock+)) - (not (gfuw:key-toggled-p gfuw:+vk-scroll-lock+)))) + (not (gfw:key-down-p gfw:+vk-shift+)) + (not (gfw:key-down-p gfw:+vk-control+)) + (not (gfw:key-down-p gfw:+vk-alt+)) + (not (gfw:key-down-p gfw:+vk-left-win+)) + (not (gfw:key-down-p gfw:+vk-right-win+)) + (not (gfw:key-toggled-p gfw:+vk-escape+)) + (not (gfw:key-toggled-p gfw:+vk-caps-lock+)) + (not (gfw:key-toggled-p gfw:+vk-num-lock+)) + (not (gfw:key-toggled-p gfw:+vk-scroll-lock+)))) (defun text-for-mouse (action time button pnt) (format nil @@ -77,8 +77,8 @@ (incf *event-counter*) action button - (gfid:point-x pnt) - (gfid:point-y pnt) + (gfi:point-x pnt) + (gfi:point-y pnt) time (text-for-modifiers))) @@ -106,8 +106,8 @@ "~a resize action: ~s size: (~d,~d) time: 0x~x ~s" (incf *event-counter*) (symbol-name type) - (gfid:size-width size) - (gfid:size-height size) + (gfi:size-width size) + (gfi:size-height size) time (text-for-modifiers))) @@ -115,74 +115,74 @@ (format nil "~a move point: (~d,~d) time: 0x~x ~s" (incf *event-counter*) - (gfid:point-x pnt) - (gfid:point-y pnt) + (gfi:point-x pnt) + (gfi:point-y pnt) time (text-for-modifiers))) -(defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char) +(defmethod gfw:event-key-down ((d event-tester-window-events) time key-code char) (setf *event-tester-text* (text-for-key "down" time key-code char)) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char) +(defmethod gfw:event-key-up ((d event-tester-window-events) time key-code char) (setf *event-tester-text* (text-for-key "up" time key-code char)) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-double ((d event-tester-window-events) time pnt button) (setf *event-tester-text* (text-for-mouse "double" time button pnt)) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-down ((d event-tester-window-events) time pnt button) (setf *event-tester-text* (text-for-mouse "down" time button pnt)) (setf *mouse-down-flag* t) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-move ((d event-tester-window-events) time pnt button) (when *mouse-down-flag* (setf *event-tester-text* (text-for-mouse "move" time button pnt)) - (gfuw:redraw *event-tester-window*))) + (gfw:redraw *event-tester-window*))) -(defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button) +(defmethod gfw:event-mouse-up ((d event-tester-window-events) time pnt button) (setf *event-tester-text* (text-for-mouse "up" time button pnt)) (setf *mouse-down-flag* nil) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-move ((d event-tester-window-events) time pnt) +(defmethod gfw:event-move ((d event-tester-window-events) time pnt) (setf *event-tester-text* (text-for-move time pnt)) - (gfuw:redraw *event-tester-window*) + (gfw:redraw *event-tester-window*) 0) -(defmethod gfuw:event-resize ((d event-tester-window-events) time size type) +(defmethod gfw:event-resize ((d event-tester-window-events) time size type) (setf *event-tester-text* (text-for-size type time size)) - (gfuw:redraw *event-tester-window*) + (gfw:redraw *event-tester-window*) 0) -(defclass event-tester-exit-dispatcher (gfuw:event-dispatcher) ()) +(defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfuw:event-select ((d event-tester-exit-dispatcher) time item rect) +(defmethod gfw:event-select ((d event-tester-exit-dispatcher) time item rect) (declare (ignorable time item rect)) (exit-event-tester)) -(defmethod gfuw:event-arm ((d event-tester-exit-dispatcher) time item) +(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) time item) (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) - (gfuw:redraw *event-tester-window*)) + (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) + (gfw:redraw *event-tester-window*)) -(defclass event-tester-echo-dispatcher (gfuw:event-dispatcher) ()) +(defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfuw:event-select ((d event-tester-echo-dispatcher) time item rect) +(defmethod gfw:event-select ((d event-tester-echo-dispatcher) time item rect) (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfuw:text item) time "item selected")) - (gfuw:redraw *event-tester-window*)) + (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected")) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-arm ((d event-tester-echo-dispatcher) time item) +(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) time item) (declare (ignore rect)) - (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) - (gfuw:redraw *event-tester-window*)) + (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed")) + (gfw:redraw *event-tester-window*)) -(defmethod gfuw:event-activate ((d event-tester-echo-dispatcher) time) +(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) time) (setf *event-tester-text* (text-for-item "" time "menu activated")) - (gfuw:redraw *event-tester-window*)) + (gfw:redraw *event-tester-window*)) (defun run-event-tester-internal () (setf *event-tester-text* "Hello!") @@ -190,23 +190,23 @@ (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) - (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events))) - (gfuw:realize *event-tester-window* nil :style-workspace) - (setf menubar (gfuw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md) - (:menuitem "&Open..." :dispatcher ,echo-md) - (:menuitem "&Save..." :disabled :dispatcher ,echo-md) - (:menuitem :separator) - (:menuitem "E&xit" :dispatcher ,exit-md)) - ((:menu "&Options" :dispatcher ,echo-md) - (:menuitem "&Enabled" :checked :dispatcher ,echo-md) - (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md) - (:menuitem "&Fonts" :dispatcher ,echo-md :disabled) - (:menuitem "&Colors" :dispatcher ,echo-md)))) - ((:menu "&Help" :dispatcher ,echo-md) - (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) - (setf (gfuw:menu-bar *event-tester-window*) menubar) - (gfuw:show *event-tester-window*) - (gfuw:run-default-message-loop))) + (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events))) + (gfw:realize *event-tester-window* nil :style-workspace) + (setf menubar (gfw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md) + (:menuitem "&Open..." :dispatcher ,echo-md) + (:menuitem "&Save..." :disabled :dispatcher ,echo-md) + (:menuitem :separator) + (:menuitem "E&xit" :dispatcher ,exit-md)) + ((:menu "&Options" :dispatcher ,echo-md) + (:menuitem "&Enabled" :checked :dispatcher ,echo-md) + (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md) + (:menuitem "&Fonts" :dispatcher ,echo-md :disabled) + (:menuitem "&Colors" :dispatcher ,echo-md)))) + ((:menu "&Help" :dispatcher ,echo-md) + (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) + (setf (gfw:menu-bar *event-tester-window*) menubar) + (gfw:show *event-tester-window*) + (gfw:run-default-message-loop))) (defun run-event-tester () - (gfuw:startup "Event Tester" #'run-event-tester-internal)) + (gfw:startup "Event Tester" #'run-event-tester-internal)) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sat Feb 11 00:39:07 2006 @@ -38,38 +38,38 @@ (defun exit-hello-world () (let ((w *hellowin*)) (setf *hellowin* nil) - (gfis:dispose w)) - (gfuw:shutdown 0)) + (gfi:dispose w)) + (gfw:shutdown 0)) -(defclass hellowin-events (gfuw:event-dispatcher) ()) +(defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfuw:event-close ((d hellowin-events) time) +(defmethod gfw:event-close ((d hellowin-events) time) (declare (ignore time)) (format t "hellowin-events event-close~%") (exit-hello-world)) -(defmethod gfuw:event-paint ((d hellowin-events) time (gc gfug:graphics-context) rect) +(defmethod gfw:event-paint ((d hellowin-events) time (gc gfg:graphics-context) rect) (declare (ignore time) (ignore rect)) - (setf (gfug:background-color gc) gfug:+color-red+) - (setf (gfug:foreground-color gc) gfug:+color-green+) - (gfug:draw-text gc "Hello World!" (gfid:make-point))) + (setf (gfg:background-color gc) gfg:+color-red+) + (setf (gfg:foreground-color gc) gfg:+color-green+) + (gfg:draw-text gc "Hello World!" (gfi:make-point))) -(defclass hellowin-exit-dispatcher (gfuw:event-dispatcher) ()) +(defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfuw:event-select ((d hellowin-exit-dispatcher) time item rect) +(defmethod gfw:event-select ((d hellowin-exit-dispatcher) time item rect) (declare (ignorable time item rect)) (exit-hello-world)) (defun run-hello-world-internal () (let ((menubar nil) (md (make-instance 'hellowin-exit-dispatcher))) - (setf *hellowin* (make-instance 'gfuw:window :dispatcher (make-instance 'hellowin-events))) - (gfuw:realize *hellowin* nil :style-workspace) - (setf menubar (gfuw:defmenusystem `(((:menu "&File") - (:menuitem "E&xit" :dispatcher ,md))))) - (setf (gfuw:menu-bar *hellowin*) menubar) - (gfuw:show *hellowin*) - (gfuw:run-default-message-loop))) + (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize *hellowin* nil :style-workspace) + (setf menubar (gfw:defmenusystem `(((:menu "&File") + (:menuitem "E&xit" :dispatcher ,md))))) + (setf (gfw:menu-bar *hellowin*) menubar) + (gfw:show *hellowin*) + (gfw:run-default-message-loop))) (defun run-hello-world () - (gfuw:startup "Hello World" #'run-hello-world-internal)) + (gfw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sat Feb 11 00:39:07 2006 @@ -41,16 +41,16 @@ (defun exit-layout-tester () (let ((w *layout-tester-win*)) (setf *layout-tester-win* nil) - (gfis:dispose w)) - (gfuw:shutdown 0)) + (gfi:dispose w)) + (gfw:shutdown 0)) -(defclass layout-tester-events (gfuw:event-dispatcher) ()) +(defclass layout-tester-events (gfw:event-dispatcher) ()) -(defmethod gfuw:event-close ((d layout-tester-events) time) +(defmethod gfw:event-close ((d layout-tester-events) time) (declare (ignore time)) (exit-layout-tester)) -(defclass layout-tester-btn-events (gfuw:event-dispatcher) +(defclass layout-tester-btn-events (gfw:event-dispatcher) ((button :accessor button :initarg :button @@ -59,29 +59,29 @@ :accessor toggle-fn :initform nil))) -(defmethod gfuw:event-select ((d layout-tester-btn-events) time item rect) +(defmethod gfw:event-select ((d layout-tester-btn-events) time item rect) (declare (ignorable time rect)) (let ((btn (button d))) - (setf (gfuw:text btn) (funcall (toggle-fn d))))) + (setf (gfw:text btn) (funcall (toggle-fn d))))) -(defclass layout-tester-child-menu-dispatcher (gfuw:event-dispatcher) ()) +(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfuw:event-activate ((d layout-tester-child-menu-dispatcher) time) +(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) time) (declare (ignore time)) - (let* ((mb (gfuw:menu-bar *layout-tester-win*)) - (menu (gfuw:sub-menu mb 1))) - (gfuw:clear-all menu) - (gfuw::visit-child-widgets *layout-tester-win* + (let* ((mb (gfw:menu-bar *layout-tester-win*)) + (menu (gfw:sub-menu mb 1))) + (gfw:clear-all menu) + (gfw::visit-child-widgets *layout-tester-win* #'(lambda (child val) (declare (ignore val)) - (let ((it (make-instance 'gfuw:menu-item))) - (gfuw:item-append menu it) - (setf (gfuw:text it) (gfuw:text child)))) + (let ((it (make-instance 'gfw:menu-item))) + (gfw:item-append menu it) + (setf (gfw:text it) (gfw:text child)))) 0))) -(defclass layout-tester-exit-dispatcher (gfuw:event-dispatcher) ()) +(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) -(defmethod gfuw:event-select ((d layout-tester-exit-dispatcher) time item rect) +(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) time item rect) (declare (ignorable time item rect)) (exit-layout-tester)) @@ -90,7 +90,7 @@ (fed (make-instance 'layout-tester-exit-dispatcher)) (be (make-instance 'layout-tester-btn-events)) (cmd (make-instance 'layout-tester-child-menu-dispatcher)) - (btn (make-instance 'gfuw:button :dispatcher be))) + (btn (make-instance 'gfw:button :dispatcher be))) (setf (button be) btn) (setf (toggle-fn be) (let ((flag nil)) #'(lambda () @@ -101,20 +101,20 @@ (progn (setf flag nil) +btn-text-2+))))) - (setf *layout-tester-win* (make-instance 'gfuw:window :dispatcher (make-instance 'layout-tester-events))) - (gfuw:realize *layout-tester-win* nil :style-workspace) - (setf (gfuw:size *layout-tester-win*) (gfid:make-size :width 200 :height 150)) - (setf menubar (gfuw:defmenusystem `(((:menu "&File") - (:menuitem "E&xit" :dispatcher ,fed)) - ((:menu "&Children" :dispatcher ,cmd) - (:menuitem :separator))))) - (setf (gfuw:menu-bar *layout-tester-win*) menubar) - (gfuw:realize btn *layout-tester-win* :push-button) - (setf (gfuw:text btn) (funcall (toggle-fn be))) - (setf (gfuw:location btn) (gfid:make-point)) - (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1)) - (gfuw:show *layout-tester-win*) - (gfuw:run-default-message-loop))) + (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events))) + (gfw:realize *layout-tester-win* nil :style-workspace) + (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 200 :height 150)) + (setf menubar (gfw:defmenusystem `(((:menu "&File") + (:menuitem "E&xit" :dispatcher ,fed)) + ((:menu "&Children" :dispatcher ,cmd) + (:menuitem :separator))))) + (setf (gfw:menu-bar *layout-tester-win*) menubar) + (gfw:realize btn *layout-tester-win* :push-button) + (setf (gfw:text btn) (funcall (toggle-fn be))) + (setf (gfw:location btn) (gfi:make-point)) + (setf (gfw:size btn) (gfw:preferred-size btn -1 -1)) + (gfw:show *layout-tester-win*) + (gfw:run-default-message-loop))) (defun run-layout-tester () - (gfuw:startup "Layout Tester" #'run-layout-tester-internal)) + (gfw:startup "Layout Tester" #'run-layout-tester-internal)) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Sat Feb 11 00:39:07 2006 @@ -37,8 +37,8 @@ ;;; methods ;;; -(defmethod gfis:dispose ((fn font)) - (let ((hgdi (gfis:handle fn))) - (unless (gfus:null-handle-p hgdi) - (gfus::delete-object hgdi))) - (setf (slot-value fn 'gfis:handle) nil)) +(defmethod gfi:dispose ((fn font)) + (let ((hgdi (gfi:handle fn))) + (unless (gfi:null-handle-p hgdi) + (gfs::delete-object hgdi))) + (setf (slot-value fn 'gfi:handle) nil)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sat Feb 11 00:39:07 2006 @@ -49,57 +49,57 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro ascent (metrics) - `(gfug::font-metrics-ascent ,metrics))) + `(gfg::font-metrics-ascent ,metrics))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro descent (metrics) - `(gfug::font-metrics-descent ,metrics))) + `(gfg::font-metrics-descent ,metrics))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro leading (metrics) - `(gfug::font-metrics-leading ,metrics))) + `(gfg::font-metrics-leading ,metrics))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro height (metrics) - `(+ (gfug::font-metrics-ascent ,metrics) - (gfug::font-metrics-descent ,metrics) - (gfug::font-metrics-leading ,metrics)))) + `(+ (gfg::font-metrics-ascent ,metrics) + (gfg::font-metrics-descent ,metrics) + (gfg::font-metrics-leading ,metrics)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro average-char-width (metrics) - `(gfug::font-metrics-avg-char-width ,metrics))) + `(gfg::font-metrics-avg-char-width ,metrics))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro maximum-char-width (metrics) - `(gfug::font-metrics-max-char-width ,metrics))) + `(gfg::font-metrics-max-char-width ,metrics))) (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct image-data (pixels nil) ; vector of bytes (bits-per-pixel 0) ; number of bits per pixel (palette nil) ; palette - (size (gfid:make-size)) ; width and height of image in pixels + (size (gfi:make-size)) ; width and height of image in pixels (type 'bmp))) ; symbol corresponding to file extension (e.g., 'bmp) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro bits-per-pixel (data) - `(gfug::image-data-bits-per-pixel ,data))) + `(gfg::image-data-bits-per-pixel ,data))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro image-palette (data) - `(gfug::image-data-palette ,data))) + `(gfg::image-data-palette ,data))) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro pixels (data) - `(gfug::image-data-pixels ,data))) + `(gfg::image-data-pixels ,data))) -(defclass font (gfis:native-object) () +(defclass font (gfi:native-object) () (:documentation "This class encapsulates a realized native font.")) -(defclass graphics-context (gfis:native-object) () +(defclass graphics-context (gfi:native-object) () (:documentation "This class represents the context associated with drawing primitives.")) -(defclass image (gfis:native-object) +(defclass image (gfi:native-object) ((transparency :accessor transparency-color :initarg :transparency-color @@ -118,35 +118,35 @@ (table nil))) ; vector of COLOR structs (defmacro blue-mask (data) - `(gfug::palette-blue-mask ,data)) + `(gfg::palette-blue-mask ,data)) (defmacro blue-shift (data) - `(gfug::palette-blue-shift ,data)) + `(gfg::palette-blue-shift ,data)) (defmacro direct (data flag) - `(setf (gfug::palette-direct ,data) ,flag)) + `(setf (gfg::palette-direct ,data) ,flag)) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro direct-p (data) - `(null (gfug::palette-direct ,data)))) + `(null (gfg::palette-direct ,data)))) (defmacro green-mask (data) - `(gfug::palette-green-mask ,data)) + `(gfg::palette-green-mask ,data)) (defmacro green-shift (data) - `(gfug::palette-green-shift ,data)) + `(gfg::palette-green-shift ,data)) (defmacro red-mask (data) - `(gfug::palette-red-mask ,data)) + `(gfg::palette-red-mask ,data)) (defmacro red-shift (data) - `(gfug::palette-red-shift ,data)) + `(gfg::palette-red-shift ,data)) (defmacro color-table (data) - `(gfug::palette-table ,data)) + `(gfg::palette-table ,data)) -(defclass pattern (gfis:native-object) () +(defclass pattern (gfi:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) -(defclass transform (gfis:native-object) () +(defclass transform (gfi:native-object) () (:documentation "This class specifies how coordinates are transformed.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Feb 11 00:39:07 2006 @@ -41,88 +41,88 @@ ;;; methods ;;; -(defmethod gfis:dispose ((gc graphics-context)) - (gfus::delete-dc (gfis:handle gc)) - (setf (slot-value gc 'gfis:handle) nil)) +(defmethod gfi:dispose ((gc graphics-context)) + (gfs::delete-dc (gfi:handle gc)) + (setf (slot-value gc 'gfi:handle) nil)) (defmethod background-color ((gc graphics-context)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) - (gfus::get-bk-color (gfis:handle gc))) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (gfs::get-bk-color (gfi:handle gc))) (defmethod (setf background-color) ((clr color) (gc graphics-context)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) - (let ((hdc (gfis:handle gc)) - (hbrush (gfus::get-stock-object gfus::+dc-brush+)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (let ((hdc (gfi:handle gc)) + (hbrush (gfs::get-stock-object gfs::+dc-brush+)) (rgb (color-as-rgb clr))) - (gfus::select-object hdc hbrush) - (gfus::set-dc-brush-color hdc rgb) - (gfus::set-bk-color hdc rgb))) - -(defmethod draw-image ((gc graphics-context) (im image) (pnt gfid:point)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) - (if (gfis:disposed-p im) - (error 'gfis:disposed-error)) + (gfs::select-object hdc hbrush) + (gfs::set-dc-brush-color hdc rgb) + (gfs::set-bk-color hdc rgb))) + +(defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (if (gfi:disposed-p im) + (error 'gfi:disposed-error)) ;; TODO: support addressing elements within bitmap as if it were an array ;; - (let ((memdc (gfus::create-compatible-dc (gfis:handle gc))) + (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) oldhbm) - (if (gfus:null-handle-p memdc) - (error 'gfus:win32-error :detail "create-compatible-dc failed")) - (setf oldhbm (gfus::select-object memdc (gfis:handle im))) - (cffi:with-foreign-object (bmp-ptr 'gfus::bitmap) - (gfus::get-object (gfis:handle im) (cffi:foreign-type-size 'gfus::bitmap) bmp-ptr) - (gfus::bit-blt (gfis:handle gc) - (gfid:point-x pnt) - (gfid:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfus::bitmap 'gfus::width) - (cffi:foreign-slot-value bmp-ptr 'gfus::bitmap 'gfus::height) + (if (gfi:null-handle-p memdc) + (error 'gfs:win32-error :detail "create-compatible-dc failed")) + (setf oldhbm (gfs::select-object memdc (gfi:handle im))) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::bit-blt (gfi:handle gc) + (gfi:point-x pnt) + (gfi:point-y pnt) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) memdc 0 0 - gfus::+blt-srccopy+)) - (gfus::select-object memdc oldhbm) - (gfus::delete-dc memdc))) - -(defmethod draw-text ((gc graphics-context) text (pnt gfid:point)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) + gfs::+blt-srccopy+)) + (gfs::select-object memdc oldhbm) + (gfs::delete-dc memdc))) + +(defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) (cffi:with-foreign-string (text-ptr text) - (cffi:with-foreign-object (rect-ptr 'gfus::rect) - (cffi:with-foreign-slots ((gfus::left gfus::right gfus::top gfus::bottom) - rect-ptr gfus::rect) - (setf gfus::left (gfid:point-x pnt)) - (setf gfus::right (gfid:point-x pnt)) - (setf gfus::top (gfid:point-y pnt)) - (setf gfus::bottom (gfid:point-y pnt)) - (gfus::draw-text (gfis:handle gc) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) + rect-ptr gfs::rect) + (setf gfs::left (gfi:point-x pnt)) + (setf gfs::right (gfi:point-x pnt)) + (setf gfs::top (gfi:point-y pnt)) + (setf gfs::bottom (gfi:point-y pnt)) + (gfs::draw-text (gfi:handle gc) text-ptr (length text) rect-ptr - (logior gfus::+dt-calcrect+ gfus::+dt-singleline+) + (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) (cffi:null-pointer)) - (gfus::draw-text (gfis:handle gc) + (gfs::draw-text (gfi:handle gc) text-ptr (length text) rect-ptr - (logior gfus::+dt-noclip+ - gfus::+dt-noprefix+ - gfus::+dt-singleline+ - gfus::+dt-vcenter+) + (logior gfs::+dt-noclip+ + gfs::+dt-noprefix+ + gfs::+dt-singleline+ + gfs::+dt-vcenter+) (cffi:null-pointer)))))) (defmethod foreground-color ((gc graphics-context)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) - (gfus::get-text-color (gfis:handle gc))) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (gfs::get-text-color (gfi:handle gc))) (defmethod (setf foreground-color) ((clr color) (gc graphics-context)) - (if (gfis:disposed-p gc) - (error 'gfis:disposed-error)) - (let ((hdc (gfis:handle gc)) - (hpen (gfus::get-stock-object gfus::+dc-pen+)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (let ((hdc (gfi:handle gc)) + (hpen (gfs::get-stock-object gfs::+dc-pen+)) (rgb (color-as-rgb clr))) - (gfus::select-object hdc hpen) - (gfus::set-dc-pen-color hdc rgb) - (gfus::set-text-color hdc rgb))) + (gfs::select-object hdc hpen) + (gfs::set-dc-pen-color hdc rgb) + (gfs::set-text-color hdc rgb))) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sat Feb 11 00:39:07 2006 @@ -48,8 +48,8 @@ (info (read-value 'BASE-BITMAPINFOHEADER in)) (pix-bits nil)) (declare (ignore header)) - (unless (= (biCompression info) gfus::+bi-rgb+) - (error 'gfus:toolkit-error :detail "FIXME: not yet implemented")) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) ;; load color table ;; @@ -92,7 +92,7 @@ ;; (setf (image-data-pixels victim) pix-bits) (setf (image-data-bits-per-pixel victim) (biBitCount info)) - (setf (size victim) (gfid:make-size :width (biWidth info) :height (biHeight info))) + (setf (size victim) (gfi:make-size :width (biWidth info) :height (biHeight info))) (setf (image-data-type victim) 'bmp) victim))) @@ -110,13 +110,13 @@ (defun bmp-loader (path) (let (hwnd) (cffi:with-foreign-string (ptr (namestring path)) - (setf hwnd (gfus::load-image nil + (setf hwnd (gfs::load-image nil ptr - gfus::+image-bitmap+ + gfs::+image-bitmap+ 0 0 - gfus::+lr-loadfromfile+))) - (if (gfus:null-handle-p hwnd) - (error 'gfus:win32-error :detail "load-image failed")) + gfs::+lr-loadfromfile+))) + (if (gfi:null-handle-p hwnd) + (error 'gfs:win32-error :detail "load-image failed")) hwnd)) |# @@ -130,86 +130,86 @@ "Associate a new (or replacement) loader function with the specified file type. \ Returns the previous loader function, if any." (unless (typep file-type 'string) - (error 'gfus:toolkit-error :detail "file-type must be a string")) + (error 'gfs:toolkit-error :detail "file-type must be a string")) (unless (typep loader-fn 'function) - (error 'gfus:toolkit-error :detail "loader-fn must be a function")) + (error 'gfs:toolkit-error :detail "loader-fn must be a function")) (let ((old-fn (gethash file-type *loaders-by-type*))) (setf (gethash file-type *loaders-by-type*) loader-fn) old-fn)) (defun image->data (hbmp) "Convert the native bitmap handle to an image-data." - (let ((mem-dc (gfus::create-compatible-dc (cffi:null-pointer))) + (let ((mem-dc (gfs::create-compatible-dc (cffi:null-pointer))) (raw-bits nil) (data nil) (sz nil) (byte-count 0)) - (when (gfus:null-handle-p mem-dc) - (error 'gfus:win32-error :detail "create-compatible-dc failed")) + (when (gfi:null-handle-p mem-dc) + (error 'gfs:win32-error :detail "create-compatible-dc failed")) (unwind-protect (progn - (cffi:with-foreign-object (bc-ptr 'gfus::bitmapcoreheader) - (cffi:with-foreign-slots ((gfus::bcsize - gfus::bcwidth - gfus::bcheight - gfus::bcbitcount) - bc-ptr gfus::bitmapcoreheader) - (setf gfus::bcsize (cffi:foreign-type-size 'gfus::bitmapcoreheader)) - (setf gfus::bcbitcount 0) - (when (zerop (gfus::get-di-bits mem-dc + (cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader) + (cffi:with-foreign-slots ((gfs::bcsize + gfs::bcwidth + gfs::bcheight + gfs::bcbitcount) + bc-ptr gfs::bitmapcoreheader) + (setf gfs::bcsize (cffi:foreign-type-size 'gfs::bitmapcoreheader)) + (setf gfs::bcbitcount 0) + (when (zerop (gfs::get-di-bits mem-dc hbmp 0 0 (cffi:null-pointer) bc-ptr - gfus::+dib-rgb-colors+)) - (error 'gfus:win32-error :detail "get-di-bits failed <1>")) - (setf sz (gfid:make-size :width gfus::bcwidth :height gfus::bcheight)) - (setf data (make-image-data :bits-per-pixel gfus::bcbitcount :size sz)))) - (setf byte-count (* (bmp-pixel-row-length (gfid:size-width sz) (bits-per-pixel data)) - (gfid:size-height sz))) + gfs::+dib-rgb-colors+)) + (error 'gfs:win32-error :detail "get-di-bits failed <1>")) + (setf sz (gfi:make-size :width gfs::bcwidth :height gfs::bcheight)) + (setf data (make-image-data :bits-per-pixel gfs::bcbitcount :size sz)))) + (setf byte-count (* (bmp-pixel-row-length (gfi:size-width sz) (bits-per-pixel data)) + (gfi:size-height sz))) (setf raw-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) - (cffi:with-foreign-object (bi-ptr 'gfus::bitmapinfo) - (cffi:with-foreign-slots ((gfus::bisize - gfus::biwidth - gfus::biheight - gfus::biplanes - gfus::bibitcount - gfus::bicompression - gfus::biclrused - gfus::bmicolors) - bi-ptr gfus::bitmapinfo) - (setf gfus::bisize (cffi:foreign-type-size 'gfus::bitmapinfoheader)) - (setf gfus::biwidth (gfid:size-width sz)) - (setf gfus::biheight (gfid:size-height sz)) - (setf gfus::biplanes 1) - (setf gfus::bibitcount (bits-per-pixel data)) - (setf gfus::bicompression gfus::+bi-rgb+) - (when (zerop (gfus::get-di-bits mem-dc + (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) + (cffi:with-foreign-slots ((gfs::bisize + gfs::biwidth + gfs::biheight + gfs::biplanes + gfs::bibitcount + gfs::bicompression + gfs::biclrused + gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) + (setf gfs::biwidth (gfi:size-width sz)) + (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biplanes 1) + (setf gfs::bibitcount (bits-per-pixel data)) + (setf gfs::bicompression gfs::+bi-rgb+) + (when (zerop (gfs::get-di-bits mem-dc hbmp - 0 (gfid:size-height sz) + 0 (gfi:size-height sz) raw-bits bi-ptr - gfus::+dib-rgb-colors+)) - (error 'gfus:win32-error :detail "get-di-bits failed <2>")) + gfs::+dib-rgb-colors+)) + (error 'gfs:win32-error :detail "get-di-bits failed <2>")) ;; process the RGBQUADs ;; (let ((color-count 0)) - (if (= gfus::biclrused 0) + (if (= gfs::biclrused 0) (progn (case (bits-per-pixel data) (1 (setf color-count 2)) (4 (setf color-count 16)) (8 (setf color-count 256)))) - (setf color-count gfus::biclrused)) + (setf color-count gfs::biclrused)) (let ((colors (make-array color-count))) (dotimes (i color-count) - (cffi:with-foreign-slots ((gfus::rgbblue gfus::rgbgreen gfus::rgbred) - (cffi:mem-aref gfus::bmicolors 'gfus::rgbquad i) - gfus::rgbquad) - (setf (aref colors i) (make-color :red gfus::rgbred - :green gfus::rgbgreen - :blue gfus::rgbblue)))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen gfs::rgbred) + (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i) + gfs::rgbquad) + (setf (aref colors i) (make-color :red gfs::rgbred + :green gfs::rgbgreen + :blue gfs::rgbblue)))) (setf (image-data-palette data) (make-palette :direct nil :table colors)))))) ;; process the pixel data @@ -220,45 +220,45 @@ (setf (image-data-pixels data) pix-bytes))) (unless (cffi:null-pointer-p raw-bits) (cffi:foreign-free raw-bits)) - (gfus::delete-dc mem-dc)) + (gfs::delete-dc mem-dc)) data)) (defun data->image (data) "Convert the image-data object to a bitmap and return the native handle." - (cffi:with-foreign-object (bi-ptr 'gfus::bitmapinfo) - (cffi:with-foreign-slots ((gfus::bisize - gfus::biwidth - gfus::biheight - gfus::biplanes - gfus::bibitcount - gfus::bicompression - gfus::bisizeimage - gfus::bixpels - gfus::biypels - gfus::biclrused - gfus::biclrimp - gfus::bmicolors) - bi-ptr gfus::bitmapinfo) + (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) + (cffi:with-foreign-slots ((gfs::bisize + gfs::biwidth + gfs::biheight + gfs::biplanes + gfs::bibitcount + gfs::bicompression + gfs::bisizeimage + gfs::bixpels + gfs::biypels + gfs::biclrused + gfs::biclrimp + gfs::bmicolors) + bi-ptr gfs::bitmapinfo) (let* ((sz (size data)) (colors (palette-table (image-palette data))) (bit-count (bits-per-pixel data)) - (row-len (bmp-pixel-row-length (gfid:size-width sz) bit-count)) - (byte-count (* row-len (gfid:size-height sz))) + (row-len (bmp-pixel-row-length (gfi:size-width sz) bit-count)) + (byte-count (* row-len (gfi:size-height sz))) (data-bits (pixels data)) (pix-bits (cffi:null-pointer)) (hbmp (cffi:null-pointer)) - (mem-dc (gfus::create-compatible-dc (cffi:null-pointer)))) - (setf gfus::bisize (cffi:foreign-type-size 'gfus::bitmapinfoheader)) - (setf gfus::biwidth (gfid:size-width sz)) - (setf gfus::biheight (gfid:size-height sz)) - (setf gfus::biplanes 1) - (setf gfus::bibitcount bit-count) - (setf gfus::bicompression gfus::+bi-rgb+) - (setf gfus::bisizeimage 0) - (setf gfus::bixpels 0) - (setf gfus::biypels 0) - (setf gfus::biclrused 0) - (setf gfus::biclrimp 0) + (mem-dc (gfs::create-compatible-dc (cffi:null-pointer)))) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) + (setf gfs::biwidth (gfi:size-width sz)) + (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biplanes 1) + (setf gfs::bibitcount bit-count) + (setf gfs::bicompression gfs::+bi-rgb+) + (setf gfs::bisizeimage 0) + (setf gfs::bixpels 0) + (setf gfs::biypels 0) + (setf gfs::biclrused 0) + (setf gfs::biclrimp 0) (unwind-protect (progn @@ -267,14 +267,14 @@ ;; (dotimes (i (length colors)) (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfus::rgbblue gfus::rgbgreen - gfus::rgbred gfus::rgbreserved) - (cffi:mem-aref gfus::bmicolors 'gfus::rgbquad i) - gfus::rgbquad) - (setf gfus::rgbblue (color-blue clr)) - (setf gfus::rgbgreen (color-green clr)) - (setf gfus::rgbred (color-red clr)) - (setf gfus::rgbreserved 0)))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i) + gfs::rgbquad) + (setf gfs::rgbblue (color-blue clr)) + (setf gfs::rgbgreen (color-green clr)) + (setf gfs::rgbred (color-red clr)) + (setf gfs::rgbreserved 0)))) ;; populate the pixel data ;; @@ -284,17 +284,17 @@ ;; create the bitmap ;; - (setf hbmp (gfus::create-di-bitmap mem-dc + (setf hbmp (gfs::create-di-bitmap mem-dc bi-ptr - 0 ; gfus::+cbm-init+ + 0 ; gfs::+cbm-init+ pix-bits bi-ptr - gfus::+dib-rgb-colors+)) - (if (gfus:null-handle-p hbmp) - (error 'gfus:win32-error :detail "create-di-bitmap failed"))) + gfs::+dib-rgb-colors+)) + (if (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-di-bitmap failed"))) (unless (cffi:null-pointer-p pix-bits) (cffi:foreign-free pix-bits)) - (gfus::delete-dc mem-dc)) + (gfs::delete-dc mem-dc)) hbmp)))) ;;; @@ -307,11 +307,11 @@ ((typep path 'string) (parse-namestring path)) (t - (error 'gfus:toolkit-error :detail "pathname or string required")))) + (error 'gfs:toolkit-error :detail "pathname or string required")))) (let* ((ptype (pathname-type path)) (fn (gethash ptype *loaders-by-type*))) (if (null fn) - (error 'gfus:toolkit-error + (error 'gfs:toolkit-error :detail (format nil "no loader registered for type: ~a" ptype))) (funcall fn path d) d)) @@ -325,8 +325,8 @@ (defmethod print-object ((obj image-data) stream) (print-unreadable-object (obj stream :type t) (format stream "type: ~a " (image-data-type obj)) - (format stream "width: ~a " (gfid:size-width (image-data-size obj))) - (format stream "height: ~a " (gfid:size-height (image-data-size obj))) + (format stream "width: ~a " (gfi:size-width (image-data-size obj))) + (format stream "height: ~a " (gfi:size-height (image-data-size obj))) (format stream "bits per pixel: ~a " (bits-per-pixel obj)) (format stream "pixel count: ~a " (length (pixels obj))) (format stream "palette: ~a" (image-palette obj)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sat Feb 11 00:39:07 2006 @@ -41,22 +41,22 @@ ;;; methods ;;; -(defmethod gfis:dispose ((im image)) - (let ((hgdi (gfis:handle im))) - (unless (gfus:null-handle-p hgdi) - (gfus::delete-object hgdi))) +(defmethod gfi:dispose ((im image)) + (let ((hgdi (gfi:handle im))) + (unless (gfi:null-handle-p hgdi) + (gfs::delete-object hgdi))) (setf (transparency-color im) nil) - (setf (slot-value im 'gfis:handle) nil)) + (setf (slot-value im 'gfi:handle) nil)) (defmethod data-obj ((im image)) - (when (gfis:disposed-p im) - (error 'gfis:disposed-error)) - (image->data (gfis:handle im))) + (when (gfi:disposed-p im) + (error 'gfi:disposed-error)) + (image->data (gfi:handle im))) (defmethod (setf data-obj) ((id image-data) (im image)) - (unless (gfis:disposed-p im) - (gfis:dispose im)) - (setf (slot-value im 'gfis:handle) (data->image id))) + (unless (gfi:disposed-p im) + (gfi:dispose im)) + (setf (slot-value im 'gfi:handle) (data->image id))) (defmethod load ((im image) path) (let ((data (make-image-data))) @@ -65,7 +65,7 @@ data)) (defmethod size ((im image)) - (error 'gfus:toolkit-error :detail "FIXME: not yet implemented")) + (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) (defmethod transparency-mask ((im image)) - (error 'gfus:toolkit-error :detail "FIXME: not yet implemented")) + (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Sat Feb 11 00:39:07 2006 @@ -37,15 +37,12 @@ ;;; convenience macros ;;; -(defmacro null-handle-p (handle) - `(cffi:null-pointer-p ,handle)) - (defmacro with-retrieved-dc ((hwnd dc-var) &body body) `(let ((,dc-var nil)) (unwind-protect (progn - (setf ,dc-var (gfus::get-dc ,hwnd)) - (if (gfus:null-handle-p ,dc-var) - (error 'gfus:win32-error :detail "get-dc failed")) + (setf ,dc-var (gfs::get-dc ,hwnd)) + (if (gfi:null-handle-p ,dc-var) + (error 'gfs:win32-error :detail "get-dc failed")) ,@body) - (gfus::release-dc ,hwnd ,dc-var)))) + (gfs::release-dc ,hwnd ,dc-var)))) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat Feb 11 00:39:07 2006 @@ -46,47 +46,47 @@ ;; primary button styles ;; ((eq sym :check-box) - (setf std-flags gfus::+bs-checkbox+)) + (setf std-flags gfs::+bs-checkbox+)) ((eq sym :default-button) - (setf std-flags gfus::+bs-defpushbutton+)) + (setf std-flags gfs::+bs-defpushbutton+)) ((eq sym :push-button) - (setf std-flags gfus::+bs-pushbutton+)) + (setf std-flags gfs::+bs-pushbutton+)) ((eq sym :radio-button) - (setf std-flags gfus::+bs-radiobutton+)) + (setf std-flags gfs::+bs-radiobutton+)) ((eq sym :toggle-button) - (setf std-flags gfus::+bs-pushbox+)))) + (setf std-flags gfs::+bs-pushbox+)))) (flatten style)) (values std-flags ex-flags))) (defmethod preferred-size ((btn button) width-hint height-hint) (declare (ignorable width-hint height-hint)) - (let ((hwnd (gfis:handle btn)) - (sz (gfid:make-size)) + (let ((hwnd (gfi:handle btn)) + (sz (gfi:make-size)) (count (length (text btn)))) - (cffi:with-foreign-object (tm-ptr 'gfus::textmetrics) - (cffi:with-foreign-slots ((gfus::tmheight - gfus::tmexternalleading - gfus::tmavgcharwidth) - tm-ptr gfus::textmetrics) - (gfus:with-retrieved-dc (hwnd dc) - (if (zerop (gfus::get-text-metrics dc tm-ptr)) - (error 'gfus:win32-error :detail "get-text-metrics failed")) - (setf (gfid:size-width sz) (* gfus::tmavgcharwidth (+ count 2))) - (let ((tmp (+ gfus::tmexternalleading gfus::tmheight) )) - (setf (gfid:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1)))))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight + gfs::tmexternalleading + gfs::tmavgcharwidth) + tm-ptr gfs::textmetrics) + (gfs:with-retrieved-dc (hwnd dc) + (if (zerop (gfs::get-text-metrics dc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfi:size-width sz) (* gfs::tmavgcharwidth (+ count 2))) + (let ((tmp (+ gfs::tmexternalleading gfs::tmheight) )) + (setf (gfi:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1)))))) sz)) (defmethod realize ((btn button) parent &rest style) (multiple-value-bind (std-style ex-style) (compute-style-flags btn style) - (let ((hwnd (create-window gfus:+button-classname+ + (let ((hwnd (create-window gfs:+button-classname+ " " - (gfis:handle parent) - (logior std-style gfus::+ws-child+ gfus::+ws-visible+) + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) ex-style))) (if (not hwnd) - (error 'gfus:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfis:handle) hwnd)))) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value btn 'gfi:handle) hwnd)))) (defmethod text ((btn button)) (get-widget-text btn)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sat Feb 11 00:39:07 2006 @@ -39,23 +39,23 @@ (defmethod preferred-size :before ((ctl control) width-hint height-hint) (declare (ignorable width-hint height-hint)) - (if (gfis:disposed-p ctl) - (error 'gfis:disposed-error))) + (if (gfi:disposed-p ctl) + (error 'gfi:disposed-error))) (defmethod realize :before ((ctl control) parent &rest style) - (if (gfis:disposed-p parent) - (error 'gfis:disposed-error)) - (if (not (gfis:disposed-p ctl)) - (error 'gfus:toolkit-error :detail "object already realized"))) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error)) + (if (not (gfi:disposed-p ctl)) + (error 'gfs:toolkit-error :detail "object already realized"))) (defmethod realize :after ((ctl control) parent &rest style) - (let ((hwnd (gfis:handle ctl))) + (let ((hwnd (gfi:handle ctl))) (subclass-wndproc hwnd) (put-widget ctl) - (let ((hfont (gfus::get-stock-object gfus::+default-gui-font+))) - (unless (gfus:null-handle-p hfont) - (unless (zerop (gfus::send-message hwnd - gfus::+wm-setfont+ + (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) + (unless (gfi:null-handle-p hfont) + (unless (zerop (gfs::send-message hwnd + gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)) - (error 'gfus:win32-error :detail "send-message failed")))))) + (error 'gfs:win32-error :detail "send-message failed")))))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Feb 11 00:39:07 2006 @@ -33,35 +33,35 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfus::+pm-noremove+ - gfus::+pm-noyield+ - gfus::+pm-qs-input+ - gfus::+pm-qs-postmessage+)) +(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+)) (defvar *last-event-time* 0) (defvar *last-virtual-key* 0) -(defvar *mouse-event-pnt* (gfid:make-point)) -(defvar *move-event-pnt* (gfid:make-point)) -(defvar *size-event-size* (gfid:make-size)) +(defvar *mouse-event-pnt* (gfi:make-point)) +(defvar *move-event-pnt* (gfi:make-point)) +(defvar *size-event-size* (gfi:make-size)) ;;; ;;; window procedures ;;; (cffi:defcallback uit_widgets_wndproc - gfus::LONG - ((hwnd gfus::HANDLE) - (msg gfus::UINT) - (wparam gfus::WPARAM) - (lparam gfus::LPARAM)) + gfs::LONG + ((hwnd gfs::HANDLE) + (msg gfs::UINT) + (wparam gfs::WPARAM) + (lparam gfs::LPARAM)) (process-message hwnd msg wparam lparam)) (cffi:defcallback subclassing_wndproc - gfus::LONG - ((hwnd gfus::HANDLE) - (msg gfus::UINT) - (wparam gfus::WPARAM) - (lparam gfus::LPARAM)) + gfs::LONG + ((hwnd gfs::HANDLE) + (msg gfs::UINT) + (wparam gfs::WPARAM) + (lparam gfs::LPARAM)) (process-subclass-message hwnd msg wparam lparam)) ;;; @@ -69,24 +69,24 @@ ;;; (defun run-default-message-loop () - (cffi:with-foreign-object (msg-ptr 'gfus::msg) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop - (let ((gm (gfus::get-message msg-ptr (cffi:null-pointer) 0 0))) - (cffi:with-foreign-slots ((gfus::hwnd - gfus::message - gfus::wparam - gfus::lparam - gfus::time - gfus::pnt) - msg-ptr gfus::msg) - (setf *last-event-time* gfus::time) + (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) + (cffi:with-foreign-slots ((gfs::hwnd + gfs::message + gfs::wparam + gfs::lparam + gfs::time + gfs::pnt) + msg-ptr gfs::msg) + (setf *last-event-time* gfs::time) (when (zerop gm) - (return-from run-default-message-loop gfus::wparam)) + (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) - (warn 'gfus:win32-warning :detail "get-message failed") - (return-from run-default-message-loop gfus::wparam))) - (gfus::translate-message msg-ptr) - (gfus::dispatch-message msg-ptr))))) + (warn 'gfs:win32-warning :detail "get-message failed") + (return-from run-default-message-loop gfs::wparam))) + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr))))) (defmacro hi-word (lparam) `(ash (logand #xFFFF0000 ,lparam) -16)) @@ -96,49 +96,49 @@ (defun key-down-p (key-code) "Return T if the key corresponding to key-code is currently down." - (= (logand (gfus::get-async-key-state key-code) #x8000) #x8000)) + (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000)) (defun key-toggled-p (key-code) "Return T if the key corresponding to key-code is toggled on; nil otherwise." - (= (gfus::get-key-state key-code) 1)) + (= (gfs::get-key-state key-code) 1)) (defun process-mouse-message (fn hwnd lparam btn-symbol) (let ((w (get-widget hwnd))) (when w - (setf (gfid:point-x *mouse-event-pnt*) (lo-word lparam)) - (setf (gfid:point-y *mouse-event-pnt*) (hi-word lparam)) + (setf (gfi:point-x *mouse-event-pnt*) (lo-word lparam)) + (setf (gfi:point-y *mouse-event-pnt*) (hi-word lparam)) (funcall fn (dispatcher w) *last-event-time* *mouse-event-pnt* btn-symbol))) 0) (defun get-class-wndproc (hwnd) - (let ((wndproc-val (gfus::get-class-long hwnd gfus::+gclp-wndproc+))) + (let ((wndproc-val (gfs::get-class-long hwnd gfs::+gclp-wndproc+))) (if (zerop wndproc-val) - (error 'gfus:win32-error :detail "get-class-long failed")) + (error 'gfs:win32-error :detail "get-class-long failed")) wndproc-val)) (defun subclass-wndproc (hwnd) - (if (zerop (gfus::set-window-long hwnd - gfus::+gwlp-wndproc+ + (if (zerop (gfs::set-window-long hwnd + gfs::+gwlp-wndproc+ (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc)))) - (error 'gfus:win32-error :detail "set-window-long failed"))) + (error 'gfs:win32-error :detail "set-window-long failed"))) ;;; ;;; process-message methods ;;; (defmethod process-message (hwnd msg wparam lparam) - (gfus::def-window-proc hwnd msg wparam lparam)) + (gfs::def-window-proc hwnd msg wparam lparam)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-close+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if w (event-close (dispatcher w) *last-event-time*) - (error 'gfus:toolkit-error :detail "no object for hwnd"))) + (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-command+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) (let ((wparam-hi (hi-word wparam)) (owner (get-widget hwnd))) (if owner @@ -146,27 +146,27 @@ ((zerop lparam) (let ((item (get-menuitem (lo-word wparam)))) (if (null item) - (error 'gfus:toolkit-error :detail "no menu item for id")) + (error 'gfs:toolkit-error :detail "no menu item for id")) (unless (null (dispatcher item)) (event-select (dispatcher item) *last-event-time* item - (make-instance 'gfid:rectangle))))) ; FIXME + (make-instance 'gfi:rectangle))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t (let ((w (get-widget (cffi:make-pointer lparam)))) (if (null w) - (error 'gfus:toolkit-error :detail "no object for hwnd")) + (error 'gfs:toolkit-error :detail "no object for hwnd")) (unless (null (dispatcher w)) (event-select (dispatcher w) *last-event-time* w - (make-instance 'gfid:rectangle)))))) ; FIXME - (error 'gfus:toolkit-error :detail "no object for hwnd"))) + (make-instance 'gfi:rectangle)))))) ; FIXME + (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-initmenupopup+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignorable hwnd lparam)) (let ((menu (get-widget (cffi:make-pointer wparam)))) (unless (null menu) @@ -175,7 +175,7 @@ (event-activate d *last-event-time*))))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-menuselect+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignorable hwnd lparam)) ; FIXME: handle system menus (let ((item (get-menuitem (lo-word wparam)))) (unless (null item) @@ -184,17 +184,17 @@ (event-arm d *last-event-time* item))))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-create+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (declare (ignorable wparam lparam)) (get-widget hwnd) ; has side-effect of setting handle slot 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-destroy+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) (remove-widget hwnd) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-char+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let ((w (get-widget hwnd)) (ch (code-char (lo-word wparam)))) @@ -202,62 +202,62 @@ (event-key-down (dispatcher w) *last-event-time* *last-virtual-key* ch))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-keydown+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) (let* ((wparam-lo (lo-word wparam)) - (ch (gfus::map-virtual-key wparam-lo 2)) + (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget hwnd))) (setf *last-virtual-key* wparam-lo) (when (and w (= ch 0) (= (logand lparam #x40000000) 0)) (event-key-down (dispatcher w) *last-event-time* wparam-lo (code-char ch)))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-keyup+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam) (declare (ignore lparam)) (unless (zerop *last-virtual-key*) (let* ((wparam-lo (lo-word wparam)) - (ch (gfus::map-virtual-key wparam-lo 2)) + (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget hwnd))) (when w (event-key-up (dispatcher w) *last-event-time* wparam-lo (code-char ch))))) (setf *last-virtual-key* 0) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttondblclk+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam 'left-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttondown+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondown+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-down hwnd lparam 'left-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttonup+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttonup+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam 'left-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttondblclk+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam 'middle-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttondown+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondown+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-down hwnd lparam 'middle-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttonup+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttonup+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam 'middle-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-mousemove+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-mousemove+)) wparam lparam) (let ((btn-sym 'left-button)) (cond - ((= (logand wparam gfus::+mk-mbutton+) gfus::+mk-mbutton+) + ((= (logand wparam gfs::+mk-mbutton+) gfs::+mk-mbutton+) (setf btn-sym 'middle-button)) - ((= (logand wparam gfus::+mk-rbutton+) gfus::+mk-rbutton+) + ((= (logand wparam gfs::+mk-rbutton+) gfs::+mk-rbutton+) (setf btn-sym 'right-button)) (t (setf btn-sym 'left-button))) (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) -(defmethod process-message (hwnd (msg (eql gfus::+wm-move+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (when w @@ -265,62 +265,62 @@ (event-move (dispatcher w) *last-event-time* *move-event-pnt*))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-moving+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-move (dispatcher w) *last-event-time*)) 1 0))) -(defmethod process-message (hwnd (msg (eql gfus::+wm-paint+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd)) - (gc (make-instance 'gfug:graphics-context))) + (gc (make-instance 'gfg:graphics-context))) (if w - (let ((rct (make-instance 'gfid:rectangle))) - (cffi:with-foreign-object (ps-ptr 'gfus::paintstruct) - (cffi:with-foreign-slots ((gfus::rcpaint-x - gfus::rcpaint-y - gfus::rcpaint-width - gfus::rcpaint-height) - ps-ptr gfus::paintstruct) - (setf (slot-value gc 'gfis:handle) (gfus::begin-paint hwnd ps-ptr)) - (setf (gfid:location rct) (gfid:make-point :x gfus::rcpaint-x - :y gfus::rcpaint-y)) - (setf (gfid:size rct) (gfid:make-size :width gfus::rcpaint-width - :height gfus::rcpaint-height)) + (let ((rct (make-instance 'gfi:rectangle))) + (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) + (cffi:with-foreign-slots ((gfs::rcpaint-x + gfs::rcpaint-y + gfs::rcpaint-width + gfs::rcpaint-height) + ps-ptr gfs::paintstruct) + (setf (slot-value gc 'gfi:handle) (gfs::begin-paint hwnd ps-ptr)) + (setf (gfi:location rct) (gfi:make-point :x gfs::rcpaint-x + :y gfs::rcpaint-y)) + (setf (gfi:size rct) (gfi:make-size :width gfs::rcpaint-width + :height gfs::rcpaint-height)) (unwind-protect (event-paint (dispatcher w) *last-event-time* gc rct) - (gfus::end-paint hwnd ps-ptr))))) - (error 'gfus:toolkit-error :detail "no object for hwnd"))) + (gfs::end-paint hwnd ps-ptr))))) + (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttondblclk+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam 'right-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttondown+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondown+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-down hwnd lparam 'right-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttonup+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttonup+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-up hwnd lparam 'right-button)) -(defmethod process-message (hwnd (msg (eql gfus::+wm-size+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) (declare (ignore lparam)) (let ((w (get-widget hwnd)) (type (cond - ((= wparam gfus::+size-maximized+) 'maximized) - ((= wparam gfus::+size-minimized+) 'minimized) - ((= wparam gfus::+size-restored+) 'restored) + ((= wparam gfs::+size-maximized+) 'maximized) + ((= wparam gfs::+size-minimized+) 'minimized) + ((= wparam gfs::+size-restored+) 'restored) (t nil)))) (when w (outer-size w *size-event-size*) (event-resize (dispatcher w) *last-event-time* *size-event-size* type))) 0) -(defmethod process-message (hwnd (msg (eql gfus::+wm-sizing+)) wparam lparam) +(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-resize (dispatcher w) *last-event-time*)) @@ -334,10 +334,10 @@ (defmethod process-subclass-message (hwnd msg wparam lparam) (let ((wndproc (get-class-wndproc hwnd))) (if wndproc - (gfus::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam) - (gfus::def-window-proc hwnd msg wparam lparam)))) + (gfs::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam) + (gfs::def-window-proc hwnd msg wparam lparam)))) -(defmethod process-subclass-message (hwnd (msg (eql gfus::+wm-destroy+)) wparam lparam) +(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignorable wparam lparam)) (remove-widget hwnd) (call-next-method)) @@ -346,6 +346,6 @@ ;;; event-dispatcher methods ;;; -(defmethod gfis:dispose ((d event-dispatcher)) +(defmethod gfi:dispose ((d event-dispatcher)) (setf (dispatcher d) nil) (call-next-method)) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sat Feb 11 00:39:07 2006 @@ -42,141 +42,141 @@ ;;; (defun get-menuitem-text (hmenu mid) - (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) - (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type - gfus::state gfus::id gfus::hsubmenu - gfus::hbmpchecked gfus::hbmpunchecked - gfus::idata gfus::tdata gfus::cch - gfus::hbmpitem) - mii-ptr gfus::menuiteminfo) - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) - (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+)) - (setf gfus::type 0) - (setf gfus::state 0) - (setf gfus::id mid) - (setf gfus::hsubmenu (cffi:null-pointer)) - (setf gfus::hbmpchecked (cffi:null-pointer)) - (setf gfus::hbmpunchecked (cffi:null-pointer)) - (setf gfus::idata 0) - (setf gfus::tdata (cffi:null-pointer)) - (setf gfus::cch 0) - (setf gfus::hbmpitem (cffi:null-pointer)) - (if (zerop (gfus::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfus::win32-error :detail "get-menu-item-info failed")) - (incf gfus::cch) - (let ((str-ptr (cffi:foreign-alloc :char :count gfus::cch)) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer)) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs::win32-error :detail "get-menu-item-info failed")) + (incf gfs::cch) + (let ((str-ptr (cffi:foreign-alloc :char :count gfs::cch)) (result "")) (unwind-protect (progn - (setf gfus::tdata str-ptr) - (if (zerop (gfus::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfus::win32-error :detail "get-menu-item-info failed")) + (setf gfs::tdata str-ptr) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs::win32-error :detail "get-menu-item-info failed")) (setf result (cffi:foreign-string-to-lisp str-ptr)) (cffi:foreign-free str-ptr))) result)))) (defun set-menuitem-text (hmenu mid label) (cffi:with-foreign-string (str-ptr label) - (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) - (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type - gfus::state gfus::id gfus::hsubmenu - gfus::hbmpchecked gfus::hbmpunchecked - gfus::idata gfus::tdata gfus::cch - gfus::hbmpitem) - mii-ptr gfus::menuiteminfo) - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) - (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+)) - (setf gfus::type 0) - (setf gfus::state 0) - (setf gfus::id mid) - (setf gfus::hsubmenu (cffi:null-pointer)) - (setf gfus::hbmpchecked (cffi:null-pointer)) - (setf gfus::hbmpunchecked (cffi:null-pointer)) - (setf gfus::idata 0) - (setf gfus::tdata str-ptr) - (setf gfus::cch (length label)) - (setf gfus::hbmpitem (cffi:null-pointer))) - (if (zerop (gfus::set-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfus:win32-error :detail "set-menu-item-info failed"))))) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata str-ptr) + (setf gfs::cch (length label)) + (setf gfs::hbmpitem (cffi:null-pointer))) + (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "set-menu-item-info failed"))))) (defun insert-menuitem (howner mid label hbmp) (cffi:with-foreign-string (str-ptr label) - (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) - (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type - gfus::state gfus::id gfus::hsubmenu - gfus::hbmpchecked gfus::hbmpunchecked - gfus::idata gfus::tdata gfus::cch - gfus::hbmpitem) - mii-ptr gfus::menuiteminfo) - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) - (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+)) - (setf gfus::type 0) - (setf gfus::state 0) - (setf gfus::id mid) - (setf gfus::hsubmenu (cffi:null-pointer)) - (setf gfus::hbmpchecked (cffi:null-pointer)) - (setf gfus::hbmpunchecked (cffi:null-pointer)) - (setf gfus::idata 0) - (setf gfus::tdata str-ptr) - (setf gfus::cch (length label)) - (setf gfus::hbmpitem hbmp)) - (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) - (error 'gfus::win32-error :detail "insert-menu-item failed"))))) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata str-ptr) + (setf gfs::cch (length label)) + (setf gfs::hbmpitem hbmp)) + (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))))) (defun insert-submenu (hparent mid label hbmp hchildmenu) (cffi:with-foreign-string (str-ptr label) - (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) - (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type - gfus::state gfus::id gfus::hsubmenu - gfus::hbmpchecked gfus::hbmpunchecked - gfus::idata gfus::tdata gfus::cch - gfus::hbmpitem) - mii-ptr gfus::menuiteminfo) - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) - (setf gfus::mask (logior gfus::+miim-id+ - gfus::+miim-string+ - gfus::+miim-submenu+)) - (setf gfus::type 0) - (setf gfus::state 0) - (setf gfus::id mid) - (setf gfus::hsubmenu hchildmenu) - (setf gfus::hbmpchecked (cffi:null-pointer)) - (setf gfus::hbmpunchecked (cffi:null-pointer)) - (setf gfus::idata 0) - (setf gfus::tdata str-ptr) - (setf gfus::cch (length label)) - (setf gfus::hbmpitem hbmp)) - (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) - (error 'gfus::win32-error :detail "insert-menu-item failed"))))) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ + gfs::+miim-string+ + gfs::+miim-submenu+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu hchildmenu) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata str-ptr) + (setf gfs::cch (length label)) + (setf gfs::hbmpitem hbmp)) + (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed"))))) (defun insert-separator (howner) - (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) - (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type - gfus::state gfus::id gfus::hsubmenu - gfus::hbmpchecked gfus::hbmpunchecked - gfus::idata gfus::tdata gfus::cch - gfus::hbmpitem) - mii-ptr gfus::menuiteminfo) - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) - (setf gfus::mask gfus::+miim-ftype+) - (setf gfus::type gfus::+mft-separator+) - (setf gfus::state 0) - (setf gfus::id 0) - (setf gfus::hsubmenu (cffi:null-pointer)) - (setf gfus::hbmpchecked (cffi:null-pointer)) - (setf gfus::hbmpunchecked (cffi:null-pointer)) - (setf gfus::idata 0) - (setf gfus::tdata (cffi:null-pointer)) - (setf gfus::cch 0) - (setf gfus::hbmpitem (cffi:null-pointer))) - (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) - (error 'gfus::win32-error :detail "insert-menu-item failed")))) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask gfs::+miim-ftype+) + (setf gfs::type gfs::+mft-separator+) + (setf gfs::state 0) + (setf gfs::id 0) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer))) + (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (error 'gfs::win32-error :detail "insert-menu-item failed")))) (defun sub-menu (m index) - (if (gfis:disposed-p m) - (error 'gfis:disposed-error)) - (let ((hwnd (gfus::get-submenu (gfis:handle m) index))) - (if (not (gfus:null-handle-p hwnd)) + (if (gfi:disposed-p m) + (error 'gfi:disposed-error)) + (let ((hwnd (gfs::get-submenu (gfi:handle m) index))) + (if (not (gfi:null-handle-p hwnd)) (get-widget hwnd) nil))) @@ -193,27 +193,27 @@ ;;; (defun menu-cleanup-callback (menu item) - (remove-widget (gfis:handle menu)) + (remove-widget (gfi:handle menu)) (remove-menuitem item)) -(defmethod gfis:dispose ((m menu)) +(defmethod gfi:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfis:handle m))) + (let ((hwnd (gfi:handle m))) (remove-widget hwnd) - (if (not (gfus:null-handle-p hwnd)) - (if (zerop (gfus::destroy-menu hwnd)) - (error 'gfus:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfis:handle) nil)) + (if (not (gfi:null-handle-p hwnd)) + (if (zerop (gfs::destroy-menu hwnd)) + (error 'gfs:win32-error :detail "destroy-menu failed")))) + (setf (slot-value m 'gfi:handle) nil)) (defmethod item-append ((m menu) (it menu-item)) (let ((id *next-menuitem-id*) - (hmenu (gfis:handle m))) - (if (gfus:null-handle-p hmenu) - (error 'gfis:disposed-error)) + (hmenu (gfi:handle m))) + (if (gfi:null-handle-p hmenu) + (error 'gfi:disposed-error)) (setf *next-menuitem-id* (1+ id)) - (insert-menuitem (gfis:handle m) id " " (cffi:null-pointer)) + (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) (setf (item-id it) id) - (setf (slot-value it 'gfis:handle) hmenu) + (setf (slot-value it 'gfi:handle) hmenu) (put-menuitem it) (call-next-method))) @@ -221,39 +221,39 @@ ;;; item methods ;;; -(defmethod gfis:dispose ((it menu-item)) +(defmethod gfi:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem it) (let ((id (item-id it)) (owner (item-owner it))) (unless (null owner) - (gfus::remove-menu (gfis:handle owner) id gfus::+mf-bycommand+) + (gfs::remove-menu (gfi:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfis:dispose child-menu)))) + (gfi:dispose child-menu)))) (setf (item-id it) 0) - (setf (slot-value it 'gfis:handle) nil))) + (setf (slot-value it 'gfi:handle) nil))) (defmethod item-owner ((it menu-item)) - (let ((hmenu (gfis:handle it))) - (if (gfus:null-handle-p hmenu) - (error 'gfus:toolkit-error :detail "null owner menu handle")) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) (let ((m (get-widget hmenu))) (if (null m) - (error 'gfus:toolkit-error :detail "no owner menu")) + (error 'gfs:toolkit-error :detail "no owner menu")) m))) (defmethod text ((it menu-item)) - (let ((hmenu (gfis:handle it))) - (if (gfus:null-handle-p hmenu) - (error 'gfus:toolkit-error :detail "null owner menu handle")) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) (get-menuitem-text hmenu (item-id it)))) (defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfis:handle it))) - (if (gfus:null-handle-p hmenu) - (error 'gfus:toolkit-error :detail "null owner menu handle")) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) (set-menuitem-text hmenu (item-id it) str))) ;;; @@ -339,7 +339,7 @@ (when dispatcher (setf dispatcher (nth (1+ dispatcher) options)) (if (null dispatcher) - (error 'gfus:toolkit-error :detail "missing dispatcher function"))) + (error 'gfs:toolkit-error :detail "missing dispatcher function"))) (values dispatcher))) (defun parse-menuitem-options (options) @@ -351,23 +351,23 @@ (sub (position-if #'submenu-option-p options))) (when sep (if (or disabled checked image sub) - (error 'gfus:toolkit-error :detail "invalid menu item options")) + (error 'gfs:toolkit-error :detail "invalid menu item options")) (return-from parse-menuitem-options (values nil nil nil nil t nil))) (when image (if sep - (error 'gfus:toolkit-error :detail "invalid menu item options")) + (error 'gfs:toolkit-error :detail "invalid menu item options")) (setf image (nth (1+ image) options)) (if (null image) - (error 'gfus:toolkit-error :detail "missing image filename"))) + (error 'gfs:toolkit-error :detail "missing image filename"))) (when dispatcher (if sep - (error 'gfus:toolkit-error :detail "invalid menu item options")) + (error 'gfs:toolkit-error :detail "invalid menu item options")) (setf dispatcher (nth (1+ dispatcher) options)) (if (null dispatcher) - (error 'gfus:toolkit-error :detail "missing dispatcher function"))) + (error 'gfs:toolkit-error :detail "missing dispatcher function"))) (when sub (if (or checked sep) - (error 'gfus:toolkit-error :detail "invalid menu item options")) + (error 'gfs:toolkit-error :detail "invalid menu item options")) (return-from parse-menuitem-options (values dispatcher disabled nil image nil t))) (values dispatcher disabled checked image nil nil))) @@ -381,7 +381,7 @@ (defun process-menuitem (generator sexp) (if (not (menuitem-form-p sexp)) - (error 'gfus:toolkit-error :detail (format nil "form ~a not a menu item definition" sexp))) + (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" sexp))) (multiple-value-bind (label options body) (parse-menuitem-form sexp) (multiple-value-bind (dispatcher disabled checked image sep sub) @@ -393,7 +393,7 @@ (defun process-menu (generator sexp) (if (not (menu-form-p (car sexp))) - (error 'gfus:toolkit-error :detail (format nil "form ~a not a menu definition" (car sexp)))) + (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu definition" (car sexp)))) (multiple-value-bind (label options body) (parse-menu-form sexp) (multiple-value-bind (dispatcher) @@ -443,7 +443,7 @@ :initform nil))) (defmethod initialize-instance :after ((gen menu-generator) &key) - (let ((m (make-instance 'menu :handle (gfus::create-menu)))) + (let ((m (make-instance 'menu :handle (gfs::create-menu)))) (put-widget m) (setf (menu-stack gen) (list m)))) @@ -451,11 +451,11 @@ (let* ((owner (first (menu-stack gen))) (it (make-instance 'menu-item :dispatcher dispatcher)) (id *next-menuitem-id*) - (hmenu (gfis:handle owner))) + (hmenu (gfi:handle owner))) (setf *next-menuitem-id* (1+ id)) (insert-menuitem hmenu id label (cffi:null-pointer)) (setf (item-id it) id) - (setf (slot-value it 'gfis:handle) hmenu) + (setf (slot-value it 'gfi:handle) hmenu) (put-menuitem it) (vector-push-extend it (items owner)))) @@ -466,19 +466,19 @@ (defmethod define-separator ((gen menu-generator)) (let* ((owner (first (menu-stack gen))) (it (make-instance 'menu-item)) - (hmenu (gfis:handle owner))) + (hmenu (gfi:handle owner))) (put-menuitem it) (insert-separator hmenu) - (setf (slot-value it 'gfis:handle) hmenu) + (setf (slot-value it 'gfi:handle) hmenu) (vector-push-extend it (items owner)))) (defmethod define-menu ((gen menu-generator) label dispatcher) - (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher)) + (let* ((m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) - (it (make-instance 'menu-item :handle (gfis:handle parent) :dispatcher dispatcher)) + (it (make-instance 'menu-item :handle (gfi:handle parent) :dispatcher dispatcher)) (id *next-menuitem-id*)) (setf *next-menuitem-id* (1+ id)) - (insert-submenu (gfis:handle parent) id label (cffi:null-pointer) (gfis:handle m)) + (insert-submenu (gfi:handle parent) id label (cffi:null-pointer) (gfi:handle m)) (setf (item-id it) id) (vector-push-extend it (items parent)) (push m (menu-stack gen)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Feb 11 00:39:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; widget-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -36,7 +36,7 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) -(defclass event-source (gfis:native-object) +(defclass event-source (gfi:native-object) ((dispatcher :accessor dispatcher :initarg :dispatcher Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Sat Feb 11 00:39:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; constants.lisp +;;;; widget-constants.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Feb 11 00:39:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; widgets-generics.lisp +;;;; widget-generics.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat Feb 11 00:39:07 2006 @@ -43,25 +43,25 @@ (mp:process-run-function thread-name nil start-fn)) (defun shutdown (exit-code) - (gfus::post-quit-message exit-code)) + (gfs::post-quit-message exit-code)) (defun clear-all (w) - (let ((count (gfuw:item-count w))) + (let ((count (gfw:item-count w))) (unless (zerop count) - (gfuw:clear-span w (gfid:make-span :start 0 :end (1- count)))))) + (gfw:clear-span w (gfi:make-span :start 0 :end (1- count)))))) (defun create-window (class-name title parent-hwnd std-style ex-style) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (gfus::create-window + (gfs::create-window ex-style cname-ptr title-ptr std-style - gfus::+cw-usedefault+ - gfus::+cw-usedefault+ - gfus::+cw-usedefault+ - gfus::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ parent-hwnd (cffi:null-pointer) (cffi:null-pointer) @@ -73,46 +73,46 @@ (mapcan (function flatten) tree))) (defun get-widget-text (w) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) (let* ((text "") - (hwnd (gfis:handle w)) - (len (gfus::get-window-text-length hwnd))) + (hwnd (gfi:handle w)) + (len (gfs::get-window-text-length hwnd))) (unless (zerop len) (let ((str-ptr (cffi:foreign-alloc :char :count len))) (unwind-protect - (unless (zerop (gfus::get-window-text hwnd str-ptr len)) + (unless (zerop (gfs::get-window-text hwnd str-ptr len)) (setf text (cffi:foreign-string-to-lisp str-ptr))) (cffi:foreign-free str-ptr)))) text)) (defun outer-location (w pnt) - (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo) - (cffi:with-foreign-slots ((gfus::cbsize - gfus::windowleft - gfus::windowtop) - wi-ptr gfus::windowinfo) - (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo)) - (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr)) - (error 'gfus:win32-error :detail "get-window-info failed")) - (setf (gfid:point-x pnt) gfus::windowleft) - (setf (gfid:point-y pnt) gfus::windowtop)))) + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize + gfs::windowleft + gfs::windowtop) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (error 'gfs:win32-error :detail "get-window-info failed")) + (setf (gfi:point-x pnt) gfs::windowleft) + (setf (gfi:point-y pnt) gfs::windowtop)))) (defun outer-size (w sz) - (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo) - (cffi:with-foreign-slots ((gfus::cbsize - gfus::windowleft - gfus::windowtop - gfus::windowright - gfus::windowbottom) - wi-ptr gfus::windowinfo) - (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo)) - (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr)) - (error 'gfus:win32-error :detail "get-window-info failed")) - (setf (gfid:size-width sz) (- gfus::windowright gfus::windowleft)) - (setf (gfid:size-height sz) (- gfus::windowbottom gfus::windowtop))))) + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize + gfs::windowleft + gfs::windowtop + gfs::windowright + gfs::windowbottom) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (error 'gfs:win32-error :detail "get-window-info failed")) + (setf (gfi:size-width sz) (- gfs::windowright gfs::windowleft)) + (setf (gfi:size-height sz) (- gfs::windowbottom gfs::windowtop))))) (defun set-widget-text (w str) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) - (gfus::set-window-text (gfis:handle w) str)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (gfs::set-window-text (gfi:handle w) str)) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Sat Feb 11 00:39:07 2006 @@ -36,12 +36,12 @@ (defmethod clear-item ((w widget-with-items) index) (let ((it (item-at w index))) (delete it (items w) :test #'items-equal-p) - (if (gfis:disposed-p it) - (error 'gfis:disposed-error)) - (gfis:dispose it))) + (if (gfi:disposed-p it) + (error 'gfi:disposed-error)) + (gfi:dispose it))) -(defmethod clear-span ((w widget-with-items) (sp gfid:span)) - (loop for index from (gfid:span-start sp) to (gfid:span-end sp) +(defmethod clear-span ((w widget-with-items) (sp gfi:span)) + (loop for index from (gfi:span-start sp) to (gfi:span-end sp) collect (clear-item w index))) (defmethod item-append ((w widget-with-items) (i item)) @@ -51,7 +51,7 @@ (elt (items w) index)) (defmethod (setf item-at) (index (i item) (w widget-with-items)) - (error 'gfus:toolkit-error :detail "not yet implemented")) + (error 'gfs:toolkit-error :detail "not yet implemented")) (defmethod item-count ((w widget-with-items)) (length (items w))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sat Feb 11 00:39:07 2006 @@ -46,81 +46,81 @@ ;;; (defmethod client-size ((w widget)) - (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo) - (cffi:with-foreign-slots ((gfus::cbsize - gfus::clientleft - gfus::clienttop - gfus::clientright - gfus::clientbottom) - wi-ptr gfus::windowinfo) - (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo)) - (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr)) - (error 'gfus:win32-error :detail "get-window-info failed")) - (gfid:make-size :width (- gfus::clientright gfus::clientleft) - :height (- gfus::clientbottom gfus::clienttop))))) + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize + gfs::clientleft + gfs::clienttop + gfs::clientright + gfs::clientbottom) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr)) + (error 'gfs:win32-error :detail "get-window-info failed")) + (gfi:make-size :width (- gfs::clientright gfs::clientleft) + :height (- gfs::clientbottom gfs::clienttop))))) -(defmethod gfis:dispose ((w widget)) +(defmethod gfi:dispose ((w widget)) (unless (null (dispatcher w)) (event-dispose (dispatcher w) 0)) - (let ((hwnd (gfis:handle w))) - (if (not (gfus:null-handle-p hwnd)) - (if (zerop (gfus::destroy-window hwnd)) - (error 'gfus:win32-error :detail "destroy-window failed")))) - (setf (slot-value w 'gfis:handle) nil)) + (let ((hwnd (gfi:handle w))) + (if (not (gfi:null-handle-p hwnd)) + (if (zerop (gfs::destroy-window hwnd)) + (error 'gfs:win32-error :detail "destroy-window failed")))) + (setf (slot-value w 'gfi:handle) nil)) (defmethod hide :before ((w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error))) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) (defmethod location ((w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) - (let ((pnt (gfid:make-point))) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((pnt (gfi:make-point))) (outer-location w pnt) pnt)) -(defmethod (setf location) ((pnt gfid:point) (w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) - (if (zerop (gfus::set-window-pos (gfis:handle w) +(defmethod (setf location) ((pnt gfi:point) (w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (if (zerop (gfs::set-window-pos (gfi:handle w) (cffi:null-pointer) - (gfid:point-x pnt) - (gfid:point-y pnt) + (gfi:point-x pnt) + (gfi:point-y pnt) 0 0 - gfus::+swp-nosize+)) - (error 'gfus:win32-error :detail "set-window-pos failed"))) + gfs::+swp-nosize+)) + (error 'gfs:win32-error :detail "set-window-pos failed"))) (defmethod redraw ((w widget)) - (let ((hwnd (gfis:handle w))) - (unless (gfus:null-handle-p hwnd) - (gfus::invalidate-rect hwnd nil 1)))) + (let ((hwnd (gfi:handle w))) + (unless (gfi:null-handle-p hwnd) + (gfs::invalidate-rect hwnd nil 1)))) (defmethod size ((w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) - (let ((sz (gfid:make-size))) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (let ((sz (gfi:make-size))) (outer-size w sz) sz)) -(defmethod (setf size) ((sz gfid:size) (w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error)) - (if (zerop (gfus::set-window-pos (gfis:handle w) +(defmethod (setf size) ((sz gfi:size) (w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)) + (if (zerop (gfs::set-window-pos (gfi:handle w) (cffi:null-pointer) 0 0 - (gfid:size-width sz) - (gfid:size-height sz) - gfus::+swp-nomove+)) - (error 'gfus:win32-error :detail "set-window-pos failed"))) + (gfi:size-width sz) + (gfi:size-height sz) + gfs::+swp-nomove+)) + (error 'gfs:win32-error :detail "set-window-pos failed"))) (defmethod show :before ((w widget)) - (if (gfis:disposed-p w) - (error 'gfis:disposed-error))) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) (defmethod update ((w widget)) - (let ((hwnd (gfis:handle w))) - (unless (gfus:null-handle-p hwnd) - (gfus::update-window hwnd)))) + (let ((hwnd (gfi:handle w))) + (unless (gfi:null-handle-p hwnd) + (gfs::update-window hwnd)))) ;;; ;;; widget table management @@ -134,13 +134,13 @@ (defun get-widget (hwnd) (when *widget-in-progress* - (setf (slot-value *widget-in-progress* 'gfis:handle) hwnd) + (setf (slot-value *widget-in-progress* 'gfi:handle) hwnd) (return-from get-widget *widget-in-progress*)) - (unless (gfus:null-handle-p hwnd) + (unless (gfi:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) *widgets-by-hwnd*))) (defun put-widget (w) - (setf (gethash (cffi:pointer-address (gfis:handle w)) *widgets-by-hwnd*) w)) + (setf (gethash (cffi:pointer-address (gfi:handle w)) *widgets-by-hwnd*) w)) (defun remove-widget (hwnd) (when (not *widget-in-progress*) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Feb 11 00:39:07 2006 @@ -46,9 +46,9 @@ ;; FIXME: causes GPF ;; (cffi:defcallback child_hwnd_collector - gfus::BOOL - ((hwnd gfus::HANDLE) - (lparam gfus::LPARAM)) + gfs::BOOL + ((hwnd gfs::HANDLE) + (lparam gfs::LPARAM)) (let ((w (get-widget hwnd))) (unless (or (null w) (null *child-visiting-functions*)) (funcall (car *child-visiting-functions*) w lparam))) @@ -62,49 +62,49 @@ ;; (push func *child-visiting-functions*) (unwind-protect - (gfus::enum-child-windows (gfis:handle win) (cffi:get-callback 'child_hwnd_collector) val) + (gfs::enum-child-windows (gfi:handle win) (cffi:get-callback 'child_hwnd_collector) val) (pop *child-visiting-functions*))) (defun register-window-class (class-name proc-ptr st) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) - (cffi:with-foreign-object (wc-ptr 'gfus::wndclassex) - (cffi:with-foreign-slots ((gfus::cbsize gfus::style gfus::wndproc - gfus::clsextra gfus::wndextra gfus::hinst - gfus::hicon gfus::hcursor gfus::hbrush - gfus::menuname gfus::classname gfus::smallicon) - wc-ptr gfus::wndclassex) + (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::style gfs::wndproc + gfs::clsextra gfs::wndextra gfs::hinst + gfs::hicon gfs::hcursor gfs::hbrush + gfs::menuname gfs::classname gfs::smallicon) + wc-ptr gfs::wndclassex) ;; FIXME: move this if form outside of with-foreign-slots ;; - (if (zerop (gfus::get-class-info (gfus::get-module-handle (cffi:null-pointer)) + (if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) (progn - (setf gfus::cbsize (cffi:foreign-type-size 'gfus::wndclassex)) - (setf gfus::style st) - (setf gfus::wndproc proc-ptr) - (setf gfus::clsextra 0) - (setf gfus::wndextra 0) - (setf gfus::hinst (gfus::get-module-handle (cffi:null-pointer))) - (setf gfus::hicon (cffi:null-pointer)) - (setf gfus::hcursor (gfus::load-image (cffi:null-pointer) - (cffi:make-pointer gfus::+ocr-normal+) - gfus::+image-cursor+ 0 0 - (logior gfus::+lr-defaultcolor+ - gfus::+lr-shared+))) - (setf gfus::hbrush (cffi:make-pointer (1+ gfus::+color-appworkspace+))) - (setf gfus::menuname (cffi:null-pointer)) - (setf gfus::classname str-ptr) - (setf gfus::smallicon (cffi:null-pointer)) - (setf retval (gfus::register-class wc-ptr))) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) + (setf gfs::style st) + (setf gfs::wndproc proc-ptr) + (setf gfs::clsextra 0) + (setf gfs::wndextra 0) + (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer))) + (setf gfs::hicon (cffi:null-pointer)) + (setf gfs::hcursor (gfs::load-image (cffi:null-pointer) + (cffi:make-pointer gfs::+ocr-normal+) + gfs::+image-cursor+ 0 0 + (logior gfs::+lr-defaultcolor+ + gfs::+lr-shared+))) + (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+))) + (setf gfs::menuname (cffi:null-pointer)) + (setf gfs::classname str-ptr) + (setf gfs::smallicon (cffi:null-pointer)) + (setf retval (gfs::register-class wc-ptr))) (setf retval 1)) (if (/= retval 0) retval - (error 'gfus::win32-error :detail "register-class failed"))))))) + (error 'gfs::win32-error :detail "register-class failed"))))))) (defun register-workspace-window-class () (register-window-class +workspace-window-classname+ (cffi:get-callback 'uit_widgets_wndproc) - (logior gfus::+cs-hredraw+ gfus::+cs-vredraw+))) + (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+))) ;;; ;;; methods @@ -119,85 +119,85 @@ ;; styles that can be combined ;; ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfus::+ws-hscroll+))) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) ((eq sym :style-max) - (setf std-flags (logior std-flags gfus::+ws-maximizebox+))) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) ((eq sym :style-min) - (setf std-flags (logior std-flags gfus::+ws-minimizebox+))) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) ((eq sym :style-resize) - (setf std-flags (logior std-flags gfus::+ws-thickframe+))) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfus::+ws-sysmenu+))) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) ((eq sym :style-title) - (setf std-flags (logior std-flags gfus::+ws-caption+))) + (setf std-flags (logior std-flags gfs::+ws-caption+))) ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfus::+ws-ex-topmost+))) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfus::+ws-vscroll+))) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) ;; pre-packaged combinations of window styles ;; ((eq sym :style-no-title) (setf std-flags 0) - (setf ex-flags gfus::+ws-ex-windowedge+)) + (setf ex-flags gfs::+ws-ex-windowedge+)) ((eq sym :style-splash) - (setf std-flags (logior gfus::+ws-overlapped+ - gfus::+ws-popup+ - gfus::+ws-clipsiblings+ - gfus::+ws-border+ - gfus::+ws-visible+)) + (setf std-flags (logior gfs::+ws-overlapped+ + gfs::+ws-popup+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-visible+)) (setf ex-flags 0)) ((eq sym :style-tool) (setf std-flags 0) - (setf ex-flags gfus::+ws-ex-palettewindow+)) + (setf ex-flags gfs::+ws-ex-palettewindow+)) ((eq sym :style-workspace) - (setf std-flags (logior gfus::+ws-overlapped+ - gfus::+ws-clipsiblings+ - gfus::+ws-clipchildren+ - gfus::+ws-caption+ - gfus::+ws-sysmenu+ - gfus::+ws-thickframe+ - gfus::+ws-minimizebox+ - gfus::+ws-maximizebox+)) + (setf std-flags (logior gfs::+ws-overlapped+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+ + gfs::+ws-caption+ + gfs::+ws-sysmenu+ + gfs::+ws-thickframe+ + gfs::+ws-minimizebox+ + gfs::+ws-maximizebox+)) (setf ex-flags 0)))) (flatten style)) (values std-flags ex-flags))) -(defmethod gfis:dispose ((win window)) +(defmethod gfi:dispose ((win window)) (let ((m (menu-bar win))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (gfis:handle m)))) + (remove-widget (gfi:handle m)))) (call-next-method)) (defmethod hide ((win window)) - (gfus::show-window (gfis:handle win) gfus::+sw-hide+)) + (gfs::show-window (gfi:handle win) gfs::+sw-hide+)) (defmethod menu-bar ((win window)) - (let ((hmenu (gfus::get-menu (gfis:handle win)))) - (if (gfus:null-handle-p hmenu) + (let ((hmenu (gfs::get-menu (gfi:handle win)))) + (if (gfi:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget hmenu))) (if (null m) - (error 'gfus:toolkit-error :detail "no object for menu handle")) + (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) (defmethod (setf menu-bar) ((m menu) (win window)) - (let* ((hwnd (gfis:handle win)) - (hmenu (gfus::get-menu hwnd)) + (let* ((hwnd (gfi:handle win)) + (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget hmenu))) - (unless (gfus:null-handle-p hmenu) - (gfus::destroy-menu hmenu)) + (unless (gfi:null-handle-p hmenu) + (gfs::destroy-menu hmenu)) (unless (null old-menu) - (gfis:dispose old-menu)) - (gfus::set-menu hwnd (gfis:handle m)) - (gfus::draw-menu-bar hwnd))) + (gfi:dispose old-menu)) + (gfs::set-menu hwnd (gfi:handle m)) + (gfs::draw-menu-bar hwnd))) (defmethod realize ((win window) parent &rest style) (if (not (null parent)) - (error 'gfus:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future - (if (not (gfis:disposed-p win)) - (error 'gfus:toolkit-error :detail "object already realized")) + (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future + (if (not (gfi:disposed-p win)) + (error 'gfs:toolkit-error :detail "object already realized")) (set-widget-in-progress win) (register-workspace-window-class) (multiple-value-bind (std-style ex-style) @@ -208,12 +208,12 @@ std-style ex-style)) (clear-widget-in-progress) - (let ((hwnd (gfis:handle win))) + (let ((hwnd (gfi:handle win))) (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfus:win32-error :detail "create-window failed")) + (error 'gfs:win32-error :detail "create-window failed")) (put-widget win))) (defmethod show ((win window)) - (let ((hwnd (gfis:handle win))) - (gfus::show-window hwnd gfus::+sw-shownormal+) - (gfus::update-window hwnd))) + (let ((hwnd (gfi:handle win))) + (gfs::show-window hwnd gfs::+sw-shownormal+) + (gfs::update-window hwnd)))

1 0

[graphic-forms-cvs] r4 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Feb '06

10 Feb '06

Author: junrue Date: Fri Feb 10 01:37:07 2006 New Revision: 4 Added: trunk/src/intrinsics/system/native-classes.lisp - copied, changed from r1, trunk/src/intrinsics/system/system-classes.lisp trunk/src/intrinsics/system/native-conditions.lisp - copied, changed from r1, trunk/src/intrinsics/system/system-conditions.lisp Removed: trunk/src/intrinsics/system/system-classes.lisp trunk/src/intrinsics/system/system-conditions.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed filename conflict; overhauled menu cleanup; implemented more menu mgmnt Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Feb 10 01:37:07 2006 @@ -54,8 +54,8 @@ ((:file "datastruct-classes"))) (:module "system" :components - ((:file "system-classes") - (:file "system-conditions") + ((:file "native-classes") + (:file "native-conditions") (:file "native-object-generics") (:file "native-object"))))) (:module "uitoolkit" Copied: trunk/src/intrinsics/system/native-classes.lisp (from r1, trunk/src/intrinsics/system/system-classes.lisp) ============================================================================== --- trunk/src/intrinsics/system/system-classes.lisp (original) +++ trunk/src/intrinsics/system/native-classes.lisp Fri Feb 10 01:37:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; native-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Copied: trunk/src/intrinsics/system/native-conditions.lisp (from r1, trunk/src/intrinsics/system/system-conditions.lisp) ============================================================================== --- trunk/src/intrinsics/system/system-conditions.lisp (original) +++ trunk/src/intrinsics/system/native-conditions.lisp Fri Feb 10 01:37:07 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; conditions.lisp +;;;; native-conditions.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Feb 10 01:37:07 2006 @@ -310,6 +310,7 @@ #:border-width #:caret #:checked-p + #:clear-all #:clear-item #:clear-selection #:clear-span @@ -387,15 +388,16 @@ #:header-visible-p #:iconify #:iconified-p - #:image - #:item-id #:hide #:hide-header #:hide-lines #:horizontal-scrollbar + #:image + #:item-append #:item-at #:item-count #:item-height + #:item-id #:item-index #:item-owner #:items @@ -455,6 +457,7 @@ #:startup #:step-increment #:style + #:sub-menu #:text #:text-height #:text-limit Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Feb 10 01:37:07 2006 @@ -36,21 +36,21 @@ (defconstant +btn-text-1+ "Push Me") (defconstant +btn-text-2+ "Again!") -(defparameter *layout-win* nil) +(defparameter *layout-tester-win* nil) (defun exit-layout-tester () - (let ((w *layout-win*)) - (setf *layout-win* nil) + (let ((w *layout-tester-win*)) + (setf *layout-tester-win* nil) (gfis:dispose w)) (gfuw:shutdown 0)) -(defclass fill-events (gfuw:event-dispatcher) ()) +(defclass layout-tester-events (gfuw:event-dispatcher) ()) -(defmethod gfuw:event-close ((d fill-events) time) +(defmethod gfuw:event-close ((d layout-tester-events) time) (declare (ignore time)) (exit-layout-tester)) -(defclass fill-btn-events (gfuw:event-dispatcher) +(defclass layout-tester-btn-events (gfuw:event-dispatcher) ((button :accessor button :initarg :button @@ -59,24 +59,40 @@ :accessor toggle-fn :initform nil))) -(defmethod gfuw:event-select ((d fill-btn-events) time item rect) +(defmethod gfuw:event-select ((d layout-tester-btn-events) time item rect) (declare (ignorable time rect)) (let ((btn (button d))) (setf (gfuw:text btn) (funcall (toggle-fn d))))) -(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ()) +(defclass layout-tester-child-menu-dispatcher (gfuw:event-dispatcher) ()) -(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect) +(defmethod gfuw:event-activate ((d layout-tester-child-menu-dispatcher) time) + (declare (ignore time)) + (let* ((mb (gfuw:menu-bar *layout-tester-win*)) + (menu (gfuw:sub-menu mb 1))) + (gfuw:clear-all menu) + (gfuw::visit-child-widgets *layout-tester-win* + #'(lambda (child val) + (declare (ignore val)) + (let ((it (make-instance 'gfuw:menu-item))) + (gfuw:item-append menu it) + (setf (gfuw:text it) (gfuw:text child)))) + 0))) + +(defclass layout-tester-exit-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d layout-tester-exit-dispatcher) time item rect) (declare (ignorable time item rect)) (exit-layout-tester)) (defun run-layout-tester-internal () (let* ((menubar nil) - (md (make-instance 'fill-exit-dispatcher)) - (bd (make-instance 'fill-btn-events)) - (btn (make-instance 'gfuw:button :dispatcher bd))) - (setf (button bd) btn) - (setf (toggle-fn bd) (let ((flag nil)) + (fed (make-instance 'layout-tester-exit-dispatcher)) + (be (make-instance 'layout-tester-btn-events)) + (cmd (make-instance 'layout-tester-child-menu-dispatcher)) + (btn (make-instance 'gfuw:button :dispatcher be))) + (setf (button be) btn) + (setf (toggle-fn be) (let ((flag nil)) #'(lambda () (if (null flag) (progn @@ -85,18 +101,19 @@ (progn (setf flag nil) +btn-text-2+))))) - (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events))) - (gfuw:realize *layout-win* nil :style-workspace) - (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150)) + (setf *layout-tester-win* (make-instance 'gfuw:window :dispatcher (make-instance 'layout-tester-events))) + (gfuw:realize *layout-tester-win* nil :style-workspace) + (setf (gfuw:size *layout-tester-win*) (gfid:make-size :width 200 :height 150)) (setf menubar (gfuw:defmenusystem `(((:menu "&File") - (:menuitem "E&xit" :dispatcher ,md)) - ((:menu "&Children"))))) - (setf (gfuw:menu-bar *layout-win*) menubar) - (gfuw:realize btn *layout-win* :push-button) - (setf (gfuw:text btn) (funcall (toggle-fn bd))) + (:menuitem "E&xit" :dispatcher ,fed)) + ((:menu "&Children" :dispatcher ,cmd) + (:menuitem :separator))))) + (setf (gfuw:menu-bar *layout-tester-win*) menubar) + (gfuw:realize btn *layout-tester-win* :push-button) + (setf (gfuw:text btn) (funcall (toggle-fn be))) (setf (gfuw:location btn) (gfid:make-point)) (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1)) - (gfuw:show *layout-win*) + (gfuw:show *layout-tester-win*) (gfuw:run-default-message-loop))) (defun run-layout-tester () Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Feb 10 01:37:07 2006 @@ -211,6 +211,9 @@ (defconstant +lr-copyfromresource+ #x4000) (defconstant +lr-shared+ #x8000) +(defconstant +mf-bycommand+ #x00000000) +(defconstant +mf-byposition+ #x00000400) + (defconstant +mfs-grayed+ #x00000003) (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Feb 10 01:37:07 2006 @@ -288,6 +288,13 @@ (hdc HANDLE)) (defcfun + ("RemoveMenu" remove-menu) + BOOL + (hmenu HANDLE) + (pos UINT) + (flags UINT)) + +(defcfun ("SendMessageA" send-message) LRESULT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Fri Feb 10 01:37:07 2006 @@ -34,4 +34,4 @@ (in-package :graphic-forms.uitoolkit.widgets) (defun items-equal-p (item1 item2) - (string= (text item1) (text item2))) + (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Fri Feb 10 01:37:07 2006 @@ -75,7 +75,31 @@ (cffi:foreign-free str-ptr))) result)))) -(defun insert-menuitem (hparent mid label hbmp) +(defun set-menuitem-text (hmenu mid label) + (cffi:with-foreign-string (str-ptr label) + (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) + (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type + gfus::state gfus::id gfus::hsubmenu + gfus::hbmpchecked gfus::hbmpunchecked + gfus::idata gfus::tdata gfus::cch + gfus::hbmpitem) + mii-ptr gfus::menuiteminfo) + (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo)) + (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+)) + (setf gfus::type 0) + (setf gfus::state 0) + (setf gfus::id mid) + (setf gfus::hsubmenu (cffi:null-pointer)) + (setf gfus::hbmpchecked (cffi:null-pointer)) + (setf gfus::hbmpunchecked (cffi:null-pointer)) + (setf gfus::idata 0) + (setf gfus::tdata str-ptr) + (setf gfus::cch (length label)) + (setf gfus::hbmpitem (cffi:null-pointer))) + (if (zerop (gfus::set-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfus:win32-error :detail "set-menu-item-info failed"))))) + +(defun insert-menuitem (howner mid label hbmp) (cffi:with-foreign-string (str-ptr label) (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type @@ -96,7 +120,7 @@ (setf gfus::tdata str-ptr) (setf gfus::cch (length label)) (setf gfus::hbmpitem hbmp)) - (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) (error 'gfus::win32-error :detail "insert-menu-item failed"))))) (defun insert-submenu (hparent mid label hbmp hchildmenu) @@ -125,7 +149,7 @@ (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) (error 'gfus::win32-error :detail "insert-menu-item failed"))))) -(defun insert-separator (hparent) +(defun insert-separator (howner) (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo) (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type gfus::state gfus::id gfus::hsubmenu @@ -145,26 +169,35 @@ (setf gfus::tdata (cffi:null-pointer)) (setf gfus::cch 0) (setf gfus::hbmpitem (cffi:null-pointer))) - (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) (error 'gfus::win32-error :detail "insert-menu-item failed")))) +(defun sub-menu (m index) + (if (gfis:disposed-p m) + (error 'gfis:disposed-error)) + (let ((hwnd (gfus::get-submenu (gfis:handle m) index))) + (if (not (gfus:null-handle-p hwnd)) + (get-widget hwnd) + nil))) + +(defun visit-menu-tree (menu fn) + (dotimes (index (item-count menu)) + (let ((it (item-at menu index)) + (child (sub-menu menu index))) + (unless (null child) + (visit-menu-tree child fn)) + (funcall fn menu it)))) + ;;; ;;; menu methods ;;; -(defun recursively-dispose-menuitem (it) - (let ((hsubmenu (gfis:handle it))) - (unless (gfus:null-handle-p hsubmenu) - (let ((m (get-widget hsubmenu))) - (if (null m) - (error 'gfus:toolkit-error :detail "no object for hmenu")) - (gfis:dispose m)))) - (gfis:dispose it)) +(defun menu-cleanup-callback (menu item) + (remove-widget (gfis:handle menu)) + (remove-menuitem item)) (defmethod gfis:dispose ((m menu)) - (let ((tmp (items m))) - (dotimes (i (length tmp)) - (recursively-dispose-menuitem (elt tmp i)))) + (visit-menu-tree m #'menu-cleanup-callback) (let ((hwnd (gfis:handle m))) (remove-widget hwnd) (if (not (gfus:null-handle-p hwnd)) @@ -172,6 +205,18 @@ (error 'gfus:win32-error :detail "destroy-menu failed")))) (setf (slot-value m 'gfis:handle) nil)) +(defmethod item-append ((m menu) (it menu-item)) + (let ((id *next-menuitem-id*) + (hmenu (gfis:handle m))) + (if (gfus:null-handle-p hmenu) + (error 'gfis:disposed-error)) + (setf *next-menuitem-id* (1+ id)) + (insert-menuitem (gfis:handle m) id " " (cffi:null-pointer)) + (setf (item-id it) id) + (setf (slot-value it 'gfis:handle) hmenu) + (put-menuitem it) + (call-next-method))) + ;;; ;;; item methods ;;; @@ -179,14 +224,40 @@ (defmethod gfis:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem it) - (setf (item-id it) 0) - (setf (slot-value it 'gfis:handle) nil)) ; menu-item slot is for parent menu - -(defmethod text ((i menu-item)) - (get-menuitem-text (gfis:handle (item-owner i)) (item-id i))) + (let ((id (item-id it)) + (owner (item-owner it))) + (unless (null owner) + (gfus::remove-menu (gfis:handle owner) id gfus::+mf-bycommand+) + (let* ((index (item-index owner it)) + (child-menu (sub-menu owner index))) + (unless (null child-menu) + (gfis:dispose child-menu)))) + (setf (item-id it) 0) + (setf (slot-value it 'gfis:handle) nil))) + +(defmethod item-owner ((it menu-item)) + (let ((hmenu (gfis:handle it))) + (if (gfus:null-handle-p hmenu) + (error 'gfus:toolkit-error :detail "null owner menu handle")) + (let ((m (get-widget hmenu))) + (if (null m) + (error 'gfus:toolkit-error :detail "no owner menu")) + m))) + +(defmethod text ((it menu-item)) + (let ((hmenu (gfis:handle it))) + (if (gfus:null-handle-p hmenu) + (error 'gfus:toolkit-error :detail "null owner menu handle")) + (get-menuitem-text hmenu (item-id it)))) + +(defmethod (setf text) (str (it menu-item)) + (let ((hmenu (gfis:handle it))) + (if (gfus:null-handle-p hmenu) + (error 'gfus:toolkit-error :detail "null owner menu handle")) + (set-menuitem-text hmenu (item-id it) str))) ;;; -;;; DSL implementation +;;; menu language compiler ;;; ;;; an example menubar definition: ;;; @@ -268,7 +339,7 @@ (when dispatcher (setf dispatcher (nth (1+ dispatcher) options)) (if (null dispatcher) - (error 'toolkit-error :detail "missing dispatcher function"))) + (error 'gfus:toolkit-error :detail "missing dispatcher function"))) (values dispatcher))) (defun parse-menuitem-options (options) @@ -280,23 +351,23 @@ (sub (position-if #'submenu-option-p options))) (when sep (if (or disabled checked image sub) - (error 'toolkit-error :detail "invalid menu item options")) + (error 'gfus:toolkit-error :detail "invalid menu item options")) (return-from parse-menuitem-options (values nil nil nil nil t nil))) (when image (if sep - (error 'toolkit-error :detail "invalid menu item options")) + (error 'gfus:toolkit-error :detail "invalid menu item options")) (setf image (nth (1+ image) options)) (if (null image) - (error 'toolkit-error :detail "missing image filename"))) + (error 'gfus:toolkit-error :detail "missing image filename"))) (when dispatcher (if sep - (error 'toolkit-error :detail "invalid menu item options")) + (error 'gfus:toolkit-error :detail "invalid menu item options")) (setf dispatcher (nth (1+ dispatcher) options)) (if (null dispatcher) - (error 'toolkit-error :detail "missing dispatcher function"))) + (error 'gfus:toolkit-error :detail "missing dispatcher function"))) (when sub (if (or checked sep) - (error 'toolkit-error :detail "invalid menu item options")) + (error 'gfus:toolkit-error :detail "invalid menu item options")) (return-from parse-menuitem-options (values dispatcher disabled nil image nil t))) (values dispatcher disabled checked image nil nil))) @@ -377,35 +448,39 @@ (setf (menu-stack gen) (list m)))) (defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image) - (let* ((parent (first (menu-stack gen))) + (let* ((owner (first (menu-stack gen))) (it (make-instance 'menu-item :dispatcher dispatcher)) - (id *next-menuitem-id*)) + (id *next-menuitem-id*) + (hmenu (gfis:handle owner))) (setf *next-menuitem-id* (1+ id)) + (insert-menuitem hmenu id label (cffi:null-pointer)) (setf (item-id it) id) + (setf (slot-value it 'gfis:handle) hmenu) (put-menuitem it) - (item-append parent it) - (insert-menuitem (gfis:handle parent) id label (cffi:null-pointer)))) + (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image) (declare (ignore dispatcher) (ignore enabled) (ignore image)) (process-menu gen submenu)) (defmethod define-separator ((gen menu-generator)) - (let* ((parent (first (menu-stack gen))) - (it (make-instance 'menu-item))) + (let* ((owner (first (menu-stack gen))) + (it (make-instance 'menu-item)) + (hmenu (gfis:handle owner))) (put-menuitem it) - (item-append parent it) - (insert-separator (gfis:handle parent)))) + (insert-separator hmenu) + (setf (slot-value it 'gfis:handle) hmenu) + (vector-push-extend it (items owner)))) (defmethod define-menu ((gen menu-generator) label dispatcher) (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) - (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher)) + (it (make-instance 'menu-item :handle (gfis:handle parent) :dispatcher dispatcher)) (id *next-menuitem-id*)) (setf *next-menuitem-id* (1+ id)) - (setf (item-id it) id) - (item-append parent it) (insert-submenu (gfis:handle parent) id label (cffi:null-pointer) (gfis:handle m)) + (setf (item-id it) id) + (vector-push-extend it (items parent)) (push m (menu-stack gen)) (put-widget m) m)) @@ -414,11 +489,10 @@ (setf (menu-stack gen) (cdr (menu-stack gen)))) (defmacro defmenusystem (sexp) - `(let ((gen (gensym)) - (var (gensym))) - (setf gen (make-instance 'menu-generator)) - (mapcar #'(lambda (var) (process-menu gen var)) ,sexp) - (first (menu-stack gen)))) + (let ((gen (gensym))) + `(let ((,gen (make-instance 'menu-generator))) + (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp) + (first (menu-stack ,gen))))) ;;; ;;; menuitems table management @@ -437,18 +511,3 @@ (if (eql k (item-id it)) (remhash k *menuitems-by-id*))) *menuitems-by-id*)) - -(defun recursively-cleanup-menuitem (it) - (let ((hsubmenu (gfis:handle it))) - (unless (gfus:null-handle-p hsubmenu) - (let ((m (get-widget hsubmenu))) - (if (null m) - (error 'gfus:toolkit-error :detail "no object for hmenu")) - (cleanup-menu-tables m)))) - (remove-menuitem it)) - -(defun cleanup-menu-tables (m) - (let ((tmp (items m))) - (dotimes (i (length tmp)) - (recursively-cleanup-menuitem (elt tmp i)))) - (remove-widget (gfis:handle m))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Feb 10 01:37:07 2006 @@ -47,11 +47,7 @@ ((item-id :accessor item-id :initarg :item-id - :initform 0) - (item-owner - :accessor item-owner - :initarg :item-owner - :initform nil)) + :initform 0)) (:documentation "The item class is the base class for all non-windowed user interface objects.")) (defclass menu-item (item) () @@ -72,7 +68,8 @@ (defclass widget-with-items (widget) ((items :accessor items - :initform (make-array 7 :fill-pointer 0 :adjustable t))) ; allow subclasses to set size? + ;; FIXME: allow subclasses to set initial size? + :initform (make-array 7 :fill-pointer 0 :adjustable t))) (:documentation "The widget-with-items class is the base class for objects composed of fine-grained items.")) (defclass menu (widget-with-items) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Feb 10 01:37:07 2006 @@ -213,6 +213,9 @@ (defgeneric item-index (object other) (:documentation "Return the zero-based index of the location of the other object in this object.")) +(defgeneric item-owner (object) + (:documentation "Return the widget containing this item.")) + (defgeneric layout (object) (:documentation "Set the size and location of this object's children.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Feb 10 01:37:07 2006 @@ -45,6 +45,11 @@ (defun shutdown (exit-code) (gfus::post-quit-message exit-code)) +(defun clear-all (w) + (let ((count (gfuw:item-count w))) + (unless (zerop count) + (gfuw:clear-span w (gfid:make-span :start 0 :end (1- count)))))) + (defun create-window (class-name title parent-hwnd std-style ex-style) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Fri Feb 10 01:37:07 2006 @@ -33,9 +33,19 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defmethod clear-item ((w widget-with-items) index) + (let ((it (item-at w index))) + (delete it (items w) :test #'items-equal-p) + (if (gfis:disposed-p it) + (error 'gfis:disposed-error)) + (gfis:dispose it))) + +(defmethod clear-span ((w widget-with-items) (sp gfid:span)) + (loop for index from (gfid:span-start sp) to (gfid:span-end sp) + collect (clear-item w index))) + (defmethod item-append ((w widget-with-items) (i item)) - (vector-push-extend i (items w)) - (setf (item-owner i) w)) + (vector-push-extend i (items w))) (defmethod item-at ((w widget-with-items) index) (elt (items w) index)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Feb 10 01:37:07 2006 @@ -33,7 +33,7 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +workspace-window-classname+ "JCLUIT_WorkspaceWindow") +(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow") (defconstant +default-window-title+ "New Window") @@ -43,19 +43,22 @@ ;;; helper functions ;;; +;; FIXME: causes GPF +;; (cffi:defcallback child_hwnd_collector gfus::BOOL ((hwnd gfus::HANDLE) (lparam gfus::LPARAM)) (let ((w (get-widget hwnd))) (unless (or (null w) (null *child-visiting-functions*)) - (funcall (car *child-visiting-functions*) w lparam)))) + (funcall (car *child-visiting-functions*) w lparam))) + 1) -(defun visit-child-windows (win func val) +(defun visit-child-widgets (win func val) ;; ;; supplied closure should accept two parameters: - ;; current child window - ;; long value passed to map-child-windows + ;; current child widget + ;; long value passed to visit-child-windows ;; (push func *child-visiting-functions*) (unwind-protect @@ -163,7 +166,8 @@ (defmethod gfis:dispose ((win window)) (let ((m (menu-bar win))) (unless (null m) - (cleanup-menu-tables m))) + (visit-menu-tree m #'menu-cleanup-callback) + (remove-widget (gfis:handle m)))) (call-next-method)) (defmethod hide ((win window)) @@ -175,7 +179,7 @@ (return-from menu-bar nil)) (let ((m (get-widget hmenu))) (if (null m) - (error 'gfus:toolkit-error :detail "no object for hmenu")) + (error 'gfus:toolkit-error :detail "no object for menu handle")) m))) (defmethod (setf menu-bar) ((m menu) (win window))

1 0

[graphic-forms-cvs] r3 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 08 Feb '06

08 Feb '06

Author: junrue Date: Tue Feb 7 22:50:33 2006 New Revision: 3 Added: trunk/src/tests/uitoolkit/layout-tester.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-conditions.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu.lisp Log: first implementation of menu activation and arming Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Tue Feb 7 22:50:33 2006 @@ -49,5 +49,6 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world") - (:file "event-tester"))))))))) + ((:file "event-tester") + (:file "hello-world") + (:file "layout-tester"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Feb 7 22:50:33 2006 @@ -338,6 +338,7 @@ #:disable-layout #:disable-redraw #:disabled-image + #:dispatcher #:display-to-object #:echo-char #:enable Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Feb 7 22:50:33 2006 @@ -34,7 +34,7 @@ (in-package #:graphic-forms.uitoolkit.tests) (defparameter *event-tester-window* nil) -(defparameter *text* "Hello!") +(defparameter *event-tester-text* "Hello!") (defvar *event-counter* 0) (defvar *mouse-down-flag* nil) @@ -46,11 +46,13 @@ (defclass event-tester-window-events (gfuw:event-dispatcher) ()) -(defmethod gfuw:event-paint ((d event-tester-window-events) time (gc gfug:graphics-context) rect) - (declare (ignore time) (ignore rect)) +(defmethod gfuw:event-paint ((d event-tester-window-events) time gc rect) + (declare (ignorable time rect)) (setf (gfug:background-color gc) gfug:+color-white+) (setf (gfug:foreground-color gc) gfug:+color-blue+) - (gfug:draw-text gc *text* (gfid:make-point))) + (let* ((sz (gfuw:client-size *event-tester-window*)) + (pnt (gfid:make-point :x 0 :y (floor (/ (gfid:size-height sz) 2))))) + (gfug:draw-text gc *event-tester-text* pnt))) (defmethod gfuw:event-close ((d event-tester-window-events) time) (declare (ignore time)) @@ -90,10 +92,11 @@ time (text-for-modifiers))) -(defun text-for-menu (text time) +(defun text-for-item (text time desc) (format nil - "~a menu: ~s time: 0x~x ~s" + "~a ~s: ~s time: 0x~x ~s" (incf *event-counter*) + desc text time (text-for-modifiers))) @@ -118,39 +121,39 @@ (text-for-modifiers))) (defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char) - (setf *text* (text-for-key "down" time key-code char)) + (setf *event-tester-text* (text-for-key "down" time key-code char)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char) - (setf *text* (text-for-key "up" time key-code char)) + (setf *event-tester-text* (text-for-key "up" time key-code char)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "double" time button pnt)) + (setf *event-tester-text* (text-for-mouse "double" time button pnt)) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "down" time button pnt)) + (setf *event-tester-text* (text-for-mouse "down" time button pnt)) (setf *mouse-down-flag* t) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button) (when *mouse-down-flag* - (setf *text* (text-for-mouse "move" time button pnt)) + (setf *event-tester-text* (text-for-mouse "move" time button pnt)) (gfuw:redraw *event-tester-window*))) (defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button) - (setf *text* (text-for-mouse "up" time button pnt)) + (setf *event-tester-text* (text-for-mouse "up" time button pnt)) (setf *mouse-down-flag* nil) (gfuw:redraw *event-tester-window*)) (defmethod gfuw:event-move ((d event-tester-window-events) time pnt) - (setf *text* (text-for-move time pnt)) + (setf *event-tester-text* (text-for-move time pnt)) (gfuw:redraw *event-tester-window*) 0) (defmethod gfuw:event-resize ((d event-tester-window-events) time size type) - (setf *text* (text-for-size type time size)) + (setf *event-tester-text* (text-for-size type time size)) (gfuw:redraw *event-tester-window*) 0) @@ -160,32 +163,46 @@ (declare (ignorable time item rect)) (exit-event-tester)) -(defclass echo-menu-dispatcher (gfuw:event-dispatcher) ()) +(defmethod gfuw:event-arm ((d event-tester-exit-dispatcher) time item) + (declare (ignore rect)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) + (gfuw:redraw *event-tester-window*)) + +(defclass event-tester-echo-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d event-tester-echo-dispatcher) time item rect) + (declare (ignore rect)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item selected")) + (gfuw:redraw *event-tester-window*)) -(defmethod gfuw:event-select ((d echo-menu-dispatcher) time item rect) +(defmethod gfuw:event-arm ((d event-tester-echo-dispatcher) time item) (declare (ignore rect)) - (setf *text* (text-for-menu (gfuw:text item) time)) + (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed")) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-activate ((d event-tester-echo-dispatcher) time) + (setf *event-tester-text* (text-for-item "" time "menu activated")) (gfuw:redraw *event-tester-window*)) (defun run-event-tester-internal () - (setf *text* "Hello!") + (setf *event-tester-text* "Hello!") (setf *event-counter* 0) - (let ((echo-md (make-instance 'echo-menu-dispatcher)) + (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events))) (gfuw:realize *event-tester-window* nil :style-workspace) - (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (setf menubar (gfuw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md) (:menuitem "&Open..." :dispatcher ,echo-md) (:menuitem "&Save..." :disabled :dispatcher ,echo-md) (:menuitem :separator) (:menuitem "E&xit" :dispatcher ,exit-md)) - ((:menu "&Options") + ((:menu "&Options" :dispatcher ,echo-md) (:menuitem "&Enabled" :checked :dispatcher ,echo-md) (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md) (:menuitem "&Fonts" :dispatcher ,echo-md :disabled) (:menuitem "&Colors" :dispatcher ,echo-md)))) - ((:menu "&Help") + ((:menu "&Help" :dispatcher ,echo-md) (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) (setf (gfuw:menu-bar *event-tester-window*) menubar) (gfuw:show *event-tester-window*) Added: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Feb 7 22:50:33 2006 @@ -0,0 +1,103 @@ +;;;; +;;;; layout-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defconstant +btn-text-1+ "Push Me") +(defconstant +btn-text-2+ "Again!") + +(defparameter *layout-win* nil) + +(defun exit-layout-tester () + (let ((w *layout-win*)) + (setf *layout-win* nil) + (gfis:dispose w)) + (gfuw:shutdown 0)) + +(defclass fill-events (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-close ((d fill-events) time) + (declare (ignore time)) + (exit-layout-tester)) + +(defclass fill-btn-events (gfuw:event-dispatcher) + ((button + :accessor button + :initarg :button + :initform nil) + (toggle-fn + :accessor toggle-fn + :initform nil))) + +(defmethod gfuw:event-select ((d fill-btn-events) time item rect) + (declare (ignorable time rect)) + (let ((btn (button d))) + (setf (gfuw:text btn) (funcall (toggle-fn d))))) + +(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect) + (declare (ignorable time item rect)) + (exit-layout-tester)) + +(defun run-layout-tester-internal () + (let* ((menubar nil) + (md (make-instance 'fill-exit-dispatcher)) + (bd (make-instance 'fill-btn-events)) + (btn (make-instance 'gfuw:button :dispatcher bd))) + (setf (button bd) btn) + (setf (toggle-fn bd) (let ((flag nil)) + #'(lambda () + (if (null flag) + (progn + (setf flag t) + +btn-text-1+) + (progn + (setf flag nil) + +btn-text-2+))))) + (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events))) + (gfuw:realize *layout-win* nil :style-workspace) + (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150)) + (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (:menuitem "E&xit" :dispatcher ,md)) + ((:menu "&Children"))))) + (setf (gfuw:menu-bar *layout-win*) menubar) + (gfuw:realize btn *layout-win* :push-button) + (setf (gfuw:text btn) (funcall (toggle-fn bd))) + (setf (gfuw:location btn) (gfid:make-point)) + (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1)) + (gfuw:show *layout-win*) + (gfuw:run-default-message-loop))) + +(defun run-layout-tester () + (gfuw:startup "Layout Tester" #'run-layout-tester-internal)) Modified: trunk/src/uitoolkit/system/system-conditions.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-conditions.lisp (original) +++ trunk/src/uitoolkit/system/system-conditions.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; conditions.lisp +;;;; system-conditions.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; constants.lisp +;;;; system-constants.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -545,6 +545,10 @@ (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message (defconstant +wm-command+ #x0111) +(defconstant +wm-initmenu+ #x0116) +(defconstant +wm-initmenupopup+ #x0117) +(defconstant +wm-menuselect+ #x011F) +(defconstant +wm-menuchar+ #x0120) (defconstant +wm-mousefirst+ #x0200) ; for use with peek-message (defconstant +wm-mousemove+ #x0200) (defconstant +wm-lbuttondown+ #x0201) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; types.lisp +;;;; system-types.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Feb 7 22:50:33 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; utils.lisp +;;;; system-utils.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Tue Feb 7 22:50:33 2006 @@ -38,10 +38,10 @@ (:method (dispatcher time) (declare (ignorable dispatcher time)))) -(defgeneric event-arm (dispatcher time) +(defgeneric event-arm (dispatcher time item) (:documentation "Implement this to respond to an object about to be selected.") - (:method (dispatcher time) - (declare (ignorable dispatcher time)))) + (:method (dispatcher time item) + (declare (ignorable dispatcher time item)))) (defgeneric event-close (dispatcher time) (:documentation "Implement this to respond to an object being closed.") Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Feb 7 22:50:33 2006 @@ -131,7 +131,7 @@ (gfus::def-window-proc hwnd msg wparam lparam)) (defmethod process-message (hwnd (msg (eql gfus::+wm-close+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if w (event-close (dispatcher w) *last-event-time*) @@ -166,8 +166,26 @@ (error 'gfus:toolkit-error :detail "no object for hwnd"))) 0) +(defmethod process-message (hwnd (msg (eql gfus::+wm-initmenupopup+)) wparam lparam) + (declare (ignorable hwnd lparam)) + (let ((menu (get-widget (cffi:make-pointer wparam)))) + (unless (null menu) + (let ((d (dispatcher menu))) + (unless (null d) + (event-activate d *last-event-time*))))) + 0) + +(defmethod process-message (hwnd (msg (eql gfus::+wm-menuselect+)) wparam lparam) + (declare (ignorable hwnd lparam)) ; FIXME: handle system menus + (let ((item (get-menuitem (lo-word wparam)))) + (unless (null item) + (let ((d (dispatcher item))) + (unless (null d) + (event-arm d *last-event-time* item))))) + 0) + (defmethod process-message (hwnd (msg (eql gfus::+wm-create+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (get-widget hwnd) ; has side-effect of setting handle slot 0) @@ -240,7 +258,7 @@ (process-mouse-message #'event-mouse-move hwnd lparam btn-sym))) (defmethod process-message (hwnd (msg (eql gfus::+wm-move+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (when w (outer-location w *move-event-pnt*) @@ -248,14 +266,14 @@ 0) (defmethod process-message (hwnd (msg (eql gfus::+wm-moving+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-move (dispatcher w) *last-event-time*)) 1 0))) (defmethod process-message (hwnd (msg (eql gfus::+wm-paint+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd)) (gc (make-instance 'gfug:graphics-context))) (if w @@ -303,7 +321,7 @@ 0) (defmethod process-message (hwnd (msg (eql gfus::+wm-sizing+)) wparam lparam) - (declare (ignore wparam) (ignore lparam)) + (declare (ignorable wparam lparam)) (let ((w (get-widget hwnd))) (if (and w (event-pre-resize (dispatcher w) *last-event-time*)) 1 Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Feb 7 22:50:33 2006 @@ -398,7 +398,7 @@ (insert-separator (gfis:handle parent)))) (defmethod define-menu ((gen menu-generator) label dispatcher) - (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu))) + (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack gen))) (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher)) (id *next-menuitem-id*))

1 0

[graphic-forms-cvs] r2 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 07 Feb '06

07 Feb '06

Author: junrue Date: Tue Feb 7 11:42:35 2006 New Revision: 2 Added: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/tests.lisp Modified: trunk/build.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: upgraded to CFFI 0.9.0; started pulling in test code Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Feb 7 11:42:35 2006 @@ -1,10 +1,38 @@ ;;;; ;;;; build.lisp ;;;; -;;;; Copyright (c) 2006 by Jack D. Unrue +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; (defpackage #:graphic-forms-system + (:nicknames #:gfs) (:use :common-lisp :asdf)) (in-package #:graphic-forms-system) @@ -16,7 +44,7 @@ (defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) -(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-060114/")) +(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) (defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) (defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) (defvar *cldoc-dir* (concatenate 'string *asdf-root* "cldoc/")) @@ -25,7 +53,11 @@ (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") (defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) -(defvar *asdf-dirs* (list *cffi-dir* *pcl-ch08-dir* *pcl-ch24-dir* *cldoc-dir* *gf-dir*)) +(defvar *asdf-dirs* (list *cffi-dir* + *pcl-ch08-dir* + *pcl-ch24-dir* + *cldoc-dir* + *gf-dir*)) (defvar *library-build-root* (concatenate 'string *library-root* "build/")) (defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) @@ -33,9 +65,11 @@ (defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) (defvar *cldoc-build-dir* (concatenate 'string *library-build-root* "cldoc/")) -(defvar *build-dirs* (list *cffi-build-dir* *pcl-ch08-build-dir* *pcl-ch24-build-dir* *cldoc-build-dir* *gf-build-dir*)) - -(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp")) +(defvar *build-dirs* (list *cffi-build-dir* + *pcl-ch08-build-dir* + *pcl-ch24-build-dir* + *cldoc-build-dir* + *gf-build-dir*)) #+lispworks (defmacro chdir (path) `(hcl:change-directory ,path)) @@ -43,7 +77,6 @@ `(ext:cd ,path)) (defun build () - (mapc #'(lambda (dir-str) (pushnew dir-str asdf:*central-registry* :test #'equal)) *asdf-dirs*) (when *external-build-dirs* (mapc #'(lambda (dir-str) (ensure-directories-exist (parse-namestring dir-str))) *build-dirs*)) @@ -65,11 +98,6 @@ (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) -;;; FIXME: define test package (and must :use #:lisp-unit) -;;; -(defun run-tests () - (load (compile-file *lisp-unit-srcfile*))) - ;;; FIXME: reference to :cldoc below can't be satisfied yet when ;;; this file is loaded #| Added: trunk/graphic-forms-tests.asd ============================================================================== --- (empty file) +++ trunk/graphic-forms-tests.asd Tue Feb 7 11:42:35 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; graphic-forms-tests.asd +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms-system) + +(print "Graphic-Forms UI Toolkit Tests") +(print "Copyright (c) 2006 by Jack D. Unrue") +(print " ") + +(defsystem graphic-forms-tests + :description "Graphic-Forms UI Toolkit Tests" + :version "0.2.0" + :author "Jack D. Unrue" + :licence "BSD" + :components + ((:module "src" + :components + ((:module "tests" + :components + ((:module "uitoolkit" + :components + ((:file "hello-world") + (:file "event-tester"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Feb 7 11:42:35 2006 @@ -451,6 +451,7 @@ #:show-selection #:shutdown #:size + #:startup #:step-increment #:style #:text Added: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Feb 7 11:42:35 2006 @@ -0,0 +1,195 @@ +;;;; +;;;; event-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defparameter *event-tester-window* nil) +(defparameter *text* "Hello!") +(defvar *event-counter* 0) +(defvar *mouse-down-flag* nil) + +(defun exit-event-tester () + (let ((w *event-tester-window*)) + (setf *event-tester-window* nil) + (gfis:dispose w)) + (gfuw:shutdown 0)) + +(defclass event-tester-window-events (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-paint ((d event-tester-window-events) time (gc gfug:graphics-context) rect) + (declare (ignore time) (ignore rect)) + (setf (gfug:background-color gc) gfug:+color-white+) + (setf (gfug:foreground-color gc) gfug:+color-blue+) + (gfug:draw-text gc *text* (gfid:make-point))) + +(defmethod gfuw:event-close ((d event-tester-window-events) time) + (declare (ignore time)) + (exit-event-tester)) + +(defun text-for-modifiers () + (format nil + "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" + (not (gfuw:key-down-p gfuw:+vk-shift+)) + (not (gfuw:key-down-p gfuw:+vk-control+)) + (not (gfuw:key-down-p gfuw:+vk-alt+)) + (not (gfuw:key-down-p gfuw:+vk-left-win+)) + (not (gfuw:key-down-p gfuw:+vk-right-win+)) + (not (gfuw:key-toggled-p gfuw:+vk-escape+)) + (not (gfuw:key-toggled-p gfuw:+vk-caps-lock+)) + (not (gfuw:key-toggled-p gfuw:+vk-num-lock+)) + (not (gfuw:key-toggled-p gfuw:+vk-scroll-lock+)))) + +(defun text-for-mouse (action time button pnt) + (format nil + "~a mouse action: ~s button: ~a point: (~d,~d) time: 0x~x ~s" + (incf *event-counter*) + action + button + (gfid:point-x pnt) + (gfid:point-y pnt) + time + (text-for-modifiers))) + +(defun text-for-key (action time key-code char) + (format nil + "~a key action: ~s char: ~s code: 0x~x time: 0x~x ~s" + (incf *event-counter*) + action + char + key-code + time + (text-for-modifiers))) + +(defun text-for-menu (text time) + (format nil + "~a menu: ~s time: 0x~x ~s" + (incf *event-counter*) + text + time + (text-for-modifiers))) + +(defun text-for-size (type time size) + (format nil + "~a resize action: ~s size: (~d,~d) time: 0x~x ~s" + (incf *event-counter*) + (symbol-name type) + (gfid:size-width size) + (gfid:size-height size) + time + (text-for-modifiers))) + +(defun text-for-move (time pnt) + (format nil + "~a move point: (~d,~d) time: 0x~x ~s" + (incf *event-counter*) + (gfid:point-x pnt) + (gfid:point-y pnt) + time + (text-for-modifiers))) + +(defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char) + (setf *text* (text-for-key "down" time key-code char)) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char) + (setf *text* (text-for-key "up" time key-code char)) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button) + (setf *text* (text-for-mouse "double" time button pnt)) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button) + (setf *text* (text-for-mouse "down" time button pnt)) + (setf *mouse-down-flag* t) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button) + (when *mouse-down-flag* + (setf *text* (text-for-mouse "move" time button pnt)) + (gfuw:redraw *event-tester-window*))) + +(defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button) + (setf *text* (text-for-mouse "up" time button pnt)) + (setf *mouse-down-flag* nil) + (gfuw:redraw *event-tester-window*)) + +(defmethod gfuw:event-move ((d event-tester-window-events) time pnt) + (setf *text* (text-for-move time pnt)) + (gfuw:redraw *event-tester-window*) + 0) + +(defmethod gfuw:event-resize ((d event-tester-window-events) time size type) + (setf *text* (text-for-size type time size)) + (gfuw:redraw *event-tester-window*) + 0) + +(defclass event-tester-exit-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d event-tester-exit-dispatcher) time item rect) + (declare (ignorable time item rect)) + (exit-event-tester)) + +(defclass echo-menu-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d echo-menu-dispatcher) time item rect) + (declare (ignore rect)) + (setf *text* (text-for-menu (gfuw:text item) time)) + (gfuw:redraw *event-tester-window*)) + +(defun run-event-tester-internal () + (setf *text* "Hello!") + (setf *event-counter* 0) + (let ((echo-md (make-instance 'echo-menu-dispatcher)) + (exit-md (make-instance 'event-tester-exit-dispatcher)) + (menubar nil)) + (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events))) + (gfuw:realize *event-tester-window* nil :style-workspace) + (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (:menuitem "&Open..." :dispatcher ,echo-md) + (:menuitem "&Save..." :disabled :dispatcher ,echo-md) + (:menuitem :separator) + (:menuitem "E&xit" :dispatcher ,exit-md)) + ((:menu "&Options") + (:menuitem "&Enabled" :checked :dispatcher ,echo-md) + (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md) + (:menuitem "&Fonts" :dispatcher ,echo-md :disabled) + (:menuitem "&Colors" :dispatcher ,echo-md)))) + ((:menu "&Help") + (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp"))))) + (setf (gfuw:menu-bar *event-tester-window*) menubar) + (gfuw:show *event-tester-window*) + (gfuw:run-default-message-loop))) + +(defun run-event-tester () + (gfuw:startup "Event Tester" #'run-event-tester-internal)) Added: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/hello-world.lisp Tue Feb 7 11:42:35 2006 @@ -0,0 +1,75 @@ +;;;; +;;;; hello-world.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defparameter *hellowin* nil) + +(defun exit-hello-world () + (let ((w *hellowin*)) + (setf *hellowin* nil) + (gfis:dispose w)) + (gfuw:shutdown 0)) + +(defclass hellowin-events (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-close ((d hellowin-events) time) + (declare (ignore time)) + (format t "hellowin-events event-close~%") + (exit-hello-world)) + +(defmethod gfuw:event-paint ((d hellowin-events) time (gc gfug:graphics-context) rect) + (declare (ignore time) (ignore rect)) + (setf (gfug:background-color gc) gfug:+color-red+) + (setf (gfug:foreground-color gc) gfug:+color-green+) + (gfug:draw-text gc "Hello World!" (gfid:make-point))) + +(defclass hellowin-exit-dispatcher (gfuw:event-dispatcher) ()) + +(defmethod gfuw:event-select ((d hellowin-exit-dispatcher) time item rect) + (declare (ignorable time item rect)) + (exit-hello-world)) + +(defun run-hello-world-internal () + (let ((menubar nil) + (md (make-instance 'hellowin-exit-dispatcher))) + (setf *hellowin* (make-instance 'gfuw:window :dispatcher (make-instance 'hellowin-events))) + (gfuw:realize *hellowin* nil :style-workspace) + (setf menubar (gfuw:defmenusystem `(((:menu "&File") + (:menuitem "E&xit" :dispatcher ,md))))) + (setf (gfuw:menu-bar *hellowin*) menubar) + (gfuw:show *hellowin*) + (gfuw:run-default-message-loop))) + +(defun run-hello-world () + (gfuw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Feb 7 11:42:35 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; utils.lisp +;;;; widget-utils.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -31,7 +31,19 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; -(in-package :graphic-forms.uitoolkit.widgets) +(in-package #:graphic-forms.uitoolkit.widgets) + +#+clisp (defun startup (thread-name start-fn) + (declare (ignore thread-name)) + (funcall start-fn)) + +#+lispworks (defun startup (thread-name start-fn) + (when (null (mp:list-all-processes)) + (mp:initialize-multiprocessing)) + (mp:process-run-function thread-name nil start-fn)) + +(defun shutdown (exit-code) + (gfus::post-quit-message exit-code)) (defun create-window (class-name title parent-hwnd std-style ex-style) (cffi:with-foreign-string (cname-ptr class-name) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Feb 7 11:42:35 2006 @@ -145,10 +145,3 @@ (defun remove-widget (hwnd) (when (not *widget-in-progress*) (remhash (cffi:pointer-address hwnd) *widgets-by-hwnd*))) - -;;; -;;; miscellaneous -;;; - -(defun shutdown (exit-code) - (gfus::post-quit-message exit-code)) Added: trunk/tests.lisp ============================================================================== --- (empty file) +++ trunk/tests.lisp Tue Feb 7 11:42:35 2006 @@ -0,0 +1,47 @@ +;;;; +;;;; tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms-system) + +(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp")) + +(load (compile-file *lisp-unit-srcfile*)) + +(defpackage #:graphic-forms.uitoolkit.tests + (:nicknames #:gft) + (:use :common-lisp :lisp-unit)) + +(defun load-adhoc-tests () + (if *external-build-dirs* + (chdir *gf-build-dir*)) + (asdf:operate 'asdf:load-op :graphic-forms-tests))

1 0