[graphic-forms-cvs] r104 - in trunk: . docs/manual src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Apr 24 16:19:54 UTC 2006
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)
More information about the Graphic-forms-cvs
mailing list