[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*.
That means that we can't use SIGNAL here and we have to invoke
SLDB directly.
(condition-for-break): New helper.
Reported by Bill St. Clair.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/21 09:41:50	1.1769
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/23 16:48:16	1.1770
@@ -1,3 +1,11 @@
+2009-05-23  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*.
+	That means that we can't use SIGNAL here and we have to invoke
+	SLDB directly.
+	(condition-for-break): New helper.
+	Reported by Bill St. Clair.
+
 2009-05-19  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-symbol-at-point): Sometimes we can be too good,
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/19 09:51:55	1.171
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/23 16:48:16	1.172
@@ -517,19 +517,25 @@
     (ccl::apply-in-frame p lfun 
                          (ccl::frame-supplied-args p lfun pc nil context))))
 
-(let ((ccl::*warn-if-redefine-kernel* nil))
-  (ccl::advise
-   ccl::cbreak-loop
-   (if *break-in-sldb* 
-       (apply #'break-in-sldb ccl::arglist)
-       (:do-it))
-   :when :around
-   :name sldb-break))
-
-(defun break-in-sldb (x y &rest args)
-  (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
-                                   (ccl::%get-frame-ptr))))
-    (apply #'cerror y (if args "Break: ~a" x) args)))
+(ccl::advise ccl::cbreak-loop
+             (if *break-in-sldb* 
+                 (apply #'break-in-sldb ccl::arglist)
+                 (:do-it))
+             :when :around
+             :name sldb-break)
+
+(defun break-in-sldb (msg cont-string condition error-pointer)
+  (let ((*sldb-stack-top-hint* error-pointer))
+    (with-simple-restart (continue "~a" cont-string)
+      (funcall (read-from-string "SWANK:INVOKE-SLIME-DEBUGGER")
+               (condition-for-break condition msg)))))
+
+(defun condition-for-break (condition msg)
+  (cond ((and (eq (type-of condition) 'simple-condition)
+              (equal (simple-condition-format-control condition) ""))
+         (make-condition 'simple-condition :format-control "~a" 
+                         :format-arguments (list msg)))
+        (t condition)))
 
 (defimplementation disassemble-frame (the-frame-number)
   (with-frame (p context lfun pc) the-frame-number