[graphic-forms-cvs] r468 - in trunk: . docs/manual docs/website src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jul 9 04:15:26 UTC 2007
Author: junrue
Date: Mon Jul 9 00:15:15 2007
New Revision: 468
Added:
trunk/src/uitoolkit/widgets/defmenu.lisp
- copied, changed from r433, trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/defwindow.lisp
Removed:
trunk/src/uitoolkit/widgets/menu-language.lisp
Modified:
trunk/NEWS.txt
trunk/README.txt
trunk/docs/manual/clhs-table.xml
trunk/docs/manual/gfw-function-symbols.xml
trunk/docs/manual/gfw-macro-symbols.xml
trunk/docs/manual/introduction.xml
trunk/docs/website/index.html
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
Log:
added GFW:DEFMENU2 and GFW:MAKE-MENU, along with various bits of thread context infrastructure, and revised GFW:DEFMENU; updated docs
Modified: trunk/NEWS.txt
==============================================================================
--- trunk/NEWS.txt (original)
+++ trunk/NEWS.txt Mon Jul 9 00:15:15 2007
@@ -1,4 +1,7 @@
+. Added a new macro GFW:DEFMENU2 and associated function GFW:MAKE-MENU
+ to allow applications to create reusable menu factories.
+
. Latest CFFI is required to take advantage of built-in support for the
stdcall calling convention.
Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt (original)
+++ trunk/README.txt Mon Jul 9 00:15:15 2007
@@ -17,7 +17,7 @@
http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/
*note: ASDF is bundled with SBCL*
- - CFFI (cffi-061208 or later)
+ - CFFI (cffi-XXXXXX or later)
http://common-lisp.net/project/cffi/
- Closer to MOP
@@ -44,7 +44,7 @@
-------------------------------------
Graphic-Forms currently supports Allegro CL 8.0, CLISP 2.40 or higher,
-LispWorks 4.4.6, and SBCL 0.9.15 or higher (with a small patch).
+LispWorks 4.4.6, and SBCL 1.0.5 or higher (with a small patch).
Known Problems
Modified: trunk/docs/manual/clhs-table.xml
==============================================================================
--- trunk/docs/manual/clhs-table.xml (original)
+++ trunk/docs/manual/clhs-table.xml Mon Jul 9 00:15:15 2007
@@ -2,7 +2,7 @@
<!--
clhs-table.xml
- Copyright (c) 2006, Jack D. Unrue
+ Copyright (c) 2006-2007, Jack D. Unrue
-->
<clhs-table>
@@ -12,6 +12,7 @@
<entry name="error" url="http://www.lispworks.com/documentation/HyperSpec/Body/e_error.htm"/>
<entry name="float" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_float.htm"/>
<entry name="format" url="http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm"/>
+ <entry name="function" url="http://www.lispworks.com/reference/HyperSpec/Body/a_fn.htm"/>
<entry name="hash-table" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_hash_t.htm"/>
<entry name="integer" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm"/>
<entry name="list" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_list.htm"/>
Modified: trunk/docs/manual/gfw-function-symbols.xml
==============================================================================
--- trunk/docs/manual/gfw-function-symbols.xml (original)
+++ trunk/docs/manual/gfw-function-symbols.xml Mon Jul 9 00:15:15 2007
@@ -3880,4 +3880,28 @@
</seealso>
</slot-accessor>
+ <function name="make-menu">
+ <syntax>
+ <arguments>
+ <argument name="menu-name">
+ <description>
+ The <refclhs>symbol</refclhs> identifying a menu factory
+ function previously defined via <reftopic>gfw:defmenu2</reftopic>.
+ </description>
+ </argument>
+ </arguments>
+ <return>
+ <reftopic>gfw:menu</reftopic>
+ </return>
+ </syntax>
+ <description>
+ This function invokes the menu factory function identified by <arg0/>
+ to create a new native menu hierarchy.
+ </description>
+ <seealso>
+ <reftopic>gfw:defmenu</reftopic>
+ <reftopic>gfw:menu-bar</reftopic>
+ </seealso>
+ </function>
+
</symbols>
Modified: trunk/docs/manual/gfw-macro-symbols.xml
==============================================================================
--- trunk/docs/manual/gfw-macro-symbols.xml (original)
+++ trunk/docs/manual/gfw-macro-symbols.xml Mon Jul 9 00:15:15 2007
@@ -398,6 +398,49 @@
</description>
</macro>
+ <macro name="defmenu2">
+ <syntax>
+ <arguments>
+ <argument name=":name">
+ <description>
+ A <refclhs>symbol</refclhs> identifying the new menu factory.
+ </description>
+ </argument>
+ <notarg name="symbol"/>
+ <argument name=":menu">
+ <description>
+ Menu definition forms.
+ </description>
+ </argument>
+ <notarg name="("/>
+ <notarg name="forms"/>
+ <notarg name=")"/>
+ </arguments>
+ <return>
+ <refclhs>function</refclhs>
+ </return>
+ </syntax>
+ <description>
+ This macro defines a language for constructing menu hierarchies. For example:
+ <programlisting language="lisp">
+(gfw:defmenu2
+ :name 'test-menu
+ :menu ((:item "&File" :submenu ((:item "&Open...")
+ (:item "&Save..." :disabled)
+ (:item :separator)
+ (:item "E&xit" :callback #'some-fn)))
+ (:item "&Tools" :submenu ((:item "&Fonts" :disabled)
+ (:item "&Colors" :checked)))
+ (:item "&Help" :submenu ((:item "&About" :image some-image)))))
+ </programlisting>
+ </description>
+ <seealso>
+ <reftopic>gfw:menu-bar</reftopic>
+ <reftopic>gfw:make-menu</reftopic>
+ <reftopic>gfw:defmenu</reftopic>
+ </seealso>
+ </macro>
+
<macro name="defmenu">
<syntax>
<arguments>
@@ -417,17 +460,23 @@
This macro defines a language for constructing menu hierarchies. For example:
<programlisting language="lisp">
(gfw:defmenu
- ((:item "&File" :submenu ((:item "&Open...")
- (:item "&Save..." :disabled)
- (:item :separator)
- (:item "E&xit" :callback #'some-fn)))
+ ((:item "&File" :submenu ((:item "&Open...")
+ (:item "&Save..." :disabled)
+ (:item :separator)
+ (:item "E&xit" :callback #'some-fn)))
(:item "&Tools" :submenu ((:item "&Fonts" :disabled)
(:item "&Colors" :checked)))
- (:item "&Help" :submenu ((:item "&About" :image some-image)))))
+ (:item "&Help" :submenu ((:item "&About" :image some-image)))))
</programlisting>
+ Unlike <reftopic>gfw:defmenu2</reftopic>, this macro creates an anonymous
+ menu factory and then immediately invokes it, thus allowing the direct
+ construction of a menu hierarchy that can be immediately set on a window.
+ The factory function is then discarded.
</description>
<seealso>
<reftopic>gfw:menu-bar</reftopic>
+ <reftopic>gfw:make-menu</reftopic>
+ <reftopic>gfw:defmenu2</reftopic>
</seealso>
</macro>
Modified: trunk/docs/manual/introduction.xml
==============================================================================
--- trunk/docs/manual/introduction.xml (original)
+++ trunk/docs/manual/introduction.xml Mon Jul 9 00:15:15 2007
@@ -50,7 +50,7 @@
<listitem>CLISP 2.40 or later</listitem>
<listitem>LispWorks 4.4.6</listitem>
<listitem>
- SBCL 0.9.15 or later
+ SBCL 1.0.5 or later
<footnote>
<para role="small">
a small patch to enable the stdcall calling convention for callbacks
Modified: trunk/docs/website/index.html
==============================================================================
--- trunk/docs/website/index.html (original)
+++ trunk/docs/website/index.html Mon Jul 9 00:15:15 2007
@@ -50,7 +50,7 @@
<li><a href="http://franz.com/">Allegro CL 8.0</a> or later</li>
<li><a href="http://clisp.cons.org/">CLISP 2.40</a> or later</li>
<li><a href="http://www.lispworks.com/">LispWorks 5.0.1</a></li>
- <li><a href="http://www.sbcl.org/">SBCL 1.0.2</a> or later</li>
+ <li><a href="http://www.sbcl.org/">SBCL 1.0.5</a> or later</li>
</ul>
<h3 id="mailinglists">Mailing Lists</h3>
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Mon Jul 9 00:15:15 2007
@@ -142,7 +142,7 @@
(:file "list-box")
(:file "menu")
(:file "menu-item")
- (:file "menu-language")
+ (:file "defmenu")
(:file "progress-bar")
(:file "event")
(:file "scrolling-helper")
@@ -157,7 +157,8 @@
(:file "layout")
(:file "border-layout")
(:file "heap-layout")
- (:file "flow-layout")))))))))
+ (:file "flow-layout")
+ (:file "defwindow")))))))))
(defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit))))
(pushnew :graphic-forms *features*))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Jul 9 00:15:15 2007
@@ -442,6 +442,7 @@
#:default-message-filter
#:default-widget
#:defmenu
+ #:defmenu2
#:delay-of
#:delete-all
#:delete-item
@@ -524,6 +525,7 @@
#:location
#:lock
#:locked-p
+ #:make-menu
#:mapchildren
#:maximize
#:maximized-p
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Jul 9 00:15:15 2007
@@ -1,7 +1,7 @@
;;;;
;;;; event-tester.lisp
;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
Copied: trunk/src/uitoolkit/widgets/defmenu.lisp (from r433, trunk/src/uitoolkit/widgets/menu-language.lisp)
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/defmenu.lisp Mon Jul 9 00:15:15 2007
@@ -1,7 +1,7 @@
;;;;
-;;;; menu-language.lisp
+;;;; defmenu.lisp
;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
@@ -170,6 +170,8 @@
(defstruct menu-item-data text image)
(defun generate-menusystem-code (sexp generator-sym)
+ (if (null sexp)
+ (error 'gfs:toolkit-error :detail "a value for :MENU is required"))
(let ((code nil))
(mapcar #'(lambda (var)
(setf code (append (process-item-form var generator-sym) code)))
@@ -208,8 +210,28 @@
;;; top-level API for the menu language
;;;
+(defmacro defmenu2 (&key name menu)
+ (let ((gen (gensym))
+ (tmp-name (gensym)))
+ `(let ((,tmp-name ,name))
+ (if (get-menu-factory (thread-context) ,tmp-name)
+ (warn 'gfs:toolkit-warning
+ :detail (format nil "a menu with name ~S already exists" ,tmp-name)))
+ (put-menu-factory (thread-context)
+ ,tmp-name
+ (lambda ()
+ (let ((,gen (make-instance 'win32-menu-generator)))
+ ,@(generate-menusystem-code menu gen)
+ (pop (menu-stack-of ,gen))))))))
+
(defmacro defmenu (sexp)
- (let ((gen (gensym)))
- `(let ((,gen (make-instance 'win32-menu-generator)))
- ,@(generate-menusystem-code sexp gen)
- (pop (menu-stack-of ,gen)))))
+ `(funcall (defmenu2 :menu ,sexp)))
+
+(defun make-menu (menu-name)
+ (if (not (symbolp menu-name))
+ (error 'toolkit-error :detail "the menu name must be a symbol"))
+ (let ((menu-fn (get-menu-factory (thread-context) menu-name)))
+ (unless menu-fn
+ (error 'gfs:toolkit-error
+ :detail (format nil "~a does not identify any existing menu" menu-name)))
+ (funcall menu-fn)))
Added: trunk/src/uitoolkit/widgets/defwindow.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/defwindow.lisp Mon Jul 9 00:15:15 2007
@@ -0,0 +1,35 @@
+;;;;
+;;;; defwindow.lisp
+;;;;
+;;;; Copyright (C) 2007, 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)
+
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Jul 9 00:15:15 2007
@@ -58,6 +58,8 @@
(top-level-visitor-func :initform nil :accessor top-level-visitor-func)
(top-level-visitor-results :initform nil :accessor top-level-visitor-results)
(utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd)
+ (menu-factories :initform (make-hash-table :test #'eql))
+ (window-factories :initform (make-hash-table :test #'eql))
(widget-in-progress :initform nil :accessor widget-in-progress))
(:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
@@ -280,3 +282,27 @@
(event-wparam event) wparam
(event-lparam event) lparam)
event))
+
+(defun get-menu-factory (tc menu-name)
+ "Returns a function that creates a menu hierarchy based on a template defined via DEFMENU2."
+ (gethash menu-name (slot-value tc 'menu-factories)))
+
+(defun put-menu-factory (tc menu-name fn)
+ "Stores a function that creates a menu hierarchy based on a template defined via DEFMENU2."
+ (when menu-name
+ (if (not (symbolp menu-name))
+ (error 'gfs:toolkit-error :detail "the menu name must be a symbol"))
+ (setf (gethash menu-name (slot-value tc 'menu-factories)) fn))
+ fn)
+
+(defun get-window-factory (tc win-name)
+ "Returns a function that creates a window based on a template defined via DEFWINDOW."
+ (gethash win-name (slot-value tc 'window-factories)))
+
+(defun put-window-factory (tc win-name fn)
+ "Stores a function that creates a window based on a template defined via DEFWINDOW."
+ (when win-name
+ (if (not (symbolp win-name))
+ (error 'gfs:toolkit-error :detail "the window name must be a symbol"))
+ (setf (gethash win-name (slot-value tc 'win-factories)) fn))
+ fn)
More information about the Graphic-forms-cvs
mailing list