[graphic-forms-cvs] r24 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Fri Mar  3 17:27:21 2006
New Revision: 24

Modified:
   trunk/src/uitoolkit/widgets/menu-language.lisp
Log:
 

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Fri Mar  3 17:27:21 2006
@@ -53,7 +53,9 @@
 ;;;
 
 (defclass base-menu-generator ()
-  ((menu-stack :accessor menu-stack-of
+  ((commands   :accessor commands-of
+               :initform nil)
+   (menu-stack :accessor menu-stack-of
                :initform nil)))
 
 (defgeneric define-item (generator label dispatcher disabled checked image)
@@ -61,10 +63,10 @@
   (:method (generator label dispatcher disabled checked image)
     (declare (ignorable generator label dispatcher disabled checked image))))
 
-(defgeneric define-submenu (generator label body dispatcher disabled)
+(defgeneric define-submenu (generator label dispatcher disabled)
   (:documentation "Defines a submenu and its associated item on the parent menu.")
-  (:method (generator label body dispatcher disabled)
-    (declare (ignorable generator label body dispatcher disabled))))
+  (:method (generator label dispatcher disabled)
+    (declare (ignorable generator label dispatcher disabled))))
 
 (defgeneric define-separator (generator)
   (:documentation "Defines a separator.")
@@ -144,14 +146,17 @@
       (if (or checked image sep (not (listp sub)))
         (error 'gfs:toolkit-error :detail "invalid option for submenu")))
     (cond
-      (sep `(define-separator ,generator))
-      (sub `(define-submenu ,generator ,label ,sub ,disp ,disabled))
-      (t `(define-item ,generator ,label ,disp ,disabled ,checked ,image)))))
-
-#|
-    (mapcar #'(lambda (var) (process-item-form gen var)) body)
-    (complete-submenu gen)))
-|#
+      (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
@@ -159,7 +164,8 @@
 
 (defun interp-menusystem (sexp)
   (let ((gen (make-instance 'base-menu-generator)))
-    (mapcar #'(lambda (var) (process-item-form gen var)) sexp)))
+    (mapcar #'(lambda (var) (process-item-form gen var)) sexp)
+    (commands-of gen)))
 
 ;;;
 ;;; the real generator
@@ -187,7 +193,7 @@
     (setf (slot-value it 'gfi:handle) hmenu)
     (vector-push-extend it (items owner))))
 
-(defmethod define-submenu ((gen win32-menu-generator) label body dispatcher disabled)
+(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
   (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
          (parent (first (menu-stack-of gen)))
          (item (append-submenu parent label submenu)))
@@ -200,4 +206,5 @@
 (defmacro defmenusystem (sexp)
   (let ((gen (gensym)))
     `(let ((,gen (make-instance 'win32-menu-generator)))
-       ,@(loop for form in sexp append (process-item-form gen form)))))
+       (loop for form in sexp do (process-item-form gen form))
+       ,@(commands-of ,gen))))