Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20066
Modified Files: menu.lisp decls.lisp commands.lisp Log Message: Moved `display-command-table-menu' to menu.lisp and implemented `display-command-menu'.
--- /project/mcclim/cvsroot/mcclim/menu.lisp 2006/05/13 00:19:36 1.36 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2006/12/14 19:43:51 1.37 @@ -415,3 +415,43 @@ (- real-height 4))) (incf x width) (incf x x-spacing))))) + +(defmethod display-command-table-menu ((command-table standard-command-table) + (stream fundamental-output-stream) + &rest args + &key max-width max-height n-rows n-columns + x-spacing y-spacing initial-spacing + row-wise (cell-align-x :left) + (cell-align-y :top) (move-cursor t)) + (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows + :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing + :initial-spacing initial-spacing :row-wise row-wise + :move-cursor move-cursor) + (map-over-command-table-menu-items + #'(lambda (item-name accelerator item) + (declare (ignore accelerator)) + (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) + (cond ((eq (command-menu-item-type item) :menu) + (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) + (write-string item-name stream) + (terpri stream)) + (surrounding-output-with-border (stream) + (apply #'display-command-table-menu + (find-command-table (command-menu-item-value item)) + stream args))) + ((eq (command-menu-item-type item) :command) + (let ((name (command-name (command-menu-item-value item)))) + (when (command-line-name-for-command name command-table :errorp nil) + (present name 'command-name :stream stream))))))) + command-table))) + +(defmethod display-command-menu (frame (stream fundamental-output-stream) + &rest args &key + (command-table (frame-command-table frame)) + initial-spacing row-wise max-width + max-height n-rows n-columns + (cell-align-x :left) (cell-align-y :top)) + (declare (ignore initial-spacing row-wise max-width max-height + n-rows n-columns cell-align-x cell-align-y)) + (with-keywords-removed (args (:command-table)) + (apply #'display-command-table-menu command-table stream args))) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/13 22:31:57 1.44 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/14 19:43:51 1.45 @@ -659,6 +659,18 @@ (defgeneric run-frame-top-level (frame &key &allow-other-keys)) (defgeneric command-enabled (command-name frame)) (defgeneric (setf command-name) (enabled command-name frame)) +(defgeneric display-command-menu (frame stream &key command-table + initial-spacing row-wise max-width + max-height n-rows n-columns + cell-align-x cell-align-y) + (:documentation "Display the command table associated with +`command-table' on `stream' by calling +`display-command-table-menu'. If no command table is +provided, (frame-command-table frame) will be used. + +The arguments `initial-spacing', `row-wise', +`max-width', `max-height', `n-rows', `n-columns', `cell-align-x', +and `cell-align-y' are as for `formatting-item-list'."))
;;;; 28.5.2 Frame Manager Operations
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/13 22:30:31 1.66 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/14 19:43:51 1.67 @@ -541,35 +541,6 @@ gesture)) gesture)))
-(defmethod display-command-table-menu ((command-table standard-command-table) - (stream fundamental-output-stream) - &rest args - &key max-width max-height n-rows n-columns - x-spacing y-spacing initial-spacing - row-wise (cell-align-x :left) - (cell-align-y :top) (move-cursor t)) - (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows - :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing - :initial-spacing initial-spacing :row-wise row-wise - :move-cursor move-cursor) - (map-over-command-table-menu-items - #'(lambda (item-name accelerator item) - (declare (ignore accelerator)) - (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) - (cond ((eq (command-menu-item-type item) :menu) - (with-text-style (stream (make-text-style :serif '(:bold :italic) nil)) - (write-string item-name stream) - (terpri stream)) - (surrounding-output-with-border (stream) - (apply #'display-command-table-menu - (find-command-table (command-menu-item-value item)) - stream args))) - ((eq (command-menu-item-type item) :command) - (let ((name (command-name (command-menu-item-value item)))) - (when (command-line-name-for-command name command-table :errorp nil) - (present name 'command-name :stream stream))))))) - command-table))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commands