Author: junrue Date: Mon Apr 24 12:19:53 2006 New Revision: 104 Added: trunk/src/uitoolkit/widgets/dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: reverted widget-with-items back to storing items as a vector; fixed a bug introduced in print-object for widgets Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Apr 24 12:19:53 2006 @@ -246,9 +246,9 @@ overwrite when an existing file is selected @end itemize Applications retrieve selected files by calling the @code{items} -function, which returns a list of @sc{file namestring}s, one for each -selection. Unless the @code{:multiple-select} style keyword is -specified, there will at most be one selected file returned, and +function, which returns a @sc{vector} of @sc{file namestring}s, one +for each selection. Unless the @code{:multiple-select} style keyword +is specified, there will at most be one selected file returned, and possibly zero if the user cancelled the dialog.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 12:19:53 2006 @@ -109,6 +109,7 @@ (:file "root-window") (:file "top-level") (:file "panel") + (:file "dialog") (:file "file-dialog") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Apr 24 12:19:53 2006 @@ -69,3 +69,9 @@ (declare (ignorable width-hint height-hint)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) + +(defmethod print-object ((self control) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) Added: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/dialog.lisp Mon Apr 24 12:19:53 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; dialog.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) + +;;; +;;; methods +;;; + +(defmethod print-object ((self dialog) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Apr 24 12:19:53 2006 @@ -208,7 +208,7 @@ (put-menuitem (thread-context) it) (insert-separator hmenu) (setf (slot-value it 'gfs:handle) hmenu) - (push it (items owner)))) + (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 12:19:53 2006 @@ -139,7 +139,7 @@ (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) (put-menuitem tc item) - (push item (items owner)) + (vector-push-extend item (items owner)) item)) (defmethod append-submenu ((parent menu) text (submenu menu) disp) @@ -153,7 +153,7 @@ (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) - (push item (items parent)) + (vector-push-extend item (items parent)) (put-widget tc submenu) (cond ((null disp)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 12:19:53 2006 @@ -77,7 +77,8 @@ (defclass widget-with-items (widget) ((items :accessor items - :initform nil)) + ;; 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 sub-items.")) (defclass dialog (widget-with-items) () 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 Apr 24 12:19:53 2006 @@ -46,7 +46,7 @@ (defmethod clear-item ((w widget-with-items) index) (let* ((items (items w)) (it (elt items index))) - (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items)) + (delete it (items w) :test #'items-equal-p) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Apr 24 12:19:53 2006 @@ -236,8 +236,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "client size: ~a" (size self)))) + (format stream "dispatcher: ~a " (dispatcher self)))) (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Apr 24 12:19:53 2006 @@ -205,6 +205,12 @@ (compute-outer-size win new-client-sz)) (size win)))) +(defmethod print-object ((self window) stream) + (print-unreadable-object (self stream :type t) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a " (dispatcher self)) + (format stream "size: ~a" (size self)))) + (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method)