[mcclim-cvs] CVS mcclim

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv3621

Modified Files:
	commands.lisp 
Log Message:
Added some slightly more useful command-table errors.


--- /project/mcclim/cvsroot/mcclim/commands.lisp	2007/03/20 01:39:29	1.71
+++ /project/mcclim/cvsroot/mcclim/commands.lisp	2007/12/10 19:33:18	1.72
@@ -96,9 +96,23 @@
 (defparameter *command-tables* (make-hash-table :test #'eq))
 
 (define-condition command-table-error (simple-error)
-  ()
+  ((command-table-name :reader error-command-table-name
+                       :initform nil
+                       :initarg :command-table-name))
   (:default-initargs :format-control "" :format-arguments nil))
 
+(defmethod print-object ((object command-table-error) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (when (error-command-table-name object)
+      (princ (error-command-table-name object) stream))))
+
+(defun command-table-designator-as-name (designator)
+  "Return the name of `designator' if it is a command table,
+`designator' otherwise."
+  (if (typep designator 'standard-command-table)
+      (command-table-name designator)
+      designator))
+
 (define-condition command-table-not-found (command-table-error)
   ())
 
@@ -117,7 +131,7 @@
 (defun find-command-table (name &key (errorp t))
   (cond ((command-table-p name) name)
 	((gethash name *command-tables*))
-	(errorp (error 'command-table-not-found))
+	(errorp (error 'command-table-not-found :command-table-name name))
 	(t nil)))
 
 (define-presentation-method present (object (type command-table) stream
@@ -164,7 +178,7 @@
   (unless inherit-from
     (setq inherit-from '(global-command-table)))
   (if (and name errorp (gethash name *command-tables*))
-      (error 'command-table-already-exists)
+      (error 'command-table-already-exists :command-table-name name)
       (let ((result (make-instance 'standard-command-table :name name
 	                 :inherit-from inherit-from
 	                 :menu (menu-items-from-list menu))))
@@ -194,7 +208,7 @@
 	 (item (gethash command-name (commands table))))
     (if (null item)
 	(when errorp
-	  (error 'command-not-present))
+	  (error 'command-not-present :command-table-name (command-table-name command-table)))
 	(progn 
 	  (when (typep item '%menu-item)
 	    (remove-menu-item-from-command-table table
@@ -243,7 +257,7 @@
 				      :command-line-name name)))
 	     (after (getf menu-options :after)))
 	(when (and errorp (gethash command-name (commands table)))
-	  (error 'command-already-present))
+	  (error 'command-already-present :command-table-name command-table))
 	(remove-command-from-command-table command-name table :errorp nil)
 	(setf (gethash command-name (commands table)) item)
 	(when name
@@ -304,7 +318,7 @@
 	     (values value table)))))
    (find-command-table command-table))
   (if errorp
-      (error 'command-not-accessible)))
+      (error 'command-not-accessible :command-table-name command-table)))
 
 (defun command-line-name-for-command (command-name command-table
 				      &key (errorp t))
@@ -317,7 +331,8 @@
   (cond ((eq errorp :create)
 	 (command-name-from-symbol command-name))
 	(errorp
-	 (error 'command-not-accessible))
+	 (error 'command-not-accessible :command-table-name
+                (command-table-designator-as-name table)))
 	(t nil)))
 
 (defun find-menu-item (menu-name command-table &key (errorp t))
@@ -325,7 +340,8 @@
 	 (mem (member menu-name (slot-value table 'menu)
 		      :key #'command-menu-item-name :test #'string-equal)))
     (cond (mem (values (car mem) command-table))
-	  (errorp (error 'command-not-accessible))
+	  (errorp (error 'command-not-accessible :command-table-name
+                         (command-table-designator-as-name table)))
 	  (t nil))))
 
 (defun remove-menu-item-from-command-table (command-table string
@@ -334,7 +350,8 @@
 	(item (find-menu-item string command-table :errorp nil)))
     (with-slots (menu) table
       (if (and errorp (not item))
-	  (error 'command-not-present)
+	  (error 'command-not-present :command-table-name
+                 (command-table-designator-as-name table))
 	  (setf menu (delete string menu
 			     :key #'command-menu-item-name
 			     :test #'string-equal))))))
@@ -388,7 +405,8 @@
   (let* ((table (find-command-table command-table))
 	 (old-item (find-menu-item string command-table :errorp nil)))
     (cond ((and errorp old-item)
-	   (error 'command-already-present))
+	   (error 'command-already-present :command-table-name
+                  (command-table-designator-as-name table)))
 	  (old-item
 	   (remove-menu-item-from-command-table command-table string))
 	  (t nil))
@@ -417,7 +435,8 @@
                         (multiple-value-list (realize-gesture-spec :keyboard gesture))))
            (in-table (position gesture keystroke-accelerators :test #'equal)))
       (when (and in-table errorp)
-        (error 'command-already-present))
+        (error 'command-already-present :command-table-name
+               (command-table-designator-as-name table)))
       (if in-table
 	  (setf (nth in-table keystroke-items) item)
 	  (progn
@@ -454,7 +473,8 @@
 		  (setf (cdr accel-tail) (cddr accel-tail))
 		  (setf (cdr items-tail) (cddr items-tail))))
 	    (when errorp
-	      (error 'command-not-present))))))
+	      (error 'command-not-present :command-table-name
+                     (command-table-designator-as-name table)))))))
   nil)
 
 (defun map-over-command-table-keystrokes (function command-table)
@@ -478,7 +498,8 @@
 	  if (funcall test gesture keystroke)
 	  do (return-from find-keystroke-item (values item command-table)))
     (if errorp
-	(error 'command-not-present)
+	(error 'command-not-present :command-table-name
+               (command-table-designator-as-name table))
 	nil)))
 
 (defun lookup-keystroke-item (gesture command-table
@@ -504,7 +525,8 @@
 (defun partial-command-from-name (command-name)
   (let ((parser (gethash command-name *command-parser-table*)))
     (if (null parser)
-        (error 'command-not-present)
+        (error 'command-not-present :command-table-name
+               (command-table-designator-as-name table))
         (cons command-name
               (mapcar #'(lambda (foo)
                           (declare (ignore foo))