Changeset 15065

Timestamp:

Nov 10, 2011, 8:53:17 PM (8 years ago)

Author:

gz

Message:

Support for recursive readloops in remote listener. There are stll some problems with prompt printing but the basic mechanisms work

Location:

trunk/source

Files:

• cocoa-ide/cocoa-listener.lisp (modified) (2 diffs)
• cocoa-ide/cocoa-remote-lisp.lisp (modified) (2 diffs)
• library/remote-lisp.lisp (modified) (23 diffs)

trunk/source/cocoa-ide/cocoa-listener.lisp

@@ -106 +106 @@
           (return (values (call-next-method) nil t)))
         (wait-on-semaphore queue-semaphore nil "Toplevel Read")
-        (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
-          (cond ((stringp val)
-                 (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
-                 (setq cur-string val cur-string-pos 0))
-                (t
-                 (destructuring-bind (string package-name pathname offset) val
-                   ;; This env is used both for read and eval.
-                   (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location*
-                                      ccl::*nx-source-note-map*)
-                                    (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil
-                                          source-map))))
-                     (when package-name
-                       (push '*package* (car env))
-                       (push (ccl::pkg-arg package-name) (cdr env)))
-                     (if source-map
-                       (clrhash source-map)
-                       (setf source-map (make-hash-table :test 'eq :shared nil)))
-                     (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset))))))))))
+        (without-interrupts
+         (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
+           (cond ((stringp val)
+                  (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
+                  (setq cur-string val cur-string-pos 0))
+                 (val
+                  (destructuring-bind (string package-name pathname offset) val
+                    ;; This env is used both for read and eval.
+                    (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location*
+                                                                  ccl::*nx-source-note-map*)
+                                     (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil
+                                           source-map))))
+                      (when package-name
+                        (push '*package* (car env))
+                        (push (ccl::pkg-arg package-name) (cdr env)))
+                      (if source-map
+                        (clrhash source-map)
+                        (setf source-map (make-hash-table :test 'eq :shared nil)))
+                      (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset)))))))))))
 
 (defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset)
@@ -445 +446 @@
     (setq *next-listener-x-pos* nil
           *next-listener-y-pos* nil))
-  (let* ((p (shiftf (hemlock-document-process self) nil)))
+  (let* ((p (hemlock-document-process self)))
     (when p
+      (setf (hemlock-document-process self) nil)
       (process-kill p)))
   (call-next-method))

trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

@@ -23 +23 @@
 #+debug ;; For testing, start a ccl running swank, then call this in the ide.
 (defun cl-user::rlisp-test (port &optional host)
-  (declare (special conn thread))
-  (when (boundp 'conn) (close conn))
-  (setq conn (ccl::connect-to-swank (or host "localhost") port))
-  (setq thread (ccl::make-rrepl-thread conn "IDE Listener"))
-  (let* ((old ccl::*inhibit-greeting*)
-         (listener (unwind-protect
-                       (progn
-                         (setq ccl::*inhibit-greeting* t)
-                         (new-listener))
-                     (setq ccl::*inhibit-greeting* old))))
-    (connect-listener-to-remote listener thread)))
+  (declare (special cl-user::conn))
+  (when (boundp 'cl-user::conn) (close cl-user::conn))
+  (setq cl-user::conn (ccl::connect-to-swank (or host "localhost") port))
+  (ccl::make-rrepl-thread cl-user::conn "IDE Listener"))
+
+(defclass remote-listener-hemlock-view (hi:hemlock-view)
+  ((remote-thread :initarg :remote-thread :accessor listener-remote-thread)))
+
+;; Kludge city
+(defun create-remote-listener-view (rthread)
+  (let* ((listener (new-listener :inhibit-greeting t))
+         (doc (hi::buffer-document (hi:hemlock-view-buffer listener)))
+         (process (or (hemlock-document-process doc)
+                      (error "Not a listener: ~s" listener))))
+    (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window
+    (process-kill process)
+    (change-class listener 'remote-listener-hemlock-view :remote-thread rthread)
+    listener))
+
+(defmethod activate-rlisp-listener ((view remote-listener-hemlock-view))
+  (execute-in-gui
+   (lambda ()
+     (#/makeKeyAndOrderFront: (#/window (hi::hemlock-view-pane view)) (%null-ptr)))))
 
 
-(defclass remote-cocoa-listener-process (cocoa-listener-process)
-  ((remote-thread :initarg :remote-thread :reader process-remote-thread)))
+;; TODO: Do something to show that remote is not active
+(defmethod deactivate-rlisp-listener ((view remote-listener-hemlock-view))
+  nil)
 
-;; in the future, there should be something like a "New Remote Listener" command
-;; which should pass relevant info through to new-cocoa-listener-process.
-;; But this will do for testing: take an existing normal listener and convert it.
-(defmethod connect-listener-to-remote (object rthread)
-  (let ((view (hemlock-view object)))
-    (connect-listener-to-remote (or view (require-type object 'hi:hemlock-view)) rthread)))
+(defun listener-view-for-remote-thread (rthread &key activate)
+  (let ((view (first-window-satisfying-predicate (lambda (wptr)
+                                                   (let ((view (hemlock-view wptr)))
+                                                     (and (typep view 'remote-listener-hemlock-view)
+                                                          (eql (listener-remote-thread view) rthread)))))))
+    (when (and activate view)
+      (activate-rlisp-listener view))
+    view))
 
-(defmethod connect-listener-to-remote ((view hi:hemlock-view) (rthread ccl::remote-lisp-thread))
-  (let* ((doc (hi::buffer-document (hi:hemlock-view-buffer view)))
-         (process (or (hemlock-document-process doc)
-                      (error "Not a listener: ~s" view)))
-         (name (process-name process))
-         (window (cocoa-listener-process-window process)))
-    (when (eq process *current-process*)
-      (error "Cannot connect current listener"))
-    (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window
-    (process-kill process)
-    (let ((pos (search " [Remote " name :from-end t)))
-      (when pos
-        (setq name (subseq name 0 pos))))
+(defmethod ccl::create-rlisp-listener ((app cocoa-application) (rthread ccl::remote-lisp-thread))
+  (let* ((view (or (listener-view-for-remote-thread rthread :activate t)
+                   (create-remote-listener-view rthread)))
+         (buffer (hi:hemlock-view-buffer view))
+         (doc (hi::buffer-document buffer))
+         (name (hi:buffer-name buffer)))
+    (assert (null (hemlock-document-process doc)))
     (setf (hemlock-document-process doc)
+          ;; TODO: hemlock puts the local process number on modeline, which is uninteresting.
+          ;; TODO: change process name when change buffer name.
           (new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]"
-                                              name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread))
-                                      window
+                                              name
+                                              (ccl::rlisp-host-description rthread)
+                                              (ccl::rlisp-thread-id rthread))
+                                      (#/window (hi::hemlock-view-pane view))
                                       :class 'remote-cocoa-listener-process
                                       :initargs  `(:remote-thread ,rthread)
@@ -69 +82 @@
                                         (setf (hemlock-document-process doc) *current-process*)
                                         (ccl::remote-listener-function rthread))))))
+
+(defmethod ui-object-do-operation ((ui ns:ns-application) (op (eql :deactivate-rlisp-listener)) rthread)
+  ;; Do something to show that the listener is not active
+  (let ((view (listener-view-for-remote-thread rthread)))
+    (when view
+      (deactivate-rlisp-listener view))))
+
+(defclass remote-cocoa-listener-process (cocoa-listener-process)
+  ((remote-thread :initarg :remote-thread :reader process-remote-thread)))
+
+(defmethod process-kill :before ((process remote-cocoa-listener-process))
+  (let* ((wptr (cocoa-listener-process-window process))
+         (view (hemlock-view wptr)))
+    (when view
+      ;; don't close the window just because kill process.
+      (let ((doc (#/document wptr)))
+        (when (and doc (not (%null-ptr-p doc)))
+          (setf (hemlock-document-process doc) nil)))
+      (deactivate-rlisp-listener view))))
+
+;; Cmd-, calls this
+(defmethod ccl::force-break-in-listener ((p remote-cocoa-listener-process))
+  ;; Cause the other side to enter a breakloop, which it will inform us of when it happens.
+  (ccl::rlisp/interrupt (process-remote-thread p)))
 
 (defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))

trunk/source/library/remote-lisp.lisp

@@ -88 +88 @@
 (defclass remote-lisp-thread ()
   ((conn :initarg :connection :reader rlisp-thread-connection)
-   ;; Local process running the local repl
+   ;; Local process running the local repl: interacting with user, sending to remote for execution.
    (thread-process :initform nil :accessor rlisp-thread-process)
-   ;; Remote process doing the evaluation for this process.
-   (thread-id :initarg :thread-id :reader rlisp-thread-id)))
+   (break-level :initform nil :accessor rlisp-thread-break-level)
+   ;; Id of remote process doing the evaluation for the local process.
+   (thread-id :initarg :thread-id :reader rlisp-thread-id)
+   (event-queue :initform nil :accessor rlisp-thread-event-queue)))
 
 (defmethod rlisp-host-description ((rthread remote-lisp-thread))
@@ -118 +120 @@
                rthread)))))
 
+(defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &key (create nil))
+  (with-rlisp-lock (conn)
+    (or (find process (rlisp-threads conn) :key #'rlisp-thread-process)
+        (and create
+             (assert (not create))))))
+
 (defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
   (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
@@ -151 +159 @@
             (rlisp-host-description conn)
             (rlisp-machine-instance conn))))
+
 
 (defmethod start-rlisp-server ((conn swank-rlisp-connection))
@@ -161 +170 @@
                (handle-swank-event conn (car sexp) (cdr sexp))))))
     (setf (rlisp-server-process conn)
-          (process-run-function (format nil "Swank Client ~a" (remote-port (swank-command-stream conn)))
+          (process-run-function (format nil "swank-event-loop ~a" (remote-port (swank-command-stream conn)))
                                 #'swank-event-loop conn)))
   (let ((sem (make-semaphore)) (abort nil))
     ;; Patch up swank.  To be replaced someday by our own set of remote functions...
+    ;; TODO: advise send-to-emacs to intercept :write-string  and add in the thread id.
     (rlisp/execute conn
-                  "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
-                     (CL:DEFUN SWANK::EVAL-REGION (STRING)
-                       (CL:WITH-INPUT-FROM-STRING (STREAM STRING)
-                         (CL:LET (CL:- VALUES)
-                           (CL:LOOP
-                             (CL:LET ((FORM (CL:READ STREAM () STREAM)))
-                               (CL:WHEN (CL:EQ FORM STREAM)
-                                 (CL:FINISH-OUTPUT)
-                                 (CL:RETURN (CL:VALUES VALUES CL:-)))
-                               (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FORM)
-                                 (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:SETQ CL:- FORM))))
-                               (CL:FINISH-OUTPUT))))))
+                   "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
+                     (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::RDEBUG-SPAWN-REPL-THREAD CONN NAME))
+                     (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-INVOKE-DEBUGGER CONN))
+                     (CCL:ADVISE SWANK::DISPATCH-EVENT
+                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
+                                           (COMMAND (CL:CAR EVENT)))
+                                   (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :RETURN :EMACS-INTERRUPT
+                                                                         :EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING
+                                                                         :EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR))
+                                     (:DO-IT)
+                                     (SWANK::ENCODE-MESSAGE EVENT (SWANK::CURRENT-SOCKET-IO))))
+                                 :WHEN :AROUND
+                                 :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES
+                                 :DYNAMIC-EXTENT-ARGLIST CL:T)
+                     (CCL:ADVISE SWANK::SEND-TO-EMACS
+                                 (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
+                                           (COMMAND (CL:CAR EVENT)))
+                                   (CL:WHEN (CL:EQ COMMAND :WRITE-STRING)
+                                      (CL:SETF (CL:CDDR EVENT) (CL:LIST (SWANK::CURRENT-THREAD-ID)))))
+                                 :WHEN :BEFORE
+                                 :NAME CCL::SEND-THREAD-WITH-WRITE-STRING)
+                     (CL:DEFUN SWANK::SIMPLE-BREAK ()
+                       (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS*))
+                     (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATION*)
+                               (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :CONNECTION SWANK::*EMACS-CONNECTION*))
+
+                     (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:NIL) ;; let it go thru to break.
+
+                     (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::RDEBUG-FIND-REPL-THREAD)
+
+                     (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL)
+                       (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN
+                                               ,(SWANK::CURRENT-THREAD-ID) ,LEVEL ,SWANK::*SLDB-STEPPING-P*))
+                       (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL)) CL:T)
+                       (CL:WHEN (CL:> LEVEL 1)
+                         (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLDB-RETURN ,LEVEL))))
+
                      (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
-                       (SWANK::CREATE-REPL ())
+                       (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads.
                        (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
                          (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
                          (SWANK::THREAD-ID THREAD)))
-                     (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING)
-                       (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION*
-                                 #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LISTENER-EVAL-FOR-IDE
-                                                    (CL:MAPCAR #'CL:WRITE-TO-STRING _)))))
-                         (SWANK::REPL-EVAL STRING)))
-                     (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTENER-EVAL-FOR-IDE))"
+                     CL:T)"
                    (lambda (error result)
                      (declare (ignore result))
@@ -198 +228 @@
                      (signal-semaphore sem)))
     (wait-on-semaphore sem)
+    ;; TODO: should at least kill server process.
     (when abort (return-from start-rlisp-server nil))
     (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
@@ -229 +260 @@
   *standard-input*)
 
+(defun process-output-stream (process)
+  (let ((stream (symbol-value-in-process '*standard-output* process)))
+    (loop
+      (typecase stream
+        (synonym-stream
+         (setq stream (symbol-value-in-process (synonym-stream-symbol stream) process)))
+        (two-way-stream
+         (setq stream (two-way-stream-output-stream stream)))
+        (t (return stream))))))
+
+(defvar *signal-swank-events* nil)
+
+(define-condition swank-events () ())
+
+(defmacro with-swank-events ((rthread &key abort) &body body)
+  (let ((rthread-var (gensym "RTHREAD")))
+    (if abort
+      ;; When body is no re-entrant, abort it before handling the event.
+      `(let ((,rthread-var ,rthread))
+         (loop
+           (handler-case (return (let ((*signal-swank-events* t))
+                                   (when (rlisp-thread-event-queue ,rthread-var)
+                                     (let ((*signal-swank-events* nil))
+                                       (handle-swank-events ,rthread-var)))
+                                   ,@body))
+             (swank-events () (let ((*signal-swank-events* nil))
+                                (handle-swank-events rthread))))))
+      `(let ((,rthread-var ,rthread))
+         (handler-bind ((swank-events (lambda (c)
+                                        (declare (ignore c))
+                                        (handle-swank-events ,rthread-var))))
+           (let ((*signal-swank-events* t))
+             (when (rlisp-thread-event-queue ,rthread-var)
+               (let ((*signal-swank-events* nil))
+                 (handle-swank-events ,rthread-var)))
+             ,@body))))))
+
+(defun signal-swank-event (rthread event args)
+  (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
+    (setf (rlisp-thread-event-queue rthread)
+          (nconc (rlisp-thread-event-queue rthread) (list `(,event ,@args)))))
+  (process-interrupt (or (rlisp-thread-process rthread)
+                         (error "Got event ~s ~s for thread ~s with no process" event args rthread))
+                     (lambda ()
+                       (when *signal-swank-events*
+                         (let ((*signal-swank-events* nil))
+                           (signal 'swank-events))))))
+
+(defun handle-swank-events (rthread)
+  (loop for event = (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
+                      (pop (rlisp-thread-event-queue rthread)))
+    while event do (handle-swank-event rthread (car event) (cdr event))))
+
 (defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
   (case event
@@ -237 +321 @@
      (destructuring-bind (id message) args
        (when id (remove-rlisp-object conn id))
-       (error "Invalid swank rpc: ~s" message)))
-    ((:debug :debug-activate :debug-return :debug-condition :read-aborted)
+       (error "Invalid rpc: ~s" message)))
+    (:enter-break ;; Starting a new repl (possibly due to an error in a non-repl process)
+     ;; For now, this is assumed to create the listener before processing another command, so
+     ;; the remote can send commands to it right away.
+     ;; If that becomes a problem, can make a protocol so the other side will explicitly wait,
+     ;; and then we can spawn off a worker thread to do this.
+     (destructuring-bind (thread-id break-level) args
+       (let ((rthread (rlisp-thread conn thread-id)))
+         (enter-rlisp-listener rthread break-level)
+         ;; TODO: this isn't really right.  Need to wait for process context to be set up.  Perhaps
+         ;; make sure thread-process is not set until the process is running in full context.
+         (process-wait "REPL startup" #'rlisp-thread-process rthread)
+         ;(signal-swank-event rthread event (cdr args))
+         )))
+    (:exit-break
+     (destructuring-bind (thread-id) args
+       (let ((rthread (rlisp-thread conn thread-id)))
+         (when (and rthread (rlisp-thread-process rthread))
+           (exit-rlisp-listener rthread)))))
+    ((:read-loop :values :debug-return :debug-condition :read-aborted)
+     ;; TODO: this needs to make sure the process is in the right dynamic state (with all restarts established etc)
+     ;;  Need our own interrupt queue, with-event-handling macro...
      (destructuring-bind (thread-id &rest event-args) args
        (let ((rthread (rlisp-thread conn thread-id)))
-         (unless (rlisp-thread-process rthread)
-           (error "Got swank event ~s ~s for thread ~s with no process" event args rthread))
-         (process-interrupt (rlisp-thread-process rthread)
-                            #'handle-swank-event
-                            rthread event event-args))))
+         (signal-swank-event rthread event event-args))))
     (:new-features
      (destructuring-bind (features) args
@@ -252 +352 @@
      (destructuring-bind (name-indent-alist) args
        (declare (ignore name-indent-alist))))
+    ;; TODO: make the i/o streams be thread-specific, so we know which listener to use even if some other
+    ;; thread is doing the i/o.  I.e. this should send a thread id of the owner of the stream, not of the
+    ;; thread that happens to write it, so it will always be a listener thread.
     (:write-string
-     (destructuring-bind (string) args
-       (let ((stream (output-stream-for-remote-lisp *application*)))
+     (destructuring-bind (string thread-id) args
+       (let* ((rthread (rlisp-thread conn thread-id :create nil))
+              (stream (if (and rthread (rlisp-thread-process rthread))
+                        (process-output-stream (rlisp-thread-process rthread))
+                        (output-stream-for-remote-lisp *application*))))
          (if (> (length string) 500)
            (process-run-function "Long Remote Output" #'write-string string stream)
            (write-string string stream)))))
+    (:ping ;; flow control for output
+     (destructuring-bind (thread-id tag) args
+       ;; TODO: I guess we're supposed to wait til the previous output is finished or something.
+       (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag))))
     (:read-string
      (destructuring-bind (thread-id tag) args
        (let ((rthread (rlisp-thread conn thread-id :create nil)))
          (if (and rthread (rlisp-thread-process rthread))
-           (process-interrupt (rlisp-thread-process rthread)
-                              #'handle-swank-event
-                              rthread event `(,tag))
+           (signal-swank-event rthread event (cdr args))
            ;; not a listener thread.
            ;; TODO: this needs to be wrapped in some error handling.
@@ -275 +383 @@
     (t (warn "Received unknown event ~s with args ~s" event args))))
 
+
+
 (define-condition rlisp-read-aborted ()
   ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
@@ -282 +392 @@
                                        (when (eql tag (rlisp-read-aborted-tag c))
                                          (return-from rlisp-read-string)))))
+    (peek-char t stream) ;; wait for first one, error if none.
     (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
                      (read-available-text stream))))
@@ -292 +403 @@
      (destructuring-bind (tag) args
        (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
-    (:read-aborted
+    (:read-aborted  ;; huh?
      (destructuring-bind (tag) args
        (signal 'rlisp-read-aborted :tag tag)))
-    (:debug     ;; SLDB-SETUP
-     (destructuring-bind (level (condition-text condition-type extras)
-                                ;; list of (restart-name restart-description)
-                                restarts
-                                ;; list of (index frame-description &key restartable)
-                                backtrace
-                                ;; callbacks currently being evaluated in this thread.
-                                ;; Wonder what emacs does with that.
-                                pending-callbacks) args
-       (declare (ignorable condition-type extras backtrace pending-callbacks))
-       (format t "~&Error: ~a" condition-text)
-       (when *show-restarts-on-break*
-         (format t "~&Remote restarts:")
-         (loop for (name description) in restarts
-           do (format t "~&~a ~a" name description))
-         (fresh-line))
+    (:read-loop ;; enter (or re-enter after an abort) a break loop.
+     (destructuring-bind (level) args
+       (when (eql level *break-level*) ;; restart at same level, aborted current expression.
+         (invoke-restart 'debug-restart level))
+       (unless (eql level (1+ *break-level*))
+         (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
+       ;(format t "~&Error: ~a" condition-text)
+       ;(when *show-restarts-on-break*
+       ;  (format t "~&Remote restarts:")
+       ;  (loop for (name description) in restarts
+       ;    do (format t "~&~a ~a" name description))
+       ;  (fresh-line))
        (rlisp-read-loop rthread :break-level level)))
-    (:debug-activate ;; SLDB-ACTIVATE
-     (destructuring-bind (level flag) args
-       (declare (ignore flag))
-       (unless (eql level *break-level*)
-         (warn "break level confusion is ~s expected ~s" *break-level* level))))
-    (:debug-condition ;; This seems to have something to do with errors in the debugger
-     (destructuring-bind (message) args
-       (format t "~&Swank error: ~s" message)))
-    (:debug-return
-     (destructuring-bind (level stepping-p) args
-       (declare (ignore stepping-p))
-       (unless (eql level *break-level*)
-         (invoke-restart 'debug-return level))))))
+     (:debug-condition ;; This seems to have something to do with errors in the debugger
+         (destructuring-bind (message) args
+           (format t "~&Swank error: ~s" message)))
+     (:debug-return ;; return from level LEVEL read loop
+      (destructuring-bind (level stepping-p) args
+        (declare (ignore stepping-p))
+        (invoke-restart 'debug-return level)))
+     (:values ;; intermediate values when multiple forms in selection.
+      (destructuring-bind (values) args
+        (when values
+          (fresh-line)
+          (dolist (val values) (write val) (terpri)))
+        (force-output)
+        (print-listener-prompt *standard-output*)))))
 
 
@@ -332 +440 @@
   (assert (eq (rlisp-server-process conn) *current-process*))
   (let* ((stream (swank-command-stream conn))
-         (buffer (swank-read-buffer conn))
-         (count (stream-read-vector stream buffer 0 6)))
+         (buffer (swank-read-buffer conn)))
+    (multiple-value-bind (form updated-buffer) (read-remote-event stream buffer)
+      (unless (eq updated-buffer buffer)
+        (setf (swank-read-buffer conn) updated-buffer))
+      form)))
+
+(defun read-remote-event (stream &optional buffer)
+  (let* ((header (or buffer (make-string 6)))
+         (count (stream-read-vector stream header 0 6)))
     (when (< count 6) (signal-eof-error stream))
-    (setq count (parse-integer buffer :end 6 :radix 16))
+    (setq count (parse-integer header :end 6 :radix 16))
+    (assert (> count 0))
     (when (< (length buffer) count)
-      (setf (swank-read-buffer conn)
-            (setq buffer (make-array count :element-type 'character))))
+      (setq buffer (make-string count)))
     (let ((len (stream-read-vector stream buffer 0 count)))
       (when (< len count) (signal-eof-error stream))
-      ;; TODO: catch errors here and report them sanely.
       ;; TODO: check that there aren't more forms in the string.
-      (with-standard-io-syntax
-          (let ((*package* +swank-io-package+)
-                (*read-eval* nil))
-            (read-from-string buffer t nil :end count))))))
-
+      (values (handler-case
+                  (with-standard-io-syntax
+                      (let ((*package* +swank-io-package+)
+                            (*read-eval* nil))
+                        (read-from-string buffer t nil :end count)))
+                (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c)))
+              buffer))))
 
 (defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
@@ -409 +525 @@
 
 
-;; Continuation is executed in the same process that invoked remote-execute.
-(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key package thread)
+;; Continuation will be executed in the current process.
+(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread)
   (flet ((continuation (result)
            (ecase (car result)
@@ -416 +532 @@
              (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
     (let* ((sexp `(:emacs-rex ,form-or-string
-                              ,package
+                              nil
                               ,(thread-id-for-execute thread)
                               ,(and continuation (register-rlisp-callback conn #'continuation)))))
@@ -423 +539 @@
         (send-sexp-to-swank conn sexp)))))
 
-
 (defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
   ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
@@ -434 +549 @@
 (defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
   (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
-  
-;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string &key thread)
-;;  (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execute thread) ,tag ,string)))
-
-;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value &key thread)
-;;  (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value)))
 
 (defun read-available-text (stream)
@@ -447 +556 @@
     do (vector-push-extend ch buffer)
     finally (return buffer)))
-  
+
 ;; Return text for remote evaluation.
 (defmethod toplevel-form-text ((stream input-stream))
@@ -470 +579 @@
               (rlisp-lisp-implementation-version conn)
               (rlisp-machine-instance conn))))
-  (rlisp-read-loop rthread :break-level 0))
-  
+  (rlisp-read-loop rthread :break-level (rlisp-thread-break-level rthread)))
+
+;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
+(defmethod exit-rlisp-listener ((rthread remote-lisp-thread))
+  (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener
+  (let ((process (rlisp-thread-process rthread)))
+    (setf (rlisp-thread-process rthread) nil)
+    (process-kill process)))
+
+(defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level)
+  (when (rlisp-thread-process rthread)
+    (error "Attempting to re-enter active listener"))
+  (setf (rlisp-thread-break-level rthread) break-level)
+  ;; The process creation would be a little different
+  (create-rlisp-listener *application* rthread))
+
+(defmethod create-rlisp-listener ((application application) rthread)
+  (assert (null (rlisp-thread-process rthread)))
+  ;; see make-mcl-listener-process
+  (error "Not implemented yet"))
+
+;; IDE read-loop with remote evaluation.
 (defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
   (let* ((*break-level* break-level)  ;; used by prompt printing
          (*last-break-level* break-level)  ;; ditto
          (debug-return nil))
-    ;; When the user invokes a restart from a list, it will be a remote restart and
-    ;; we will pass the request to the remote.  However, there are some UI actions that invoke local
-    ;; restarts by name, e.g. cmd-/ will invoke 'continue.  We need catch those and pass them to
-    ;; the remote.  The remote will then do whatever the restart does, and will send 'debug-return's
-    ;; as needed.
     (unwind-protect
         (loop
+          (setf (rlisp-thread-break-level rthread) break-level)
           (restart-case
-              ;; Do continue with a restart bind because don't want to abort whatever form is
+              ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue.
+              ;; Catch those and just pass them to the remote.  The remote will then do whatever the restart
+              ;; does, and will send back unwinding directions if appropriate.
+              ;; Do continue with a restart-bind because don't want to abort whatever form is
               ;; about to be sent for evaluation, just in case the continue doesn't end up doing
               ;; anything on the remote end.
@@ -498 +626 @@
                     (rlisp/invoke-restart rthread 'abort)))
                 (rlisp/toplevel rthread))
-            (abort () ;; intercept local attempt to abort
-              (rlisp/invoke-restart rthread 'abort))
-            (abort-break () ;; intercept local attempt to abort-break
-              (if (eq break-level 0)
-                (rlisp/invoke-restart rthread 'abort)
-                (rlisp/invoke-restart rthread 'abort-break)))
-            (muffle-warning (&optional condition) ;; not likely to be invoked interactively, but...
-              (assert (null condition)) ;; no way to pass that!
-              (rlisp/invoke-restart rthread 'muffle-warning))
+            ;; These are invoked via invoke-restart-no-return, so must take non-local exit.
+            (abort () (rlisp/invoke-restart rthread 'abort))
+            (abort-break () (if (eql break-level 0)
+                              (rlisp/invoke-restart rthread 'abort)
+                              (rlisp/invoke-restart rthread 'abort-break)))
+            ;; This is invoked when remote unwinds
             (debug-return (target-level)
+               (setq debug-return t)
+               (when (eql target-level break-level)
+                 (return-from rlisp-read-loop))
                (when (> target-level break-level)
                  (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
-               (when (< target-level break-level)
+               (invoke-restart 'debug-return target-level))
+            (debug-restart (target-level)
+               (unless (eql target-level break-level)
+                 (when (> target-level break-level)
+                   (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level))
                  (setq debug-return t)
-                 (invoke-restart 'debug-return target-level))))
+                 (invoke-restart 'debug-restart target-level))))
           (clear-input)
           (fresh-line))
       (unless debug-return
-        (warn "Unknown exit from rlisp-read-loop!")))))
+        (warn "Unknown exit from rlisp-read-loop!")))))
 
 (defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
@@ -526 +658 @@
       (force-output output-stream)
       (print-listener-prompt output-stream t)
-      (multiple-value-bind (text env) (toplevel-form-text input-stream)
+
+      (multiple-value-bind (text env)
+                           ;; Reading is not re-entrant so events during reading need
+                           ;; to abort the read to be handled.
+                           (with-swank-events (rthread  :abort t)
+                             (toplevel-form-text input-stream))
         (if (null text) ;; eof
           (progn
@@ -550 +687 @@
 (defmethod remote-listener-eval ((conn swank-rlisp-connection) text
                                  &key package thread (semaphore (make-semaphore)))
-  (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text))
-         (return-values nil)
-         (return-error nil))
+  (assert thread)
+  (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)"
+                       text package 
+                       ;; This will send intermediate :values messages
+                       (and *verbose-eval-selection* t)))
+         (return-values nil))
     (rlisp/execute conn
                    form
                    (lambda (error values)
-                     (setq return-error error)
-                     (setq return-values values)
-                     (signal-semaphore semaphore))
-                   :package package
+                     ;; Error just means evaluation was aborted but we don't yet know why.  We will
+                     ;; be told to either restart a readloop or exit it.  Stay in semaphore wait
+                     ;; until then.
+                     (unless error
+                       (setq return-values values)
+                       (signal-semaphore semaphore)))
                    :thread thread)
-    (wait-on-semaphore semaphore)
-    (when return-error
-      (error "Remote eval error ~s" return-error))
+    (with-swank-events (thread)
+      (wait-on-semaphore semaphore))
     ;; a list of strings representing each return value
     return-values))
 
-
-
-
-
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
-;; Server-side SWANK support
+;; Server-side: support for a remote debugger
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
+
+;;TODO: This is per application but we may want to allow multiple remote debuggers, and have this track
+;; all connections.   See also process-ui-object.
+(defclass rdebug-ui-object (ui-object)
+  ((connection :initarg :connection :accessor rdebug-ui-connection)))
+
+;; Currently built on swank.
 
 (defun swankvar (name &optional (package :swank))
@@ -589 +730 @@
       (warn "Couldn't find ~a::~a" package name)
       (set sym value))))
+
+(defun swankfun (name &optional (package :swank))
+  (symbol-function (find-symbol name package)))
+
+#-bootstrapped
+(declaim (special *read-loop-function*))
+
+(defun rdebug-send (event)
+  (funcall (swankfun "SEND-TO-EMACS")
+           (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD-ID") x) x)) event)))
+
+(defun rdebug-listener-eval (string package-name verbose-eval-selection)
+  (if package-name
+    (let ((*package* (or (find-package package-name) *package*)))
+      (rdebug-listener-eval string nil verbose-eval-selection))
+    (with-input-from-string (sstream string)
+      (let ((values nil))
+        (loop
+          (let ((form (read-toplevel-form sstream :eof-value sstream)))
+            (when (eq form sstream)
+              (finish-output)
+              (return values))
+            (when verbose-eval-selection
+              (rdebug-send `(:values ,*current-process* ,values)))
+            ;; there is more.
+            (unless (check-toplevel-command form)
+              ;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
+              (setq values (toplevel-eval form nil))
+              (setq /// // // / / values)
+              (unless (eq (car values) (%unbound-marker))
+                (setq *** ** ** * *  (%car values)))
+              (setq values (mapcar #'write-to-string values)))))))))
+
+(defun rdebug-spawn-repl-thread (conn name)
+  (process-run-function name
+                        (lambda ()
+                          (funcall (swankfun "CALL-WITH-CONNECTION") conn
+                                   (lambda ()
+                                     (rdebug-send `(:enter-break ,*current-process* 0))
+                                     (let ((*read-loop-function* 'rdebug-read-loop)
+                                           (*debugger-hook* nil)
+                                           (*break-hook* nil))
+                                       (unwind-protect
+                                           (toplevel-loop)
+                                         (rdebug-send `(:exit-break ,*current-process*)))))))))
+
+;; Debugger invoked in a non-repl process.  This is called with all swank stuff already set up.
+(defun rdebug-invoke-debugger (condition)
+   (when (eq *read-loop-function* 'rdebug-read-loop)
+      (return-from rdebug-invoke-debugger))
+    (rdebug-send `(:enter-break ,*current-process* 1))
+    (unwind-protect
+        (let ((*read-loop-function* 'rdebug-read-loop)
+              (*debugger-hook* nil)
+              (*break-hook* nil))
+          (%break-message *break-loop-type* condition)
+          ;; Like toplevel-loop but run break-loop to set up error context before going into read-loop
+          (loop
+            (catch :toplevel
+              (break-loop condition))
+            (when (eq *current-process* *initial-process*)
+              (toplevel))))
+      (rdebug-send `(:exit-break ,*current-process*))))
+
+
+;; swank-like read loop except with all the standard ccl restarts and catches.
+;; TODO: try to make the standard read-loop customizable enough to do this so don't have to replace it.
+(defun rdebug-read-loop (&key (break-level 0) &allow-other-keys)
+  ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that won't do anything even if those
+  ;; are set to something non-standard, since swank doesn't hang its protocol on the streams.
+  (let ((*break-level* break-level)
+        (*loading-file-source-file* nil)
+        (*loading-toplevel-location* nil)
+        *** ** * +++ ++ + /// // / -)
+    (flet ((repl-until-abort ()
+             (rdebug-send `(:read-loop ,*current-process* ,break-level))
+             (restart-case
+                 (catch :abort
+                   (catch-cancel
+                    (loop
+                      (setq *break-level* break-level)
+                      (let ((event (funcall (swankfun "WAIT-FOR-EVENT")
+                                            `(or (:emacs-rex . _)
+                                                 ;; some internal swank kludge...
+                                                 (:sldb-return ,(1+ break-level))))))
+                        (when (eql (car event) :sldb-return)
+                          (abort))
+                        ;; Execute some basic protocol function (not user code).
+                        (apply (swankfun "EVAL-FOR-EMACS") (cdr event))))))
+               (abort ()
+                 :report (lambda (stream)
+                           (if (eq break-level 0)
+                             (format stream "Return to toplevel")
+                             (format stream "Return to break level ~D" break-level)))
+                 nil)
+               (abort-break () (unless (eql break-level 0) (abort))))))
+      (declare (ftype (function) exit-swank-loop))
+      (unwind-protect
+          (loop
+            (repl-until-abort)
+            ;(clear-input)
+            ;(terpri)
+            )
+        (exit-swank-loop break-level)))))
+
+ (defun safe-condition-string (condition)
+   (or (ignore-errors (princ-to-string condition))
+       (ignore-errors (prin1-to-string condition))
+       (ignore-errors (format nil "Condition of type ~s"
+                              (type-of condition)))
+       (ignore-errors (and (typep condition 'error)
+                           "<Unprintable error>"))
+       "<Unprintable condition>"))
+
+;; Find process to handle interactive abort, i.e. a local ^c.
+(defun rdebug-find-repl-thread ()
+  (let ((conn (funcall (swankfun "DEFAULT-CONNECTION"))))
+    (when conn
+      ;; TODO: select the frontmost listener (this selects the last created one).
+      (funcall (swankfun "FIND-REPL-THREAD") conn))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 
+;; Standard swank startup
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
 
 (defun load-swank (load-path)
@@ -622 +892 @@
   (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
   (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
-  (funcall (find-symbol "CREATE-SERVER" :swank)
+  (funcall (swankfun "CREATE-SERVER")
            :style style
            :port port