[graphic-forms-cvs] r25 - in trunk: . src/tests/uitoolkit src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sat Mar  4 02:13:10 2006
New Revision: 25

Modified:
   trunk/graphic-forms-tests.asd
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/uitoolkit/widgets/menu-language.lisp
Log:
more menu system rewrite fixes

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Sat Mar  4 02:13:10 2006
@@ -49,9 +49,9 @@
               :components
                 ((:module "uitoolkit"
                   :components
-                    ((:file "hello-world")))))))))
+                    ((:file "hello-world")
+                     (:file "event-tester")))))))))
 #|
-                    ((:file "event-tester")
                      (:file "hello-world")))))))))
                      (:file "layout-tester"))
 |#

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sat Mar  4 02:13:10 2006
@@ -195,7 +195,7 @@
     (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md
                                                      :submenu ((:item "&Open..." :dispatcher echo-md)
                                                                (:item "&Save..." :disabled :dispatcher echo-md)
-                                                               (:item :separator)
+                                                               (:item "" :separator)
                                                                (:item "E&xit" :dispatcher exit-md)))
                                       (:item "&Options" :dispatcher echo-md
                                                         :submenu ((:item "&Enabled" :checked :dispatcher echo-md)

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Sat Mar  4 02:13:10 2006
@@ -53,9 +53,7 @@
 ;;;
 
 (defclass base-menu-generator ()
-  ((commands   :accessor commands-of
-               :initform nil)
-   (menu-stack :accessor menu-stack-of
+  ((menu-stack :accessor menu-stack-of
                :initform nil)))
 
 (defgeneric define-item (generator label dispatcher disabled checked image)
@@ -78,19 +76,15 @@
   (:method (generator)
     (declare (ignorable generator))))
 
-;;; borrowed from Practical Common Lisp, pg. 433
-;;;
-(defun self-evaluating-p (form)
-  (and (atom form) (if (symbolp form) (keywordp form) t)))
-
 (defun item-form-p (form)
   (and (consp form)
        (eq (car form) :item)))
 
-(defun process-item-form (generator form)
+(defun process-item-form (form generator-sym)
   (if (not (item-form-p form))
     (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form)))
-  (let ((checked nil)
+  (let ((cmds nil)
+        (checked nil)
         (disabled nil)
         (disp nil)
         (image nil)
@@ -105,7 +99,7 @@
                ((not (null disp-tmp))
                   (setf disp opt)
                   (setf disp-tmp nil))
-               ((not (null image-tmp))
+                 ((not (null image-tmp))
                   (setf image opt)
                   (setf image-tmp nil))
                ((not (null sub-tmp))
@@ -141,35 +135,33 @@
       (if sep
         (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))
       (if (null disp)
-        (error 'gfs:toolkit-error :detail "missing dispatcher function")))
+        (error 'gfs:toolkit-error :detail "missing dispatcher argument")))
     (when sub
       (if (or checked image sep (not (listp sub)))
         (error 'gfs:toolkit-error :detail "invalid option for submenu")))
     (cond
-      (sep (push (commands-of generator) `(define-separator ,generator)))
-      (sub (push (commands-of generator) `(define-submenu ,generator
-                                                          ,label
-                                                          ,disp
-                                                          ,disabled)))
-      (t (push (commands-of generator) `(define-item ,generator
-                                                     ,label
-                                                     ,disp
-                                                     ,disabled
-                                                     ,checked
-                                                     ,image))))))
-
-;;;
-;;; interpreter for debugging
-;;;
-
-(defun interp-menusystem (sexp)
-  (let ((gen (make-instance 'base-menu-generator)))
-    (mapcar #'(lambda (var) (process-item-form gen var)) sexp)
-    (commands-of gen)))
-
-;;;
-;;; the real generator
-;;;
+      (sep (push `(define-separator ,generator-sym) cmds))
+      (sub (push `(define-submenu ,generator-sym
+                                  ,label
+                                  ,disp
+                                  ,disabled) cmds)
+                  (loop for subform in sub
+                        do (setf cmds (append (process-item-form subform generator-sym) cmds)))
+           (push `(complete-submenu ,generator-sym) cmds))
+      (t (push `(define-item ,generator-sym
+                             ,label
+                             ,disp
+                             ,disabled
+                             ,checked
+                             ,image) cmds)))
+    cmds))
+
+(defun generate-menusystem-code (sexp generator-sym)
+  (let ((cmds nil))
+    (mapcar #'(lambda (var)
+                (setf cmds (append (process-item-form var generator-sym) cmds)))
+            sexp)
+    (reverse cmds)))
 
 (defclass win32-menu-generator (base-menu-generator) ())
 
@@ -204,7 +196,8 @@
   (pop (menu-stack-of gen)))
 
 (defmacro defmenusystem (sexp)
-  (let ((gen (gensym)))
+  (let* ((gen (gensym))
+         (cmds (generate-menusystem-code sexp gen)))
     `(let ((,gen (make-instance 'win32-menu-generator)))
-       (loop for form in sexp do (process-item-form gen form))
-       ,@(commands-of ,gen))))
+       , at cmds
+       (pop (menu-stack-of ,gen)))))