graphic-forms-cvs

Download

graphic-forms-cvs@common-lisp.net

July 2007

1 participants
2 discussions

[graphic-forms-cvs] r469 - trunk/src/tests/uitoolkit
by junrue＠common-lisp.net 09 Jul '07

09 Jul '07

Author: junrue Date: Mon Jul 9 00:17:21 2007 New Revision: 469 Modified: trunk/src/tests/uitoolkit/event-tester.lisp Log: revised event-tester menu creation to test GFW:DEFMENU2 and GFW:MAKE-MENU 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:17:21 2007 @@ -289,22 +289,24 @@ (setf *event-counter* 0) (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) - (menubar nil)) + (menu-factory nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) (initialize-scrollbars) - (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu - :submenu ((:item "Timer" :callback #'manage-timer) - (:item "" :separator) - (:item "E&xit" :dispatcher exit-md))) - (:item "&Test Menu" :dispatcher echo-md - :submenu ((:item "&Checked Item" :checked :dispatcher echo-md) - (:item "&Submenu" :dispatcher echo-md - :submenu ((:item "&Item A" :dispatcher echo-md :disabled) - (:item "&Item B" :dispatcher echo-md))))) - (:item "&Help" :dispatcher echo-md - :submenu ((:item "&About" :dispatcher echo-md)))))) - (setf (gfw:menu-bar *event-tester-window*) menubar) + (setf menu-factory + (gfw:defmenu2 :name 'event-tester-menu + :menu ((:item "&File" :callback #'manage-file-menu + :submenu ((:item "Timer" :callback #'manage-timer) + (:item "" :separator) + (:item "E&xit" :dispatcher exit-md))) + (:item "&Test Menu" :dispatcher echo-md + :submenu ((:item "&Checked Item" :checked :dispatcher echo-md) + (:item "&Submenu" :dispatcher echo-md + :submenu ((:item "&Item A" :dispatcher echo-md :disabled) + (:item "&Item B" :dispatcher echo-md))))) + (:item "&Help" :dispatcher echo-md + :submenu ((:item "&About" :dispatcher echo-md)))))) + (setf (gfw:menu-bar *event-tester-window*) (gfw:make-menu 'event-tester-menu)) (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *event-tester-window* t)))

1 0

[graphic-forms-cvs] r468 - in trunk: . docs/manual docs/website src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '07

09 Jul '07

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

1 0