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

[Helmut Eller]

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

Modified Files:
	swank.lisp 
Log Message:
(with-io-redirection, with-connection, with-buffer-syntax): Implement
macros with a `call-with' functions to avoid some code bloat.
(call-with-connection, maybe-call-with-io-redirection)
(call-with-buffer-syntax): New functions.

(interactive-eval): Use from-string instead of read-from-string to
avoid problems whit *read-suppress*.

Date: Sat Apr  9 09:07:46 2005
Author: heller

Index: slime/swank.lisp
diff -u slime/swank.lisp:1.292 slime/swank.lisp:1.293
--- slime/swank.lisp:1.292	Mon Apr  4 01:27:20 2005
+++ slime/swank.lisp	Sat Apr  9 09:07:46 2005
@@ -78,6 +78,10 @@
 (defvar *swank-debug-p* t
   "When true, print extra debugging information.")
 
+(defvar *redirect-io* t
+  "When non-nil redirect Lisp standard I/O to Emacs.
+Redirection is done while Lisp is processing a request for Emacs.")
+
 (defvar *sldb-printer-bindings*
   `((*print-pretty*           . nil)
     (*print-level*            . 4)
@@ -258,17 +262,23 @@
 (defmacro with-io-redirection ((connection) &body body)
   "Execute BODY I/O redirection to CONNECTION.
 If *REDIRECT-IO* is true then all standard I/O streams are redirected."
-  `(if *redirect-io*
-       (call-with-redirected-io ,connection (lambda () , at body))
-       (progn , at body)))
+  `(maybe-call-with-io-redirection ,connection (lambda () , at body)))
 
+(defun maybe-call-with-io-redirection (connection fun)
+  (if *redirect-io*
+      (call-with-redirected-io connection fun)
+      (funcall fun)))
+      
 (defmacro with-connection ((connection) &body body)
   "Execute BODY in the context of CONNECTION."
-  `(let ((*emacs-connection* ,connection))
-     (catch 'slime-toplevel
-       (with-io-redirection (*emacs-connection*)
-         (let ((*debugger-hook* #'swank-debugger-hook))
-           , at body)))))
+  `(call-with-connection ,connection (lambda () , at body)))
+
+(defun call-with-connection (connection fun)
+  (let ((*emacs-connection* connection))
+    (catch 'slime-toplevel
+      (with-io-redirection (*emacs-connection*)
+        (let ((*debugger-hook* #'swank-debugger-hook))
+          (funcall fun))))))
 
 (defmacro without-interrupts (&body body)
   `(call-without-interrupts (lambda () , at body)))
@@ -317,10 +327,6 @@
 
 ;;;; TCP Server
 
-(defparameter *redirect-io* t
-  "When non-nil redirect Lisp standard I/O to Emacs.
-Redirection is done while Lisp is processing a request for Emacs.")
-
 (defvar *use-dedicated-output-stream* t)
 (defvar *communication-style* (preferred-communication-style))
 
@@ -1052,13 +1058,16 @@
 This should be used for code that is conceptionally executed in an
 Emacs buffer."
   (destructuring-bind () _
-    `(let ((*package* *buffer-package*))
-       ;; Don't shadow *readtable* unnecessarily because that prevents
-       ;; the user from assigning to it.
-       (if (eq *readtable* *buffer-readtable*)
-           (call-with-syntax-hooks (lambda () , at body))
-           (let ((*readtable* *buffer-readtable*))
-             (call-with-syntax-hooks (lambda () , at body)))))))
+    `(call-with-buffer-syntax (lambda () , at body))))
+
+(defun call-with-buffer-syntax (fun)
+  (let ((*package* *buffer-package*))
+    ;; Don't shadow *readtable* unnecessarily because that prevents
+    ;; the user from assigning to it.
+    (if (eq *readtable* *buffer-readtable*)
+        (call-with-syntax-hooks fun)
+        (let ((*readtable* *buffer-readtable*))
+          (call-with-syntax-hooks fun)))))
 
 (defun from-string (string)
   "Read string in the *BUFFER-PACKAGE*"
@@ -1629,8 +1638,8 @@
             (let ((*buffer-package* (guess-buffer-package buffer-package))
                   (*buffer-readtable* (guess-buffer-readtable buffer-package))
                   (*pending-continuations* (cons id *pending-continuations*)))
-              (assert (packagep *buffer-package*))
-              (assert (readtablep *buffer-readtable*))
+              (check-type *buffer-package* package)
+              (check-type *buffer-readtable* readtable)
               (setq result (eval form))
               (force-output)
               (run-hook *pre-reply-hook*)
@@ -1651,7 +1660,7 @@
 
 (defslimefun interactive-eval (string)
   (with-buffer-syntax ()
-    (let ((values (multiple-value-list (eval (read-from-string string)))))
+    (let ((values (multiple-value-list (eval (from-string string)))))
       (fresh-line)
       (force-output)
       (format-values-for-echo-area values))))
@@ -1660,7 +1669,7 @@
   (with-buffer-syntax ()
     (let* ((s (make-string-output-stream))
            (*standard-output* s)
-           (values (multiple-value-list (eval (read-from-string string)))))
+           (values (multiple-value-list (eval (from-string string)))))
       (list (get-output-stream-string s) 
             (format nil "~{~S~^~%~}" values)))))