[mcclim-cvs] CVS update: mcclim/builtin-commands.lisp mcclim/commands.lisp

[Timothy Moore]

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)