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

[Helmut Eller]

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

Modified Files:
	swank-sbcl.lisp 
Log Message:
(*trap-load-time-warnings*): New variable.  If it is true, conditions,
most notably redefinition warnings, signalled at load time are not
trapped.

(swank-compile-file, swank-compile-string): Use it.

Date: Sun Jun 20 14:37:05 2004
Author: heller

Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.90 slime/swank-sbcl.lisp:1.91
--- slime/swank-sbcl.lisp:1.90	Wed Jun 16 13:26:01 2004
+++ slime/swank-sbcl.lisp	Sun Jun 20 14:37:05 2004
@@ -128,6 +128,11 @@
             (return (sb-bsd-sockets:socket-accept socket))
           (sb-bsd-sockets:interrupted-error ()))))
 
+(defimplementation emacs-connected (stream)
+  (declare (ignore stream))
+  (setq sb-ext:*invoke-debugger-hook* 
+        (find-symbol (string :swank-debugger-hook) (find-package :swank))))
+
 (defmethod call-without-interrupts (fn)
   (declare (type function fn))
   (sb-sys:without-interrupts (funcall fn)))
@@ -268,19 +273,29 @@
                  (warning              #'handle-notification-condition))
     (funcall function)))
 
+(defvar *trap-load-time-warnings* nil)
+
 (defimplementation swank-compile-file (filename load-p)
-  (with-compilation-hooks ()
-    (let ((fasl-file (compile-file filename)))
-      (when (and load-p fasl-file)
-        (load fasl-file)))))
+  (flet ((loadit (fasl-file) (when (and load-p fasl-file) (load fasl-file))))
+    (cond (*trap-load-time-warnings*
+           (with-compilation-hooks ()
+             (loadit (compile-file filename))))
+          (t
+           (loadit (with-compilation-hooks () 
+                     (compile-file filename)))))))
 
 (defimplementation swank-compile-string (string &key buffer position)
-  (with-compilation-hooks ()
-    (let ((*buffer-name* buffer)
-          (*buffer-offset* position)
-          (*buffer-substring* string))
-      (funcall (compile nil (read-from-string
-                             (format nil "(~S () ~A)" 'lambda string)))))))
+  (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
+    (flet ((compileit (cont)
+             (with-compilation-hooks ()
+               (let ((*buffer-name* buffer)
+                     (*buffer-offset* position)
+                     (*buffer-substring* string))
+                 (funcall cont (compile nil form))))))
+      (cond (*trap-load-time-warnings*
+             (compileit #'funcall))
+            (t 
+             (funcall (compileit #'identity)))))))
 
 ;;;; Definitions