[slime-cvs] CVS slime

[CVS User msimmons]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv30926

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
(frame-actual-args): Reimplement to include
only the values like on other platforms and deal with, optional
key and rest args.
(print-frame): Format the frame as a call like in other backends.


--- /project/slime/cvsroot/slime/ChangeLog	2010/11/13 11:18:03	1.2165
+++ /project/slime/cvsroot/slime/ChangeLog	2010/12/02 16:39:00	1.2166
@@ -1,3 +1,10 @@
+2010-12-02  Martin Simmons  <martin at lispworks.com>
+
+	* swank-lispworks.lisp (frame-actual-args): Reimplement to include
+	only the values like on other platforms and deal with, optional
+	key and rest args.
+	(print-frame): Format the frame as a call like in other backends.
+
 2010-11-13  Helmut Eller  <heller at common-lisp.net>
 
 	Improve source locations for compiler messages in Lispworks.
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/13 11:18:03	1.140
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/12/02 16:39:00	1.141
@@ -365,20 +365,39 @@
 	(push frame backtrace)))))
 
 (defun frame-actual-args (frame)
-  (let ((*break-on-signals* nil))
-    (mapcar (lambda (arg)
-              (case arg
-                ((&rest &optional &key) arg)
-                (t
-                 (handler-case (dbg::dbg-eval arg frame)
-                   (error (e) (format nil "<~A>" arg))))))
-            (dbg::call-frame-arglist frame))))
+  (let ((*break-on-signals* nil)
+        (kind nil))
+    (loop for arg in (dbg::call-frame-arglist frame)
+          if (eq kind '&rest)
+          nconc (handler-case
+                    (dbg::dbg-eval arg frame)
+                  (error (e) (list (format nil "<~A>" arg))))
+          and do (loop-finish)
+          else
+          if (member arg '(&rest &optional &key))
+          do (setq kind arg)
+          else
+          nconc
+          (handler-case
+              (nconc (and (eq kind '&key)
+                          (list (cond ((symbolp arg)
+                                       (intern (symbol-name arg) :keyword))
+                                      ((and (consp arg) (symbolp (car arg)))
+                                       (intern (symbol-name (car arg)) :keyword))
+                                      (t (caar arg)))))
+                     (list (dbg::dbg-eval
+                            (cond ((symbolp arg) arg)
+                                  ((and (consp arg) (symbolp (car arg)))
+                                   (car arg))
+                                  (t (cadar arg)))
+                            frame)))
+            (error (e) (list (format nil "<~A>" arg)))))))
 
 (defimplementation print-frame (frame stream)
   (cond ((dbg::call-frame-p frame)
-         (format stream "~S ~S"
-                 (dbg::call-frame-function-name frame)
-                 (frame-actual-args frame)))
+         (prin1 (cons (dbg::call-frame-function-name frame)
+                      (frame-actual-args frame))
+                stream))
         (t (princ frame stream))))
 
 (defun frame-vars (frame)