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))