Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv22538

Modified Files: builtin-commands.lisp commands.lisp Log Message:

Fixed the Help command to not display duplicates i.e., commands accessible via more than one inherited command table.

Fixed a bug in command-line-name-for-command; it wasn't looking in inherited command tables.

Changed the presentation method for command-name to output the symbol if the command isn't accessable instead of pretending that nothing's wrong and creating a command line name.

Date: Wed Jun 22 13:41:35 2005 Author: tmoore

Index: mcclim/builtin-commands.lisp diff -u mcclim/builtin-commands.lisp:1.19 mcclim/builtin-commands.lisp:1.20 --- mcclim/builtin-commands.lisp:1.19 Wed Jun 22 11:49:15 2005 +++ mcclim/builtin-commands.lisp Wed Jun 22 13:41:34 2005 @@ -42,15 +42,18 @@ (push (cons name command) command-names)) command-table) + (setf command-names (remove-duplicates command-names :key #'cdr)) (setf command-names (sort command-names #'(lambda (a b) (string-lessp (car a) (car b))))) (formatting-item-list (*query-io*) - (loop for (nil . command) in command-names - do (progn - (formatting-cell (*query-io*) - (present command `(command-name :command-table ,command-table) - :stream *query-io*)))))))) + (loop + for (nil . command) in command-names + do (formatting-cell (*query-io*) + (present command + `(command-name :command-table ,command-table) + :stream *query-io*))))))) +

;;; Describe command. I don't know if this should go in the global command ;;; table, but we don't exactly have a surplus of commands yet...

Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.52 mcclim/commands.lisp:1.53 --- mcclim/commands.lisp:1.52 Wed Jun 22 11:49:15 2005 +++ mcclim/commands.lisp Wed Jun 22 13:41:35 2005 @@ -316,20 +316,17 @@

(defun command-line-name-for-command (command-name command-table &key (errorp t)) - (block exit ; save typing - (do-command-table-inheritance (table command-table) - (let* ((command-item (gethash command-name (slot-value table 'commands))) - (command-line-name (and command-item - (command-line-name command-item)))) - (cond ((stringp command-line-name) - (return-from exit command-line-name)) - ((eq errorp :create) - (return-from exit (command-name-from-symbol command-name))) - (errorp - (error 'command-not-accessible)) - (t nil)))) - nil)) - + (do-command-table-inheritance (table command-table) + (let* ((command-item (gethash command-name (slot-value table 'commands))) + (command-line-name (and command-item + (command-line-name command-item)))) + (when (stringp command-line-name) + (return-from command-line-name-for-command command-line-name)))) + (cond ((eq errorp :create) + (command-name-from-symbol command-name)) + (errorp + (error 'command-not-accessible)) + (t nil)))

(defun find-menu-item (menu-name command-table &key (errorp t)) (let* ((table (find-command-table command-table)) @@ -1081,11 +1078,13 @@ (define-presentation-method present (object (type command-name) stream (view textual-view) - &key acceptably for-context-type) + &key) (declare (ignore acceptably for-context-type)) - (princ (command-line-name-for-command object command-table :errorp :create) - stream)) - + (let ((command-line-name (command-line-name-for-command object command-table + :errorp nil))) + (if command-line-name + (write-string command-line-name stream) + (prin1 object stream))))

(define-presentation-method accept ((type command-name) stream (view textual-view)