/[slime]/slime/swank.lisp
ViewVC logotype

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.778 by heller, Sat Dec 10 12:33:40 2011 UTC revision 1.779 by heller, Sat Dec 10 12:33:52 2011 UTC
# Line 205  Backend code should treat the connection Line 205  Backend code should treat the connection
205    (user-output      nil :type (or stream null))    (user-output      nil :type (or stream null))
206    (user-io          nil :type (or stream null))    (user-io          nil :type (or stream null))
207    ;; Bindings used for this connection (usually streams)    ;; Bindings used for this connection (usually streams)
208    env    (env '() :type list)
209    ;; A stream that we use for *trace-output*; if nil, we user user-output.    ;; A stream that we use for *trace-output*; if nil, we user user-output.
210    (trace-output     nil :type (or stream null))    (trace-output     nil :type (or stream null))
211    ;; A stream where we send REPL results.    ;; A stream where we send REPL results.
# Line 1294  event was found." Line 1294  event was found."
1294        (end-of-file () (error 'end-of-repl-input :stream stream)))))        (end-of-file () (error 'end-of-repl-input :stream stream)))))
1295    
1296    
 ;; FIXME: would be nice if we could move this I/O stuff to swank-repl.lisp.  
   
 ;;;; 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)  
   
1297  ;;; Channels  ;;; Channels
1298    
1299  ;; FIXME: should be per connection not global.  ;; FIXME: should be per connection not global.

Legend:
Removed from v.1.778  
changed lines
  Added in v.1.779

  ViewVC Help
Powered by ViewVC 1.1.5