[slime-cvs] CVS slime

[CVS User nsiivola]

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
sbcl: restart-frame can restart anon and lexical functions now

  ...at least when the stars and entry points align.


--- /project/slime/cvsroot/slime/ChangeLog	2011/11/16 10:01:18	1.2242
+++ /project/slime/cvsroot/slime/ChangeLog	2011/11/19 16:35:58	1.2243
@@ -1,3 +1,8 @@
+2011-11-19  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank-sbcl.lisp (restart-frame): Make it possible to restart
+	frames of anonymous functions -- at least some of the time.
+
 2011-11-16  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (open-dedicated-output-stream): Open a stream with
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/11/06 17:06:09	1.292
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/11/19 16:35:58	1.293
@@ -1284,18 +1284,23 @@
                                                    (lambda ()
                                                      (values-list values)))))
             (t (format nil "Cannot return from frame: ~S" frame)))))
-  
+
   (defimplementation restart-frame (index)
-    (let* ((frame (nth-frame index)))
-      (cond ((sb-debug:frame-has-debug-tag-p frame)
-             (let* ((call-list (sb-debug::frame-call-as-list frame))
-                    (fun (fdefinition (car call-list)))
-                    (thunk (lambda () 
-                             ;; Ensure that the thunk gets tail-call-optimized
-                             (declare (optimize (debug 1)))
-                             (apply fun (cdr call-list)))))
-               (sb-debug:unwind-to-frame-and-call frame thunk)))
-            (t (format nil "Cannot restart frame: ~S" frame))))))
+    (let ((frame (nth-frame index)))
+      (when (sb-debug:frame-has-debug-tag-p frame)
+        (multiple-value-bind (fname args) (sb-debug::frame-call frame)
+          (multiple-value-bind (fun arglist)
+              (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
+                  (values (fdefinition fname) args)
+                  (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
+                          (sb-debug::frame-args-as-list frame)))
+            (when (functionp fun)
+              (sb-debug:unwind-to-frame-and-call frame
+                                                 (lambda ()
+                                                   ;; Ensure TCO.
+                                                   (declare (optimize (debug 0)))
+                                                   (apply fun arglist)))))))
+      (format nil "Cannot restart frame: ~S" frame))))
 
 ;; FIXME: this implementation doesn't unwind the stack before
 ;; re-invoking the function, but it's better than no implementation at