[slime-cvs] CVS slime/contrib

[CVS User heller]

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

Modified Files:
	swank-repl.lisp 
Log Message:
* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.

--- /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/05 11:29:18	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/10 12:33:52	1.3
@@ -199,3 +199,153 @@
         (make-output-stream-for-target *emacs-connection* target))
   nil)
 
+
+
+;;;; IO to Emacs
+;;;
+;;; This code handles redirection of the standard I/O streams
+;;; (`*standard-output*', etc) into Emacs. The `connection' structure
+;;; contains the appropriate streams, so all we have to do is make the
+;;; right bindings.
+
+;;;;; Global I/O redirection framework
+;;;
+;;; Optionally, the top-level global bindings of the standard streams
+;;; can be assigned to be redirected to Emacs. When Emacs connects we
+;;; redirect the streams into the connection, and they keep going into
+;;; that connection even if more are established. If the connection
+;;; handling the streams closes then another is chosen, or if there
+;;; are no connections then we revert to the original (real) streams.
+;;;
+;;; It is slightly tricky to assign the global values of standard
+;;; streams because they are often shadowed by dynamic bindings. We
+;;; solve this problem by introducing an extra indirection via synonym
+;;; streams, so that *STANDARD-INPUT* is a synonym stream to
+;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
+;;; variables, so they can always be assigned to affect a global
+;;; change.
+
+(defvar *globally-redirect-io* nil
+  "When non-nil globally redirect all standard streams to Emacs.")
+
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+  "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
+  "Setup redirection scaffolding for a global stream variable.
+Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
+
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
+
+2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
+*STANDARD-INPUT*.
+
+3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
+*CURRENT-STANDARD-INPUT*.
+
+This has the effect of making *CURRENT-STANDARD-INPUT* contain the
+effective global value for *STANDARD-INPUT*. This way we can assign
+the effective global value even when *STANDARD-INPUT* is shadowed by a
+dynamic binding."
+  (let ((current-stream-var (prefixed-var '#:current stream-var))
+        (stream (or stream (symbol-value stream-var))))
+    ;; Save the real stream value for the future.
+    (setf (getf *saved-global-streams* stream-var) stream)
+    ;; Define a new variable for the effective stream.
+    ;; This can be reassigned.
+    (proclaim `(special ,current-stream-var))
+    (set current-stream-var stream)
+    ;; Assign the real binding as a synonym for the current one.
+    (let ((stream (make-synonym-stream current-stream-var)))
+      (set stream-var stream)
+      (set-default-initial-binding stream-var `(quote ,stream)))))
+
+(defun prefixed-var (prefix variable-symbol)
+  "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+  (let ((basename (subseq (symbol-name variable-symbol) 1)))
+    (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+
+(defvar *standard-output-streams*
+  '(*standard-output* *error-output* *trace-output*)
+  "The symbols naming standard output streams.")
+
+(defvar *standard-input-streams*
+  '(*standard-input*)
+  "The symbols naming standard input streams.")
+
+(defvar *standard-io-streams*
+  '(*debug-io* *query-io* *terminal-io*)
+  "The symbols naming standard io streams.")
+
+(defun init-global-stream-redirection ()
+  (when *globally-redirect-io*
+    (cond (*saved-global-streams*
+           (warn "Streams already redirected."))
+          (t
+           (mapc #'setup-stream-indirection
+                 (append *standard-output-streams*
+                         *standard-input-streams*
+                         *standard-io-streams*))))))
+
+(add-hook *after-init-hook* 'init-global-stream-redirection)
+
+(defun globally-redirect-io-to-connection (connection)
+  "Set the standard I/O streams to redirect to CONNECTION.
+Assigns *CURRENT-<STREAM>* for all standard streams."
+  (dolist (o *standard-output-streams*)
+    (set (prefixed-var '#:current o)
+         (connection.user-output connection)))
+  ;; FIXME: If we redirect standard input to Emacs then we get the
+  ;; regular Lisp top-level trying to read from our REPL.
+  ;;
+  ;; Perhaps the ideal would be for the real top-level to run in a
+  ;; thread with local bindings for all the standard streams. Failing
+  ;; that we probably would like to inhibit it from reading while
+  ;; Emacs is connected.
+  ;;
+  ;; Meanwhile we just leave *standard-input* alone.
+  #+NIL
+  (dolist (i *standard-input-streams*)
+    (set (prefixed-var '#:current i)
+         (connection.user-input connection)))
+  (dolist (io *standard-io-streams*)
+    (set (prefixed-var '#:current io)
+         (connection.user-io connection))))
+
+(defun revert-global-io-redirection ()
+  "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
+  (dolist (stream-var (append *standard-output-streams*
+                              *standard-input-streams*
+                              *standard-io-streams*))
+    (set (prefixed-var '#:current stream-var)
+         (getf *saved-global-streams* stream-var))))
+
+;;;;; Global redirection hooks
+
+(defvar *global-stdio-connection* nil
+  "The connection to which standard I/O streams are globally redirected.
+NIL if streams are not globally redirected.")
+
+(defun maybe-redirect-global-io (connection)
+  "Consider globally redirecting to CONNECTION."
+  (when (and *globally-redirect-io* (null *global-stdio-connection*)
+             (connection.user-io connection))
+    (setq *global-stdio-connection* connection)
+    (globally-redirect-io-to-connection connection)))
+
+(defun update-redirection-after-close (closed-connection)
+  "Update redirection after a connection closes."
+  (check-type closed-connection connection)
+  (when (eq *global-stdio-connection* closed-connection)
+    (if (and (default-connection) *globally-redirect-io*)
+        ;; Redirect to another connection.
+        (globally-redirect-io-to-connection (default-connection))
+        ;; No more connections, revert to the real streams.
+        (progn (revert-global-io-redirection)
+               (setq *global-stdio-connection* nil)))))
+
+(add-hook *connection-closed-hook* 'update-redirection-after-close)