[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv19789

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp (compiler-warning-short-message): Add a method
for ccl::shadowed-typecase-clause.  Whithout that we only get
"Nonspecific warning".
(function-name-package): Factored out from frame-package.  Add
case for standard-method.

--- /project/slime/cvsroot/slime/ChangeLog	2013/01/07 10:12:08	1.2381
+++ /project/slime/cvsroot/slime/ChangeLog	2013/01/07 13:01:28	1.2382
@@ -1,5 +1,13 @@
 2013-01-07  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-ccl.lisp (compiler-warning-short-message): Add a method
+	for ccl::shadowed-typecase-clause.  Whithout that we only get
+	"Nonspecific warning".
+	(function-name-package): Factored out from frame-package.  Add
+	case for standard-method.
+
+2013-01-07  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-ecl.lisp (describe-symbol-for-emacs): Include bound
 	symbols even those without documentation.
 
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2013/01/05 08:50:24	1.30
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2013/01/07 13:01:28	1.31
@@ -180,6 +180,11 @@
   (with-output-to-string (stream)
     (ccl:report-compiler-warning c stream :short t)))
 
+;; Needed because `ccl:report-compiler-warning' would return
+;; "Nonspecific warning".
+(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
+  (princ-to-string c))
+
 (defimplementation call-with-compilation-hooks (function)
   (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
     (let ((ccl:*merge-compiler-warnings* nil))
@@ -407,19 +412,21 @@
         (pc-source-location lfun pc)
         (function-source-location lfun)))))
 
+(defun function-name-package (name)
+  (etypecase name
+    (null nil)
+    (symbol (symbol-package name))
+    ((cons (eql setf) symbol) (symbol-package (cadr name)))
+    ((cons (eql :internal)) (function-name-package (car (last name))))
+    ((cons (and symbol (not keyword)) (cons list null))
+     (symbol-package (car name)))
+    (standard-method (function-name-package (ccl:method-name name)))))
+
 (defimplementation frame-package (frame-number)
   (with-frame (p context) frame-number
     (let* ((lfun (ccl:frame-function p context))
            (name (ccl:function-name lfun)))
-      (labels ((name-package (name)
-                 (etypecase name
-                   (null nil)
-                   (symbol (symbol-package name))
-                   ((cons (eql setf) symbol) (symbol-package (cadr name)))
-                   ((cons (eql :internal)) (name-package (car (last name))))
-                   ((cons (and symbol (not keyword)) (cons list null))
-                    (symbol-package (car name))))))
-        (name-package name)))))
+      (function-name-package name))))
 
 (defimplementation eval-in-frame (form index)
   (with-frame (p context) index