Index: commands.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/commands.lisp,v retrieving revision 1.63 diff -a -u -r1.63 commands.lisp --- commands.lisp 12 May 2006 10:24:32 -0000 1.63 +++ commands.lisp 18 Jan 2007 11:48:04 -0000 @@ -159,32 +159,68 @@ :inherit-from nil :menu nil)) -; adjusted to allow anonymous command-tables for menu-bars -(defun make-command-table (name &key inherit-from menu (errorp t)) - (unless inherit-from - (setq inherit-from '(global-command-table))) +;;; (defun make-new-menu-for-command-table (menu inherit-menu inherit-from) +;;; (format *trace-output* "~& ~a ~a ~a" menu inherit-menu inherit-from) +;;; (force-output *trace-output*) +;;; (let ((new-menu +;;; (append (menu-items-from-list menu) +;;; (when inherit-menu +;;; (mapcan (lambda (command-table-designator) +;;; (format *trace-output* "~&fo: ~a " command-table-designator) +;;; (force-output *trace-output*) +;;; (slot-value +;;; (if (command-table-p command-table-designator) +;;; command-table-designator +;;; (find-command-table command-table-designator)) +;;; 'menu)) +;;; inherit-from)))) +;;; ) +;;; (format *trace-output* "~& ~a" new-menu) (force-output *trace-output*) +;;; new-menu)) + +(defun make-new-menu-for-command-table (menu inherit-menu inherit-from) + (apply #'append (menu-items-from-list menu) + (when inherit-menu + (mapcar (lambda (command-table-designator) + (slot-value + (if (command-table-p command-table-designator) + command-table-designator + (find-command-table command-table-designator)) + 'menu)) + inherit-from)))) + +;;; adjusted to allow anonymous command-tables for menu-bars +(defun make-command-table (name &key inherit-from menu inherit-menu (errorp t)) +;;; No! 27.2 says: "Creates a command table named name. inherit-from, +;;; menu, and inherit-menu are the same as for define-command-table. +;;; make-command-table does not implicitly include CLIM's global +;;; command table in the inheritance list for the new command table." +;;; (unless inherit-from +;;; (setq inherit-from '(global-command-table))) (if (and name errorp (gethash name *command-tables*)) (error 'command-table-already-exists) - (let ((result (make-instance 'standard-command-table :name name + (let* ((result (make-instance 'standard-command-table :name name :inherit-from inherit-from - :menu (menu-items-from-list menu)))) + :menu (make-new-menu-for-command-table menu inherit-menu inherit-from)))) (when name (setf (gethash name *command-tables*) result)) result))) (make-command-table 'user-command-table) -(defmacro define-command-table (name &key inherit-from menu) +(defmacro define-command-table (name &key inherit-from menu inherit-menu) `(let ((old-table (gethash ',name *command-tables* nil)) (inherit-from-arg (or ',inherit-from '(global-command-table)))) (if old-table (with-slots (inherit-from menu) old-table (setq inherit-from inherit-from-arg - menu (menu-items-from-list ',menu)) + menu (make-new-menu-for-command-table ',menu ',inherit-menu ',inherit-from)) + ;;(menu-items-from-list ',menu)) old-table) (make-command-table ',name :inherit-from inherit-from-arg :menu ',menu + :inherit-menu ',inherit-menu :errorp nil)))) (defun remove-command-from-command-table (command-name @@ -273,6 +309,48 @@ (apply-with-command-table-inheritance #'map-func command-table) (map-func command-table))))) +(defun map-over-command-table-translators (function command-table + &key (inherited t)) + (let ((command-table (find-command-table command-table))) + (flet ((map-func (table) + (maphash #'(lambda (key val) + (declare (ignore val)) + (funcall function key)) + (slot-value table 'presentation-translators)))) + (if inherited + (apply-with-command-table-inheritance #'map-func command-table) + (map-func command-table))))) + +(defun remove-presentation-translator-from-command-table (name command-table &key (errorp t)) + (let* ((table (find-command-table command-table)) + (item (gethash name (translators (presentation-translators table))))) + (if (null item) + (when errorp + (error 'command-not-present)) + (progn + (when (typep item 'menu-item) + (remove-menu-item-from-command-table table + (command-menu-item-name item) + :errorp nil) + + (when (command-item-name item) + (remhash (command-item-name item) (command-line-names table))) + (remhash command-name (commands table))))))) + +(define-condition presentation-translator-not-found (command-table-error) + ()) + +(defun add-presentation-translator-to-command-table (command-table translator-name &key (errorp t) + source-command-table) + (let ((translator (find-presentation-translator translator-name source-command-table :errorp nil))) + (when (not translator) + (error 'presentation-translator-not-found)) + (when (and errorp (find-presentation-translator translator-name command-table :errorp nil)) + (error 'command-already-present)) + (remove-presentation-translator-from-command-table command-table translator-name :errorp nil) + (add-translator (presentation-translators (find-command-table command-table)) + translator))) + (defun map-over-command-table-names (function command-table &key (inherited t)) (let ((command-table (find-command-table command-table))) (flet ((map-func (table) @@ -306,6 +384,17 @@ (if errorp (error 'command-not-accessible))) +(defun find-presentation-translator (name command-table &key (errorp t)) + (apply-with-command-table-inheritance + #'(lambda (table) + (let ((value (gethash name (translators (presentation-translators table))))) + (when value + (return-from find-presentation-translator + (values value table))))) + (find-command-table command-table)) + (if errorp + (error 'command-not-accessible))) + (defun command-line-name-for-command (command-name command-table &key (errorp t)) (do-command-table-inheritance (table command-table) @@ -767,6 +856,9 @@ (when still-missing (format ,stream "~&Please supply all arguments."))) +;;; (print (list ,@original-args) *trace-output*) +;;; (print (list ,@required-arg-names) *trace-output*) +;;; (force-output *trace-output*) (setf ,partial-command (list ,command-name ,@required-arg-names)) (unless (partial-command-p ,partial-command) (return ,partial-command))))))))))