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)))) + ,@cmds + (pop (menu-stack-of ,gen)))))