[slime-cvs] CVS slime

[trittweiler]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4453

Modified Files:
	swank-sbcl.lisp 
Log Message:

	On SBCL, 

	  (block outta
	    (let ((*debugger-hook* #'(lambda (c hook)
				       (declare (ignore hook))
				       (return-from outta 42))))
	      (error "FOO")))

	would kist silently skip over the *DEBUGGER-HOOK*, and pop right
	into SLDB to handle the error. Fix that.
	
	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
	presence of *DEBUGGER-HOOK*, and calls that if available.
	(install-debugger-globally): Use it.
	(call-with-debugger-hook): Ditto.

	(getpid): Declaim return type explicitly, to make SBCL shut up about
	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.

	* slime.el (def-slime-test break): Test additionally that BREAK
	turns into SLDB even when *DEBUGGER-HOOK* is locally bound.
	(def-slime-test locally-bound-debugger-hook): New test case; tests
	that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/02/28 19:44:14	1.193
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/03/26 15:57:37	1.194
@@ -56,6 +56,17 @@
 (defun swank-mop:slot-definition-documentation (slot)
   (sb-pcl::documentation slot t))
 
+;;; Connection info
+
+(defimplementation lisp-implementation-type-name ()
+  "sbcl")
+
+;; Declare return type explicitly to shut up STYLE-WARNINGS about
+;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
+(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
+(defimplementation getpid ()
+  (sb-posix:getpid))
+
 ;;; TCP Server
 
 (defimplementation preferred-communication-style ()
@@ -109,7 +120,8 @@
 
 (defun enable-sigio-on-fd (fd)
   (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
-  (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
+  (sb-posix::fcntl fd sb-posix::f-setown (getpid))
+  (values))
 
 (defimplementation add-sigio-handler (socket fn)
   (set-sigio-handler)
@@ -173,11 +185,6 @@
   (declare (type function fn))
   (sb-sys:without-interrupts (funcall fn)))
 
-(defimplementation getpid ()
-  (sb-posix:getpid))
-
-(defimplementation lisp-implementation-type-name ()
-  "sbcl")
 
 
 ;;;; Support for SBCL syntax
@@ -723,8 +730,18 @@
 
 (defvar *sldb-stack-top*)
 
+(defun make-invoke-debugger-hook (hook)
+  #'(lambda (condition old-hook)
+      ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
+      ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
+      ;; run when it was established locally by a user.
+      (if *debugger-hook*
+          (funcall *debugger-hook* condition old-hook)
+          (funcall hook condition old-hook))))
+
 (defimplementation install-debugger-globally (function)
-  (setq sb-ext:*invoke-debugger-hook* function))
+  (setq *debugger-hook* function)
+  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
 
 (defimplementation condition-extras (condition)
   (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
@@ -772,7 +789,8 @@
     (invoke-restart 'sb-ext:step-out)))
 
 (defimplementation call-with-debugger-hook (hook fun)
-  (let ((sb-ext:*invoke-debugger-hook* hook)
+  (let ((*debugger-hook* hook)
+        (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
         #+#.(swank-backend::sbcl-with-new-stepper-p)
         (sb-ext:*stepper-hook*
          (lambda (condition)