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

[Helmut Eller]

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

Modified Files:
	swank.lisp 
Log Message:
(pprint-inspector-part, swank-compiler-macroexpand): New. 

Date: Mon Nov 21 00:27:26 2005
Author: heller

Index: slime/swank.lisp
diff -u slime/swank.lisp:1.352 slime/swank.lisp:1.353
--- slime/swank.lisp:1.352	Sat Nov 12 00:47:50 2005
+++ slime/swank.lisp	Mon Nov 21 00:27:26 2005
@@ -1805,6 +1805,8 @@
                   (*pending-continuations* (cons id *pending-continuations*)))
               (check-type *buffer-package* package)
               (check-type *buffer-readtable* readtable)
+              ;; APPLY would be cleaner than EVAL. 
+              ;;(setq result (apply (car form) (cdr form)))
               (setq result (eval form))
               (finish-output)
               (run-hook *pre-reply-hook*)
@@ -2428,6 +2430,12 @@
 (defslimefun swank-macroexpand-all (string)
   (apply-macro-expander #'macroexpand-all string))
 
+(defslimefun swank-compiler-macroexpand-1 (string)
+  (apply-macro-expander #'compiler-macroexpand-1 string))
+
+(defslimefun swank-compiler-macroexpand (string)
+  (apply-macro-expander #'compiler-macroexpand string))
+
 (defslimefun disassemble-symbol (name)
   (with-buffer-syntax ()
     (with-output-to-string (*standard-output*)
@@ -3590,29 +3598,28 @@
 (defmethod inspect-for-emacs ((o standard-object) inspector)
   (declare (ignore inspector))
   (values "An object."
-          `("Class: " (:value ,(class-of o))
-            (:newline)
+          `("Class: " (:value ,(class-of o)) (:newline)
             "Slots:" (:newline)
             ,@(loop
-                 with direct-slots = (swank-mop:class-direct-slots (class-of o))
                  for slot in (swank-mop:class-slots (class-of o))
-                 for slot-def = (or (find-if (lambda (a)
-                                               ;; find the direct slot
-                                               ;; with the same name
-                                               ;; as SLOT (an
-                                               ;; effective slot).
-                                               (eql (swank-mop:slot-definition-name a)
-                                                    (swank-mop:slot-definition-name slot)))
-                                             direct-slots)
-                                    slot)
-                 collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
+                 for slot-def = (find-effective-slot o slot)
+                 for slot-name = (swank-mop:slot-definition-name slot-def)
+                 collect `(:value ,slot-def ,(string slot-name))
                  collect " = "
-                 if (slot-boundp o (swank-mop:slot-definition-name slot-def))
-                   collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
-                 else
-                   collect "#<unbound>"
+                 collect (if (slot-boundp o slot-name)
+                             `(:value ,(slot-value o slot-name))
+                              "#<unbound>")
                  collect '(:newline)))))
 
+(defun find-effective-slot (o slot)
+  ;; find the direct slot with the same name as SLOT (an effective
+  ;; slot).
+  (or (find-if (lambda (a)
+                 (eql (swank-mop:slot-definition-name a)
+                      (swank-mop:slot-definition-name slot)))
+               (swank-mop:class-direct-slots (class-of o)))
+      slot))
+
 (defvar *gf-method-getter* 'methods-by-applicability
   "This function is called to get the methods of a generic function.
 The default returns the method sorted by applicability.
@@ -4040,6 +4047,11 @@
   "Describe the currently inspected object."
   (with-buffer-syntax ()
     (describe-to-string *inspectee*)))
+
+(defslimefun pprint-inspector-part (index)
+  "Pretty-print the currently inspected object."
+  (with-buffer-syntax ()
+    (swank-pprint (list (inspector-nth-part index)))))
 
 (defslimefun inspect-in-frame (string index)
   (with-buffer-syntax ()