[slime-cvs] CVS update: slime/swank-openmcl.lisp

[Marco Baringer]

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

Modified Files:
	swank-openmcl.lisp 
Log Message:
(specializer-name): New function.
(who-specializes): Use it.
(maybe-method-location): Use it.
(function-source-location): Use it.

Date: Mon Oct 25 18:18:28 2004
Author: mbaringer

Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.85 slime/swank-openmcl.lisp:1.86
--- slime/swank-openmcl.lisp:1.85	Fri Sep 17 14:51:07 2004
+++ slime/swank-openmcl.lisp	Mon Oct 25 18:18:27 2004
@@ -115,6 +115,12 @@
    openmcl-mop:slot-definition-readers
    openmcl-mop:slot-definition-writers))
 
+(defun specializer-name (spec)
+  (etypecase spec
+    (cons spec)
+    ((or swank-mop:standard-class built-in-class) (swank-mop:class-name spec))
+    (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec)))))
+
 ;;; TCP Server
 
 (defimplementation preferred-communication-style ()
@@ -314,7 +320,9 @@
                      (let ((location (function-source-location (ccl::method-function m))))
                        (if (eq (car location) :error)
                            (setq location nil ))
-                       `((method ,(ccl::method-name m) ,(mapcar 'class-name (ccl::method-specializers m)) ,@(ccl::method-qualifiers m))
+                       `((method ,(ccl::method-name m)
+                                 ,(mapcar #'specializer-name (ccl::method-specializers m))
+                                 ,@(ccl::method-qualifiers m))
                          ,location)))
                    (ccl::%class.direct-methods class))
            (mapcan 'who-specializes (ccl::%class-direct-subclasses class)))
@@ -519,7 +527,9 @@
 
 (defun maybe-method-location (type)
   (when (typep type 'ccl::method)
-    `((method ,(ccl::method-name type) ,(mapcar 'class-name (ccl::method-specializers type)) ,@(ccl::method-qualifiers type))
+    `((method ,(ccl::method-name type)
+              ,(mapcar #'specializer-name (ccl::method-specializers type))
+              ,@(ccl::method-qualifiers type))
       ,(function-source-location (ccl::method-function type)))))
 
 (defimplementation find-definitions (symbol)
@@ -538,7 +548,9 @@
            `(:location 
              (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
              (:method  ,(princ-to-string (ccl::method-name (caar info)))
-               ,(mapcar 'princ-to-string (mapcar 'class-name (ccl::method-specializers (caar info))))
+               ,(mapcar 'princ-to-string
+                        (mapcar #'specializer-name
+                                (ccl::method-specializers (caar info))))
                ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
              nil))
           (t (canonicalize-location (cdr (first info)) name)))))