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

Diff of /slime/swank.lisp

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

revision 1.766 by heller, Thu Dec 1 16:48:21 2011 UTC revision 1.767 by heller, Fri Dec 2 18:17:54 2011 UTC
# Line 1533  NIL if streams are not globally redirect Line 1533  NIL if streams are not globally redirect
1533  (defun send-to-remote-channel (channel-id msg)  (defun send-to-remote-channel (channel-id msg)
1534    (send-to-emacs `(:channel-send ,channel-id ,msg)))    (send-to-emacs `(:channel-send ,channel-id ,msg)))
1535    
 (defclass listener-channel (channel)  
   ((remote :initarg :remote)  
    (env :initarg :env)))  
   
 (defslimefun create-listener (remote)  
   (let* ((pkg *package*)  
          (conn *emacs-connection*)  
          (ch (make-instance 'listener-channel  
                             :remote remote  
                             :env (initial-listener-bindings remote))))  
   
     (with-slots (thread id) ch  
       (when (use-threads-p)  
         (setf thread (spawn-listener-thread ch conn)))  
       (list id  
             (thread-id thread)  
             (package-name pkg)  
             (package-string-for-prompt pkg)))))  
   
 (defun initial-listener-bindings (remote)  
   `((*package* . ,*package*)  
     (*standard-output*  
      . ,(make-listener-output-stream remote))  
     (*standard-input*  
      . ,(make-listener-input-stream remote))))  
   
 (defun spawn-listener-thread (channel connection)  
   (spawn (lambda ()  
            (with-connection (connection)  
              (loop  
               (destructure-case (wait-for-event `(:emacs-channel-send . _))  
                 ((:emacs-channel-send c (selector &rest args))  
                  (assert (eq c channel))  
                  (channel-send channel selector args))))))  
          :name "swank-listener-thread"))  
   
 (define-channel-method :eval ((c listener-channel) string)  
   (with-slots (remote env) c  
     (let ((aborted t))  
       (with-bindings env  
         (unwind-protect  
              (let* ((form (read-from-string string))  
                     (value (eval form)))  
                (send-to-remote-channel remote  
                                        `(:write-result  
                                          ,(prin1-to-string value)))  
                (setq aborted nil))  
           (force-output)  
           (setf env (loop for (sym) in env  
                           collect (cons sym (symbol-value sym))))  
           (let ((pkg (package-name *package*))  
                 (prompt (package-string-for-prompt *package*)))  
             (send-to-remote-channel remote  
                                     (if aborted  
                                         `(:evaluation-aborted ,pkg ,prompt)  
                                         `(:prompt ,pkg ,prompt)))))))))  
   
 (defun make-listener-output-stream (remote)  
   (make-output-stream (lambda (string)  
                         (send-to-remote-channel remote  
                                                 `(:write-string ,string)))))  
   
 (defun make-listener-input-stream (remote)  
   (make-input-stream  
    (lambda ()  
      (force-output)  
      (let ((tag (make-tag)))  
        (send-to-remote-channel remote  
                                `(: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-remote-channel remote `(:read-aborted ,tag)))))))))  
   
1536    
1537    
1538  (defun input-available-p (stream)  (defun input-available-p (stream)

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

  ViewVC Help
Powered by ViewVC 1.1.5