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

Diff of /slime/swank.lisp

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

revision 1.767 by heller, Fri Dec 2 18:17:54 2011 UTC revision 1.768 by heller, Sun Dec 4 15:05:46 2011 UTC
# Line 644  If PACKAGE is not specified, the home pa Line 644  If PACKAGE is not specified, the home pa
644    
645  ;;;; TCP Server  ;;;; TCP Server
646    
 (defvar *use-dedicated-output-stream* nil  
   "When T swank will attempt to create a second connection to  
   Emacs which is used just to send output.")  
   
 (defvar *dedicated-output-stream-port* 0  
   "Which port we should use for the dedicated output stream.")  
   
647  (defvar *communication-style* (preferred-communication-style))  (defvar *communication-style* (preferred-communication-style))
648    
649  (defvar *dont-close* nil  (defvar *dont-close* nil
650    "Default value of :dont-close argument to start-server and    "Default value of :dont-close argument to start-server and
651    create-server.")    create-server.")
652    
 (defvar *dedicated-output-stream-buffering*  
   (if (eq *communication-style* :spawn) t nil)  
   "The buffering scheme that should be used for the output stream.  
 Valid values are nil, t, :line")  
   
653  (defvar *listener-sockets* nil  (defvar *listener-sockets* nil
654    "A property list of lists containing style, socket pairs used    "A property list of lists containing style, socket pairs used
655     by swank server listeners, keyed on socket port number. They     by swank server listeners, keyed on socket port number. They
# Line 789  if the file doesn't exist; otherwise the Line 777  if the file doesn't exist; otherwise the
777      (format *log-output* "~&;; Swank started at port: ~D.~%" port)      (format *log-output* "~&;; Swank started at port: ~D.~%" port)
778      (force-output *log-output*)))      (force-output *log-output*)))
779    
 (defun open-streams (connection properties)  
   "Return the 5 streams for IO redirection:  
 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"  
   (let* ((input-fn  
           (lambda ()  
             (with-connection (connection)  
               (with-simple-restart (abort-read  
                                     "Abort reading input from Emacs.")  
                 (read-user-input-from-emacs)))))  
          (dedicated-output (if *use-dedicated-output-stream*  
                                (open-dedicated-output-stream  
                                 connection  
                                 (getf properties :coding-system))))  
          (in (make-input-stream input-fn))  
          (out (or dedicated-output  
                   (make-output-stream (make-output-function connection))))  
          (io (make-two-way-stream in out))  
          (repl-results (make-output-stream-for-target connection  
                                                       :repl-result)))  
     (when (eq (connection.communication-style connection) :spawn)  
       (setf (connection.auto-flush-thread connection)  
             (spawn (lambda () (auto-flush-loop out))  
                    :name "auto-flush-thread")))  
     (values dedicated-output in out io repl-results)))  
   
 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.  
 (defun make-output-function (connection)  
   "Create function to send user output to Emacs."  
   (let ((i 0) (tag 0) (l 0))  
     (lambda (string)  
       (with-connection (connection)  
         (multiple-value-setq (i tag l)  
           (send-user-output string i tag l))))))  
   
 (defvar *maximum-pipelined-output-chunks* 50)  
 (defvar *maximum-pipelined-output-length* (* 80 20 5))  
 (defun send-user-output (string pcount tag plength)  
   ;; send output with flow control  
   (when (or (> pcount *maximum-pipelined-output-chunks*)  
             (> plength *maximum-pipelined-output-length*))  
     (setf tag (mod (1+ tag) 1000))  
     (send-to-emacs `(:ping ,(current-thread-id) ,tag))  
     (with-simple-restart (abort "Abort sending output to Emacs.")  
       (wait-for-event `(:emacs-pong ,tag)))  
     (setf pcount 0)  
     (setf plength 0))  
   (send-to-emacs `(:write-string ,string))  
   (values (1+ pcount) tag (+ plength (length string))))  
   
 (defun make-output-function-for-target (connection target)  
   "Create a function to send user output to a specific TARGET in Emacs."  
   (lambda (string)  
     (with-connection (connection)  
       (with-simple-restart  
           (abort "Abort sending output to Emacs.")  
         (send-to-emacs `(:write-string ,string ,target))))))  
   
 (defun make-output-stream-for-target (connection target)  
   "Create a stream that sends output to a specific TARGET in Emacs."  
   (make-output-stream (make-output-function-for-target connection target)))  
   
 (defun open-dedicated-output-stream (connection coding-system)  
   "Open a dedicated output connection to the Emacs on SOCKET-IO.  
 Return an output stream suitable for writing program output.  
   
 This is an optimized way for Lisp to deliver output to Emacs."  
   (let ((socket (create-socket *loopback-interface*  
                                *dedicated-output-stream-port*))  
         (ef (find-external-format-or-lose coding-system)))  
     (unwind-protect  
          (let ((port (local-port socket)))  
            (encode-message `(:open-dedicated-output-stream ,port  
                                                            ,coding-system)  
                            (connection.socket-io connection))  
            (let ((dedicated (accept-connection  
                              socket  
                              :external-format ef  
                              :buffering *dedicated-output-stream-buffering*  
                              :timeout 30)))  
              (authenticate-client dedicated)  
              (close-socket socket)  
              (setf socket nil)  
              dedicated))  
       (when socket  
         (close-socket socket)))))  
   
780    
781  ;;;;; Event Decoding/Encoding  ;;;;; Event Decoding/Encoding
782    
# Line 1003  The processing is done in the extent of Line 905  The processing is done in the extent of
905       :seconds 0.1)       :seconds 0.1)
906      (sleep *auto-flush-interval*)))      (sleep *auto-flush-interval*)))
907    
 (defun find-repl-thread (connection)  
   (cond ((not (use-threads-p))  
          (current-thread))  
         (t  
          (let ((thread (connection.repl-thread connection)))  
            (cond ((not thread) nil)  
                  ((thread-alive-p thread) thread)  
                  (t  
                   (setf (connection.repl-thread connection)  
                         (spawn-repl-thread connection "new-repl-thread"))))))))  
   
908  (defun find-worker-thread (id)  (defun find-worker-thread (id)
909    (etypecase id    (etypecase id
910      ((member t)      ((member t)
# Line 1057  The processing is done in the extent of Line 948  The processing is done in the extent of
948                        (cdr (wait-for-event `(:emacs-rex . _)))))))                        (cdr (wait-for-event `(:emacs-rex . _)))))))
949           :name "worker"))           :name "worker"))
950    
 (defun spawn-repl-thread (connection name)  
   (spawn (lambda ()  
            (with-bindings *default-worker-thread-bindings*  
              (repl-loop connection)))  
          :name name))  
   
951  (defun dispatch-event (event)  (defun dispatch-event (event)
952    "Handle an event triggered either by Emacs or within Lisp."    "Handle an event triggered either by Emacs or within Lisp."
953    (log-event "dispatch-event: ~s~%" event)    (log-event "dispatch-event: ~s~%" event)
# Line 1197  event was found." Line 1082  event was found."
1082                   (not (equal (current-thread) thread)))                   (not (equal (current-thread) thread)))
1083          (kill-thread thread)))))          (kill-thread thread)))))
1084    
 (defun repl-loop (connection)  
   (handle-requests connection))  
   
1085  ;;;;;; Signal driven IO  ;;;;;; Signal driven IO
1086    
1087  (defun install-sigio-handler (connection)  (defun install-sigio-handler (connection)
# Line 1463  NIL if streams are not globally redirect Line 1345  NIL if streams are not globally redirect
1345    
1346  (add-hook *connection-closed-hook* 'update-redirection-after-close)  (add-hook *connection-closed-hook* 'update-redirection-after-close)
1347    
 ;;;;; Redirection during requests  
 ;;;  
 ;;; We always redirect the standard streams to Emacs while evaluating  
 ;;; an RPC. This is done with simple dynamic bindings.  
   
 (defslimefun create-repl (target &key coding-system)  
   (assert (eq target nil))  
   (let ((conn *emacs-connection*))  
     (initialize-streams-for-connection conn `(:coding-system ,coding-system))  
     (with-struct* (connection. @ conn)  
       (setf (@ env)  
             `((*standard-output* . ,(@ user-output))  
               (*standard-input*  . ,(@ user-input))  
               (*trace-output*    . ,(or (@ trace-output) (@ user-output)))  
               (*error-output*    . ,(@ user-output))  
               (*debug-io*        . ,(@ user-io))  
               (*query-io*        . ,(@ user-io))  
               (*terminal-io*     . ,(@ user-io))))  
       (maybe-redirect-global-io conn)  
       (when (use-threads-p)  
         (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))  
       (list (package-name *package*)  
             (package-string-for-prompt *package*)))))  
   
 (defun initialize-streams-for-connection (connection properties)  
   (multiple-value-bind (dedicated in out io repl-results)  
       (open-streams connection properties)  
     (setf (connection.dedicated-output connection) dedicated  
           (connection.user-io connection)          io  
           (connection.user-output connection)      out  
           (connection.user-input connection)       in  
           (connection.repl-results connection)     repl-results)  
     connection))  
   
   
1348  ;;; Channels  ;;; Channels
1349    
1350  (defvar *channels* '())  (defvar *channels* '())
# Line 1561  NIL if streams are not globally redirect Line 1408  NIL if streams are not globally redirect
1408  (defun make-tag ()  (defun make-tag ()
1409    (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))    (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1410    
 (defun read-user-input-from-emacs ()  
   (let ((tag (make-tag)))  
     (force-output)  
     (send-to-emacs `(:read-string ,(current-thread-id) ,tag))  
     (let ((ok nil))  
       (unwind-protect  
            (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))  
              (setq ok t))  
         (unless ok  
           (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))  
   
1411  (defun y-or-n-p-in-emacs (format-string &rest arguments)  (defun y-or-n-p-in-emacs (format-string &rest arguments)
1412    "Like y-or-n-p, but ask in the Emacs minibuffer."    "Like y-or-n-p, but ask in the Emacs minibuffer."
1413    (let ((tag (make-tag))    (let ((tag (make-tag))
# Line 2027  Return the full package-name and the str Line 1863  Return the full package-name and the str
1863      (setq *package* p)      (setq *package* p)
1864      (list (package-name p) (package-string-for-prompt p))))      (list (package-name p) (package-string-for-prompt p))))
1865    
 ;;;;; Listener eval  
   
 (defvar *listener-eval-function* 'repl-eval)  
   
 (defslimefun listener-eval (string)  
   (funcall *listener-eval-function* string))  
   
 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)  
   
 (defun repl-eval (string)  
   (clear-user-input)  
   (with-buffer-syntax ()  
     (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")  
       (track-package  
        (lambda ()  
          (multiple-value-bind (values last-form) (eval-region string)  
            (setq *** **  ** *  * (car values)  
                  /// //  // /  / values  
                  +++ ++  ++ +  + last-form)  
            (funcall *send-repl-results-function* values))))))  
   nil)  
   
 (defslimefun clear-repl-variables ()  
   (let ((variables '(*** ** * /// // / +++ ++ +)))  
     (loop for variable in variables  
           do (setf (symbol-value variable) nil))))  
   
 (defun track-package (fun)  
   (let ((p *package*))  
     (unwind-protect (funcall fun)  
       (unless (eq *package* p)  
         (send-to-emacs (list :new-package (package-name *package*)  
                              (package-string-for-prompt *package*)))))))  
   
 (defun send-repl-results-to-emacs (values)  
   (finish-output)  
   (if (null values)  
       (send-to-emacs `(:write-string "; No value" :repl-result))  
       (dolist (v values)  
         (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)  
                                        :repl-result)))))  
   
1866  (defun cat (&rest strings)  (defun cat (&rest strings)
1867    "Concatenate all arguments and make the result a string."    "Concatenate all arguments and make the result a string."
1868    (with-output-to-string (out)    (with-output-to-string (out)
# Line 3056  Include the nicknames if NICKNAMES is tr Line 2850  Include the nicknames if NICKNAMES is tr
2850  (defslimefun untrace-all ()  (defslimefun untrace-all ()
2851    (untrace))    (untrace))
2852    
 (defslimefun redirect-trace-output (target)  
   (setf (connection.trace-output *emacs-connection*)  
         (make-output-stream-for-target *emacs-connection* target))  
   nil)  
   
2853    
2854  ;;;; Undefing  ;;;; Undefing
2855    

Legend:
Removed from v.1.767  
changed lines
  Added in v.1.768

  ViewVC Help
Powered by ViewVC 1.1.5