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

[Alan Ruttenberg]

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

Modified Files:
	swank-openmcl.lisp 
Log Message:
in openmcl (break) now goes into slime debugger. 
(setq swank:*break-in-sldb* nil) to disable that.

Date: Thu Dec 18 14:57:50 2003
Author: aruttenberg

Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.40 slime/swank-openmcl.lisp:1.41
--- slime/swank-openmcl.lisp:1.40	Wed Dec 17 12:07:51 2003
+++ slime/swank-openmcl.lisp	Thu Dec 18 14:57:42 2003
@@ -13,7 +13,7 @@
 ;;; The LLGPL is also available online at
 ;;; http://opensource.franz.com/preamble.html
 ;;;
-;;;   $Id: swank-openmcl.lisp,v 1.40 2003/12/17 17:07:51 aruttenberg Exp $
+;;;   $Id: swank-openmcl.lisp,v 1.41 2003/12/18 19:57:42 aruttenberg Exp $
 ;;;
 
 ;;;
@@ -71,7 +71,7 @@
 (defun without-interrupts* (body)
   (ccl:without-interrupts (funcall body)))
 
-(defvar *swank-debugger-stack-frame*)
+(defvar *swank-debugger-stack-frame* nil)
 
 ;;; TCP Server
 
@@ -115,6 +115,37 @@
       (restart-case (invoke-debugger)
         (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t))
       ))))))
+
+(defvar *break-in-sldb* t)
+
+(let ((ccl::*warn-if-redefine-kernel* nil))
+  (ccl::advise 
+   cl::break 
+   (if (and *break-in-sldb* 
+            (eq ccl::*current-process* ccl::*interactive-abort-process*))
+       (apply 'break-in-sldb ccl::arglist)
+       (:do-it)) :when :around :name sldb-break))
+  
+
+(defun break-in-sldb (&optional string &rest args)
+  (let ((c (make-condition 'simple-condition
+                           :format-control (or string "Break")
+                           :format-arguments args)))
+    (let ((*swank-debugger-stack-frame* nil)
+          (previous-f nil)
+          (previous-f2 nil))
+      (block find-frame
+        (map-backtrace  
+         #'(lambda(frame-number p tcr lfun pc)
+             (declare (ignore frame-number tcr pc))
+             (when (eq  previous-f2 'break-in-sldb) 
+               (setq *swank-debugger-stack-frame* p)
+               (return-from find-frame))
+             (setq previous-f2 previous-f)
+             (setq previous-f (ccl::lfun-name lfun)))))
+      (restart-case (invoke-debugger c)
+        (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t))
+      )))
 
 (defun accept-loop (server-socket close)
   (unwind-protect (cond (close (accept-one-client server-socket))