Changeset 15105


Ignore:
Timestamp:
Dec 2, 2011, 9:57:48 PM (8 years ago)
Author:
gz
Message:

Rewrite the remote lisp client to use swink rather than swank. Move swank utilities to a separate file since no longer use it here.

Location:
trunk/source
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

    r15065 r15105  
    2525  (declare (special cl-user::conn))
    2626  (when (boundp 'cl-user::conn) (close cl-user::conn))
    27   (setq cl-user::conn (ccl::connect-to-swank (or host "localhost") port))
     27  (setq cl-user::conn (ccl::connect-to-swink (or host "localhost") port))
    2828  (ccl::make-rrepl-thread cl-user::conn "IDE Listener"))
    2929
     
    7474                                              name
    7575                                              (ccl::rlisp-host-description rthread)
    76                                               (ccl::rlisp-thread-id rthread))
     76                                              (swink:thread-id rthread))
    7777                                      (#/window (hi::hemlock-view-pane view))
    7878                                      :class 'remote-cocoa-listener-process
     
    107107  (ccl::rlisp/interrupt (process-remote-thread p)))
    108108
    109 (defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))
    110   (hemlock-ext:top-listener-output-stream))
    111 
    112 (defmethod ccl::input-stream-for-remote-lisp ((app cocoa-application))
    113   (hemlock-ext:top-listener-input-stream))
     109(defmethod ccl::wait-for-toplevel-form ((stream cocoa-listener-input-stream))
     110  (with-slots (read-lock queue-lock queue queue-semaphore text-semaphore) stream
     111    (with-lock-grabbed (read-lock)
     112      (assert (with-slots (cur-sstream) stream (null cur-sstream)))
     113      (loop
     114        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
     115        (without-interrupts ;; yes, we're screwed if an interrupt happens just before, oh well.
     116         (with-lock-grabbed (queue-lock)
     117           (let ((val (car queue)))
     118             (unless (and (stringp val) (every #'whitespacep val))
     119               (signal-semaphore queue-semaphore) ;; return it.
     120               (return t)))
     121           (pop queue)))))))
    114122
    115123(defmethod ccl::toplevel-form-text ((stream cocoa-listener-input-stream))
     
    117125    (with-lock-grabbed (read-lock)
    118126      (assert (with-slots (cur-sstream) stream (null cur-sstream)))
    119       (wait-on-semaphore queue-semaphore nil "Toplevel Read")
    120       (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
    121         (cond ((stringp val) ;; listener input
    122                (assert (with-slots (text-semaphore) stream
    123                          (timed-wait-on-semaphore text-semaphore 0))
    124                        ()
    125                        "text/queue mismatch!")
    126                (values val nil t))
    127               (t
    128                ;; TODO: this is bogus, the package may not exist on this side, so must be a string,
    129                ;; but we can't bind *package* to a string.  So this assumes the caller will know
    130                ;; not to progv the env.
    131                (destructuring-bind (string package-name pathname offset) val ;; queued form
    132                  (declare (ignore offset))
    133                  (let ((env (cons '(*loading-file-source-file*)
    134                                   (list pathname))))
    135                    (when package-name
    136                      (push '*package* (car env))
    137                      (push package-name (cdr env)))
    138                    (values string env)))))))))
     127      (loop
     128        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
     129        (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
     130          (cond ((stringp val) ;; listener input
     131                 (assert (with-slots (text-semaphore) stream
     132                           (timed-wait-on-semaphore text-semaphore 0))
     133                         ()
     134                         "text/queue mismatch!")
     135                 (unless (every #'whitespacep val)
     136                   (return (values val nil t))))
     137                (t
     138                 ;; TODO: this is bogus, the package may not exist on this side, so must be a string,
     139                 ;; but we can't bind *package* to a string.  So this assumes the caller will know
     140                 ;; not to progv the env.
     141                 (destructuring-bind (string package-name pathname offset) val ;; queued form
     142                   (declare (ignore offset))
     143                   (let ((env (cons '(*loading-file-source-file*)
     144                                    (list pathname))))
     145                     (when package-name
     146                       (push '*package* (car env))
     147                       (push package-name (cdr env)))
     148                     (return (values string env)))))))))))
  • trunk/source/level-1/l1-boot-2.lisp

    r15104 r15105  
    354354      (bin-load-provide "CORE-FILES" "core-files")
    355355      (bin-load-provide "DOMINANCE" "dominance")
     356      (bin-load-provide "SWANK-LOADER" "swank-loader")
    356357      (bin-load-provide "REMOTE-LISP" "remote-lisp")
    357358      (bin-load-provide "MCL-COMPAT" "mcl-compat")
  • trunk/source/lib/compile-ccl.lisp

    r15104 r15105  
    232232    core-files
    233233    dominance
     234    swank-loader
    234235    remote-lisp
    235236    ;; asdf has peculiar compile-time side-effects
  • trunk/source/lib/swink.lisp

    r15104 r15105  
    291291(defmethod make-new-thread ((conn connection) &optional (process *current-process*))
    292292  (with-connection-lock (conn)
    293     (assert (not (find-thread conn process)))
     293    (assert (not (find-thread conn process :key #'thread-process)))
    294294    (let ((thread (make-instance (thread-class conn) :connection conn :process process)))
    295295      (push thread (connection-threads conn))
     
    424424                  (with-swink-lock ()
    425425                    (remf *listener-sockets* info)))))))
    426     (log-event "Swink awaiting ~s instructions on ~s" external-format socket)
     426    (log-event "Swink awaiting ~s instructions on port ~s ~s" external-format local-port socket)
    427427    local-port))
    428428
     
    517517                                           (signal-semaphore return-signal))))
    518518            (send-event conn `(:read-string ,thread ,tag))
    519             (let ((current-thread (find-thread conn *current-process*)))
    520               (if current-thread ;; we're running in a repl, process events while waiting.
    521                 (with-event-handling (current-thread)
    522                   (wait-on-semaphore return-signal))
    523                 (wait-on-semaphore return-signal)))
     519
     520            (let ((current-thread (find-thread conn *current-process* :key #'thread-process)))
     521              (with-interrupts-enabled
     522                  (if current-thread ;; we're running in a repl, process events while waiting.
     523                    (with-event-handling (current-thread)
     524                      (wait-on-semaphore return-signal))
     525                    (wait-on-semaphore return-signal))))
    524526            returned-string)
    525527        (unless returned-string
  • trunk/source/lib/systems.lisp

    r15104 r15105  
    228228    (core-files       "ccl:bin;core-files"       ("ccl:library;core-files.lisp"))
    229229    (dominance        "ccl:bin;dominance"        ("ccl:library;dominance.lisp"))
    230     (remote-lisp      "ccl:bin;remote-lisp"    ("ccl:library;remote-lisp.lisp"))
     230    (swank-loader     "ccl:bin;swank-loader"     ("ccl:library;swank-loader.lisp"))   
     231    (remote-lisp      "ccl:bin;remote-lisp"      ("ccl:library;remote-lisp.lisp" "ccl:lib;swink.lisp"))
    231232 
    232233    (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp"))
  • trunk/source/library/remote-lisp.lisp

    r15065 r15105  
    2020;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2121;;
    22 ;; Client-side remote lisp support
     22;; swink client -- use this ccl to debug a remote ccl.
    2323;;
    2424;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    2525
    26 ;; (export '(remote-lisp-thread remote-listener-function toplevel-form-text))
    27 
    28 (defclass remote-lisp-connection ()
    29   ((lock :initform (make-lock) :reader rlisp-lock)
    30    (server-process :initform nil :accessor rlisp-server-process)
    31    (object-counter :initform most-negative-fixnum :accessor rlisp-object-counter)
    32    (objects :initform () :accessor rlisp-objects)
    33    (threads :initform () :accessor rlisp-threads)
    34 
    35    (features :initform nil :accessor rlisp-features)
     26(defclass remote-lisp-connection (swink:connection)
     27  ((features :initform nil :accessor rlisp-features)
    3628   (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type)
    3729   (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version)
    3830   (machine-instance :initform "???" :accessor rlisp-machine-instance)))
    3931
    40 (defmacro with-rlisp-lock ((conn &rest args) &body body)
    41   `(with-lock-grabbed ((rlisp-lock ,conn) ,@args)
    42      (without-interrupts ;; without callbacks
    43       ,@body)))
     32(defmethod swink:thread-id ((conn remote-lisp-connection)) nil)
    4433
    4534(defmethod update-rlisp-connection-info ((conn remote-lisp-connection)
     
    4736                                              lisp-implementation-version
    4837                                              machine-instance
    49                                               (features nil featuresp))
    50   (with-rlisp-lock (conn)
     38                                              (features nil featuresp)
     39                                         &allow-other-keys)
     40  (swink:with-connection-lock (conn)
    5141    (when featuresp
    5242      (setf (rlisp-features conn) features))
     
    5848      (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version))))
    5949
    60 (defun register-rlisp-object (conn object)
    61   (with-rlisp-lock (conn)
    62     (let* ((id (incf (rlisp-object-counter conn))))
    63       (push (cons id object) (rlisp-objects conn))
    64       id)))
    65 
    66 (defun find-rlisp-object (conn id)
    67   (with-rlisp-lock (conn)
    68     (let ((cell (assoc id (rlisp-objects conn))))
    69       (unless cell
    70         (warn "Missing remote object ~s" id))
    71       (setf (rlisp-objects conn) (delq cell (rlisp-objects conn)))
    72       (cdr cell))))
    73 
    74 (defun remove-rlisp-object (conn id)
    75   (with-rlisp-lock (conn)
    76     (setf (rlisp-objects conn) (delete id (rlisp-objects conn) :key #'car))))
    77 
    78 (defun register-rlisp-callback (conn callback)
    79   (register-rlisp-object conn (cons callback *current-process*)))
    80 
    81 ;; Invoke callback in the process that registered it.
    82 (defun invoke-rlisp-callback (conn id &rest values)
    83   (declare (dynamic-extent values))
    84   (destructuring-bind (callback . process) (or (find-rlisp-object conn id) '(nil . nil))
    85     (when callback
    86       (apply #'process-interrupt process callback values))))
    87 
    88 (defclass remote-lisp-thread ()
    89   ((conn :initarg :connection :reader rlisp-thread-connection)
    90    ;; Local process running the local repl: interacting with user, sending to remote for execution.
    91    (thread-process :initform nil :accessor rlisp-thread-process)
    92    (break-level :initform nil :accessor rlisp-thread-break-level)
    93    ;; Id of remote process doing the evaluation for the local process.
    94    (thread-id :initarg :thread-id :reader rlisp-thread-id)
    95    (event-queue :initform nil :accessor rlisp-thread-event-queue)))
     50;; Proxy for a thread on the remote server.
     51(defclass remote-lisp-thread (swink:thread)
     52  (;; Local process running the local repl: interacting with user, sending to remote for execution.
     53   ;;    (the swink:thread-process slot has thread-id of the remote process)
     54   (control-process :initform nil :accessor swink:thread-control-process)
     55   (break-level :initform nil :accessor rthread-break-level)))
     56
     57(defmethod swink:thread-class ((conn remote-lisp-connection)) 'remote-lisp-thread)
    9658
    9759(defmethod rlisp-host-description ((rthread remote-lisp-thread))
    98   (rlisp-host-description (rlisp-thread-connection rthread)))
     60  (rlisp-host-description (swink:thread-connection rthread)))
    9961
    10062(defmethod print-object ((rthread remote-lisp-thread) stream)
     
    10264    (format stream "~a thread ~a"
    10365            (rlisp-host-description rthread)
    104             (rlisp-thread-id rthread))))
    105 
    106 (defmethod rlisp-thread-id ((thread-id integer)) thread-id)
    107 
    108 (defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
    109 
    110 (defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread) &key (create t))
    111   (declare (ignore create))
    112   thread)
    113 
    114 (defmethod rlisp-thread ((conn remote-lisp-connection) (id integer) &key (create t))
    115   (with-rlisp-lock (conn)
    116     (or (find id (rlisp-threads conn) :key #'rlisp-thread-id)
    117         (and create
    118              (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id)))
    119                (push rthread (rlisp-threads conn))
    120                rthread)))))
    121 
    122 (defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &key (create nil))
    123   (with-rlisp-lock (conn)
    124     (or (find process (rlisp-threads conn) :key #'rlisp-thread-process)
    125         (and create
    126              (assert (not create))))))
    127 
    128 (defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
    129   (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
    130 
    131 (defmethod rlisp/toplevel ((rthread remote-lisp-thread) &key)
    132   (rlisp/toplevel (rlisp-thread-connection rthread) :thread rthread))
    133 
    134 (defmethod rlisp/execute ((rthread remote-lisp-thread) form continuation &key)
    135   (rlisp/execute (rlisp-thread-connection rthread) form continuation :thread rthread))
    136 
    137 (defmethod rlisp/interrupt ((rthread remote-lisp-thread) &key)
    138   (rlisp/interrupt (rlisp-thread-connection rthread) :thread rthread))
    139 
    140 (defmethod remote-listener-eval ((rthread remote-lisp-thread) text &rest keys &key &allow-other-keys)
    141   (apply #'remote-listener-eval (rlisp-thread-connection rthread) text :thread rthread keys))
    142 
    143 (defclass swank-rlisp-connection (remote-lisp-connection)
    144   (
    145    ;; The socket to the swank server.  Only the connection process reads from it, without locking.
    146    ;;  Anyone can write, but should grab the connection lock.
    147    (command-stream :initarg :stream :reader swank-command-stream)
    148    (read-buffer :initform (make-array 1024 :element-type 'character) :accessor swank-read-buffer)))
    149 
    150 (defmethod rlisp-host-description ((conn swank-rlisp-connection))
    151   (let ((socket (swank-command-stream conn)))
     66            (swink:thread-id rthread))))
     67
     68(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name)
     69  (swink:send-event rthread `(:invoke-restart ,name)))
     70
     71(defmethod rlisp/toplevel ((rthread remote-lisp-thread))
     72  (swink:send-event rthread `(:toplevel)))
     73
     74(defmethod rlisp/interrupt ((rthread remote-lisp-thread))
     75  (swink:send-event rthread `(:interrupt)))
     76
     77(defmethod rlisp-host-description ((conn remote-lisp-connection))
     78  (let ((socket (swink:connection-control-stream conn)))
    15279    (if (open-stream-p socket)
    15380      (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket))
    15481      ":CLOSED")))
    15582
    156 (defmethod print-object ((conn swank-rlisp-connection) stream)
     83(defmethod print-object ((conn remote-lisp-connection) stream)
    15784  (print-unreadable-object (conn stream :type t :identity t)
    15885    (format stream "~a @~a"
     
    16188
    16289
    163 (defmethod start-rlisp-server ((conn swank-rlisp-connection))
    164   ;; TODO: Make sure closing the connection kills the process or vice versa.
    165   (assert (null (rlisp-server-process conn)))
    166   (flet ((swank-event-loop (conn)
    167            (setf (rlisp-server-process conn) *current-process*)
    168            (loop
    169              (let ((sexp (read-swank-event conn)))
    170                (handle-swank-event conn (car sexp) (cdr sexp))))))
    171     (setf (rlisp-server-process conn)
    172           (process-run-function (format nil "swank-event-loop ~a" (remote-port (swank-command-stream conn)))
    173                                 #'swank-event-loop conn)))
    174   (let ((sem (make-semaphore)) (abort nil))
    175     ;; Patch up swank.  To be replaced someday by our own set of remote functions...
    176     ;; TODO: advise send-to-emacs to intercept :write-string  and add in the thread id.
    177     (rlisp/execute conn
    178                    "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
    179                      (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::RDEBUG-SPAWN-REPL-THREAD CONN NAME))
    180                      (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-INVOKE-DEBUGGER CONN))
    181                      (CCL:ADVISE SWANK::DISPATCH-EVENT
    182                                  (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
    183                                            (COMMAND (CL:CAR EVENT)))
    184                                    (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :RETURN :EMACS-INTERRUPT
    185                                                                          :EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING
    186                                                                          :EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR))
    187                                      (:DO-IT)
    188                                      (SWANK::ENCODE-MESSAGE EVENT (SWANK::CURRENT-SOCKET-IO))))
    189                                  :WHEN :AROUND
    190                                  :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES
    191                                  :DYNAMIC-EXTENT-ARGLIST CL:T)
    192                      (CCL:ADVISE SWANK::SEND-TO-EMACS
    193                                  (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
    194                                            (COMMAND (CL:CAR EVENT)))
    195                                    (CL:WHEN (CL:EQ COMMAND :WRITE-STRING)
    196                                       (CL:SETF (CL:CDDR EVENT) (CL:LIST (SWANK::CURRENT-THREAD-ID)))))
    197                                  :WHEN :BEFORE
    198                                  :NAME CCL::SEND-THREAD-WITH-WRITE-STRING)
    199                      (CL:DEFUN SWANK::SIMPLE-BREAK ()
    200                        (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS*))
    201                      (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATION*)
    202                                (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :CONNECTION SWANK::*EMACS-CONNECTION*))
    203 
    204                      (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:NIL) ;; let it go thru to break.
    205 
    206                      (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::RDEBUG-FIND-REPL-THREAD)
    207 
    208                      (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL)
    209                        (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN
    210                                                ,(SWANK::CURRENT-THREAD-ID) ,LEVEL ,SWANK::*SLDB-STEPPING-P*))
    211                        (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL)) CL:T)
    212                        (CL:WHEN (CL:> LEVEL 1)
    213                          (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLDB-RETURN ,LEVEL))))
    214 
    215                      (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
    216                        (SWANK::CREATE-REPL ()) ;; set up connection.env with redirect threads.
    217                        (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
    218                          (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
    219                          (SWANK::THREAD-ID THREAD)))
    220                      CL:T)"
    221                    (lambda (error result)
    222                      (declare (ignore result))
    223                      (when error
    224                        (unwind-protect
    225                            (error "Error initializing SWANK: ~s" error)
    226                          (setq abort t)
    227                          (signal-semaphore sem)))
    228                      (signal-semaphore sem)))
    229     (wait-on-semaphore sem)
    230     ;; TODO: should at least kill server process.
    231     (when abort (return-from start-rlisp-server nil))
    232     (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
    233                    (lambda (error info)
    234                      (unless error
    235                        (destructuring-bind (&key (features nil featuresp)
    236                                                  machine
    237                                                  lisp-implementation
    238                                                  &allow-other-keys) info
    239                          (let ((args nil))
    240                            (when featuresp
    241                              (setq args (list* :features features args)))
    242                            (when (consp machine)
    243                              (destructuring-bind (&key instance &allow-other-keys) machine
    244                                (setq args (list* :machine-instance instance args))))
    245                            (when (consp lisp-implementation)
    246                              (destructuring-bind (&key type version &allow-other-keys) lisp-implementation
    247                                (setq args (list* :lisp-implementation-type type
    248                                                  :lisp-implementation-version version
    249                                                  args))))
    250                            (when args
    251                              (apply #'update-rlisp-connection-info conn args)))))
    252                      (signal-semaphore sem)))
    253     (wait-on-semaphore sem)
    254     conn))
    255 
    256 (defmethod output-stream-for-remote-lisp ((app application))
    257   *standard-output*)
    258 
    259 (defmethod input-stream-for-remote-lisp ((app application))
    260   *standard-input*)
    261 
    262 (defun process-output-stream (process)
    263   (let ((stream (symbol-value-in-process '*standard-output* process)))
    264     (loop
    265       (typecase stream
    266         (synonym-stream
    267          (setq stream (symbol-value-in-process (synonym-stream-symbol stream) process)))
    268         (two-way-stream
    269          (setq stream (two-way-stream-output-stream stream)))
    270         (t (return stream))))))
    271 
    272 (defvar *signal-swank-events* nil)
    273 
    274 (define-condition swank-events () ())
    275 
    276 (defmacro with-swank-events ((rthread &key abort) &body body)
    277   (let ((rthread-var (gensym "RTHREAD")))
    278     (if abort
    279       ;; When body is no re-entrant, abort it before handling the event.
    280       `(let ((,rthread-var ,rthread))
    281          (loop
    282            (handler-case (return (let ((*signal-swank-events* t))
    283                                    (when (rlisp-thread-event-queue ,rthread-var)
    284                                      (let ((*signal-swank-events* nil))
    285                                        (handle-swank-events ,rthread-var)))
    286                                    ,@body))
    287              (swank-events () (let ((*signal-swank-events* nil))
    288                                 (handle-swank-events rthread))))))
    289       `(let ((,rthread-var ,rthread))
    290          (handler-bind ((swank-events (lambda (c)
    291                                         (declare (ignore c))
    292                                         (handle-swank-events ,rthread-var))))
    293            (let ((*signal-swank-events* t))
    294              (when (rlisp-thread-event-queue ,rthread-var)
    295                (let ((*signal-swank-events* nil))
    296                  (handle-swank-events ,rthread-var)))
    297              ,@body))))))
    298 
    299 (defun signal-swank-event (rthread event args)
    300   (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
    301     (setf (rlisp-thread-event-queue rthread)
    302           (nconc (rlisp-thread-event-queue rthread) (list `(,event ,@args)))))
    303   (process-interrupt (or (rlisp-thread-process rthread)
    304                          (error "Got event ~s ~s for thread ~s with no process" event args rthread))
    305                      (lambda ()
    306                        (when *signal-swank-events*
    307                          (let ((*signal-swank-events* nil))
    308                            (signal 'swank-events))))))
    309 
    310 (defun handle-swank-events (rthread)
    311   (loop for event = (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, not worth a separate lock
    312                       (pop (rlisp-thread-event-queue rthread)))
    313     while event do (handle-swank-event rthread (car event) (cdr event))))
    314 
    315 (defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
    316   (case event
    317     (:return
    318      (destructuring-bind (value id) args
    319        (when id (invoke-rlisp-callback conn id value))))
    320     (:invalid-rpc
    321      (destructuring-bind (id message) args
    322        (when id (remove-rlisp-object conn id))
    323        (error "Invalid rpc: ~s" message)))
    324     (:enter-break ;; Starting a new repl (possibly due to an error in a non-repl process)
    325      ;; For now, this is assumed to create the listener before processing another command, so
    326      ;; the remote can send commands to it right away.
    327      ;; If that becomes a problem, can make a protocol so the other side will explicitly wait,
    328      ;; and then we can spawn off a worker thread to do this.
    329      (destructuring-bind (thread-id break-level) args
    330        (let ((rthread (rlisp-thread conn thread-id)))
    331          (enter-rlisp-listener rthread break-level)
    332          ;; TODO: this isn't really right.  Need to wait for process context to be set up.  Perhaps
    333          ;; make sure thread-process is not set until the process is running in full context.
    334          (process-wait "REPL startup" #'rlisp-thread-process rthread)
    335          ;(signal-swank-event rthread event (cdr args))
    336          )))
    337     (:exit-break
    338      (destructuring-bind (thread-id) args
    339        (let ((rthread (rlisp-thread conn thread-id)))
    340          (when (and rthread (rlisp-thread-process rthread))
    341            (exit-rlisp-listener rthread)))))
    342     ((:read-loop :values :debug-return :debug-condition :read-aborted)
    343      ;; TODO: this needs to make sure the process is in the right dynamic state (with all restarts established etc)
    344      ;;  Need our own interrupt queue, with-event-handling macro...
    345      (destructuring-bind (thread-id &rest event-args) args
    346        (let ((rthread (rlisp-thread conn thread-id)))
    347          (signal-swank-event rthread event event-args))))
    348     (:new-features
    349      (destructuring-bind (features) args
    350        (update-rlisp-connection-info conn :features features)))
    351     (:indentation-update
    352      (destructuring-bind (name-indent-alist) args
    353        (declare (ignore name-indent-alist))))
    354     ;; TODO: make the i/o streams be thread-specific, so we know which listener to use even if some other
    355     ;; thread is doing the i/o.  I.e. this should send a thread id of the owner of the stream, not of the
    356     ;; thread that happens to write it, so it will always be a listener thread.
    357     (:write-string
    358      (destructuring-bind (string thread-id) args
    359        (let* ((rthread (rlisp-thread conn thread-id :create nil))
    360               (stream (if (and rthread (rlisp-thread-process rthread))
    361                         (process-output-stream (rlisp-thread-process rthread))
    362                         (output-stream-for-remote-lisp *application*))))
    363          (if (> (length string) 500)
    364            (process-run-function "Long Remote Output" #'write-string string stream)
    365            (write-string string stream)))))
    366     (:ping ;; flow control for output
    367      (destructuring-bind (thread-id tag) args
    368        ;; TODO: I guess we're supposed to wait til the previous output is finished or something.
    369        (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag))))
    370     (:read-string
    371      (destructuring-bind (thread-id tag) args
    372        (let ((rthread (rlisp-thread conn thread-id :create nil)))
    373          (if (and rthread (rlisp-thread-process rthread))
    374            (signal-swank-event rthread event (cdr args))
    375            ;; not a listener thread.
    376            ;; TODO: this needs to be wrapped in some error handling.
    377            (process-run-function (format nil "Remote Input (~s)" thread-id)
    378                                  #'rlisp-read-string
    379                                  conn
    380                                  (input-stream-for-remote-lisp *application*)
    381                                  thread-id
    382                                  tag)))))
    383     (t (warn "Received unknown event ~s with args ~s" event args))))
    384 
    385 
     90(defmethod start-rlisp-process ((conn remote-lisp-connection))
     91  (assert (null (swink:connection-control-process conn)))
     92  (setf (swink:connection-control-process conn)
     93        (process-run-function (format nil "swank-event-loop ~a" (remote-port (swink:connection-control-stream conn)))
     94          (lambda ()
     95            (setf (swink:connection-control-process conn) *current-process*)
     96            (with-simple-restart (swink:close-connection "Close connection")
     97              (loop (dispatch-event conn (swink:read-sexp conn)))))))
     98  (let ((info (send-event-for-value conn `(:connection-info))))
     99    (when info
     100      (apply #'update-rlisp-connection-info conn info)))
     101  conn)
     102
     103
     104(defmethod dispatch-event ((conn remote-lisp-connection) thread.event)
     105  (swink::log-event "Dispatch-event ~s" thread.event)
     106  (destructuring-bind (sender-id . event) thread.event
     107    (swink:destructure-case event
     108      ((:end-connection condition)
     109       (declare (ignore condition))
     110       (swink:close-connection conn))
     111      ((:start-repl break-level)
     112       ;; Starting a new repl (possibly due to an error in a non-repl process)
     113       (let ((rthread (swink:make-new-thread conn sender-id)))
     114         (start-remote-listener rthread break-level)))
     115      ((:exit-repl)
     116       (let ((rthread (swink:find-thread conn sender-id)))
     117         (when (and rthread (swink:thread-control-process rthread))
     118           (exit-remote-listener rthread))))
     119      ((:return local-tag &rest values)
     120       ;; Note this interrupts the process rather than going through the event mechanism,
     121       ;; the caller has to set up the callback environment before sending the request.
     122       (when local-tag
     123         (apply #'swink:invoke-callback conn local-tag values)))
     124      ((:cancel-return local-tag)
     125       (when local-tag
     126         (let ((process (cdr (swink:tagged-object conn local-tag)))) ;; this removes the tag.
     127           (when process
     128             (process-interrupt process (lambda () (signal 'rlisp-cancel-return :tag local-tag)))))))
     129      (((:read-string :abort-read :write-string) stream-thread-id &rest args)
     130       ;; Do I/O stuff in the stream listener process, not the caller's listener
     131       ;; process (which might not even exist)
     132       (let ((stream-listener (swink:find-thread conn stream-thread-id)))
     133         (if stream-listener
     134           (swink:signal-event stream-listener (cons (car event) args))
     135           (warn "Missing listener for ~s" event))))
     136      (t (let ((thread (swink:find-thread conn sender-id)))
     137           (when thread
     138             (swink:signal-event thread event)))))))
     139
     140(define-condition rlisp-cancel-return ()
     141  ((tag :initarg :tag :reader rlisp-cancel-return-tag)))
    386142
    387143(define-condition rlisp-read-aborted ()
    388144  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
    389145
    390 (defun rlisp-read-string (conn stream thread-id tag)
     146(defun rlisp-read-string (rthread tag)
    391147  (handler-bind ((rlisp-read-aborted (lambda (c)
    392148                                       (when (eql tag (rlisp-read-aborted-tag c))
    393149                                         (return-from rlisp-read-string)))))
    394     (peek-char t stream) ;; wait for first one, error if none.
    395     (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
    396                      (read-available-text stream))))
    397       (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,text)))))
    398 
    399 (defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
    400   (assert (eq (rlisp-thread-process rthread) *current-process*))
    401   (ecase event
    402     (:read-string
    403      (destructuring-bind (tag) args
    404        (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
    405     (:read-aborted  ;; huh?
    406      (destructuring-bind (tag) args
    407        (signal 'rlisp-read-aborted :tag tag)))
    408     (:read-loop ;; enter (or re-enter after an abort) a break loop.
    409      (destructuring-bind (level) args
    410        (when (eql level *break-level*) ;; restart at same level, aborted current expression.
    411          (invoke-restart 'debug-restart level))
    412        (unless (eql level (1+ *break-level*))
    413          (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
    414        ;(format t "~&Error: ~a" condition-text)
    415        ;(when *show-restarts-on-break*
    416        ;  (format t "~&Remote restarts:")
    417        ;  (loop for (name description) in restarts
    418        ;    do (format t "~&~a ~a" name description))
    419        ;  (fresh-line))
    420        (rlisp-read-loop rthread :break-level level)))
    421      (:debug-condition ;; This seems to have something to do with errors in the debugger
    422          (destructuring-bind (message) args
    423            (format t "~&Swank error: ~s" message)))
    424      (:debug-return ;; return from level LEVEL read loop
    425       (destructuring-bind (level stepping-p) args
    426         (declare (ignore stepping-p))
    427         (invoke-restart 'debug-return level)))
    428      (:values ;; intermediate values when multiple forms in selection.
    429       (destructuring-bind (values) args
    430         (when values
    431           (fresh-line)
    432           (dolist (val values) (write val) (terpri)))
    433         (force-output)
    434         (print-listener-prompt *standard-output*)))))
    435 
    436 
    437 ;; This assumes connection process is the only thing that reads from the socket stream and uses
    438 ;; the read-buffer, so don't need locking.
    439 (defun read-swank-event (conn)
    440   (assert (eq (rlisp-server-process conn) *current-process*))
    441   (let* ((stream (swank-command-stream conn))
    442          (buffer (swank-read-buffer conn)))
    443     (multiple-value-bind (form updated-buffer) (read-remote-event stream buffer)
    444       (unless (eq updated-buffer buffer)
    445         (setf (swank-read-buffer conn) updated-buffer))
    446       form)))
    447 
    448 (defun read-remote-event (stream &optional buffer)
    449   (let* ((header (or buffer (make-string 6)))
    450          (count (stream-read-vector stream header 0 6)))
    451     (when (< count 6) (signal-eof-error stream))
    452     (setq count (parse-integer header :end 6 :radix 16))
    453     (assert (> count 0))
    454     (when (< (length buffer) count)
    455       (setq buffer (make-string count)))
    456     (let ((len (stream-read-vector stream buffer 0 count)))
    457       (when (< len count) (signal-eof-error stream))
    458       ;; TODO: check that there aren't more forms in the string.
    459       (values (handler-case
    460                   (with-standard-io-syntax
    461                       (let ((*package* +swank-io-package+)
    462                             (*read-eval* nil))
    463                         (read-from-string buffer t nil :end count)))
    464                 (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c)))
    465               buffer))))
    466 
    467 (defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
    468   (let* ((semaphore (make-semaphore))
    469          (return-error nil)
    470          (return-id nil))
    471     (rlisp/execute conn (format nil "(CCL::MAKE-SWANK-REPL-FOR-IDE ~s)" name)
    472                    (lambda (error id)
    473                      (setf return-error error)
    474                      (setq return-id id)
    475                      (signal-semaphore semaphore)))
    476     (wait-on-semaphore semaphore)
    477     (when return-error
    478       (error "Remote eval error ~s" return-error))
    479     (rlisp-thread conn return-id)))
    480 
    481 ;; TODO: "coding-system".
    482 (defun connect-to-swank (host port &key (secret-file "home:.slime-secret"))
     150    (let ((text (and (swink:with-event-handling (rthread :restart t)
     151                       (peek-char nil *standard-input* nil)) ;; wait for first one, nil means eof
     152                     (read-available-text *standard-input*))))
     153      (swink:send-event (swink:thread-connection rthread) `(:return ,tag ,text)))))
     154
     155(defun send-event-for-value (target event &key (semaphore (make-semaphore)))
     156  (let* ((return-values nil)
     157         (conn (etypecase target
     158                 (remote-lisp-connection target)
     159                 (remote-lisp-thread (swink:thread-connection target))))
     160         (tag (swink:tag-callback conn
     161                                  (lambda (&rest values)
     162                                    (setq return-values values)
     163                                    (signal-semaphore semaphore))))
     164         (event-with-callback `(,@event ,tag)))
     165    (handler-bind ((rlisp-cancel-return
     166                    ;; This is called if the call got aborted for any reason, so we can clean up.
     167                    (lambda (c)
     168                      (when (eq (rlisp-cancel-return-tag c) tag)
     169                        (signal-semaphore semaphore)))))
     170      (swink:send-event target event-with-callback)
     171      (if (eq target conn)
     172        (wait-on-semaphore semaphore)
     173        (swink:with-event-handling (target)
     174          (wait-on-semaphore semaphore)))
     175      (apply #'values return-values))))
     176
     177(defmethod swink:handle-event ((rthread remote-lisp-thread) event)
     178  (assert (eq (swink:thread-control-process rthread) *current-process*))
     179  (swink::log-event "Handle-event in thread ~s: ~s" (swink:thread-id rthread) event)
     180  (swink:destructure-case event
     181    ((:read-string remote-tag)
     182     (rlisp-read-string rthread remote-tag))
     183    ((:abort-read remote-tag)
     184     (signal 'rlisp-read-aborted :tag remote-tag))
     185    ((:write-string string)
     186     (write-string string))
     187    ((:read-loop level) ;; enter (or re-enter after an abort) a break loop.
     188     (when (eql level *break-level*) ;; restart at same level, aborted current expression.
     189       (invoke-restart 'debug-restart level))
     190     (unless (eql level (1+ *break-level*))
     191       (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *break-level*)))
     192     ;(format t "~&Error: ~a" condition-text)
     193     ;(when *show-restarts-on-break*
     194     ;  (format t "~&Remote restarts:")
     195     ;  (loop for (name description) in restarts
     196     ;    do (format t "~&~a ~a" name description))
     197     ;  (fresh-line))
     198     (rlisp-read-loop rthread :break-level level))
     199    ((:debug-return level) ;; return from level LEVEL read loop
     200     (invoke-restart 'debug-return level))))
     201
     202(defmethod make-rrepl-thread ((conn remote-lisp-connection) name)
     203  (swink:send-event conn `(:spawn-repl ,name)))
     204
     205(defun connect-to-swink (host port)
    483206  (let* ((socket (make-socket :remote-host host :remote-port port :nodelay t))
    484          (conn (make-instance 'swank-rlisp-connection :stream socket)))
    485     (when secret-file
    486       (with-open-file (stream secret-file :if-does-not-exist nil)
    487         (when stream
    488           (let ((secret (read-line stream nil nil)))
    489             (when secret
    490               (send-string-to-swank conn secret))))))
    491     (start-rlisp-server conn)))
    492 
    493 (defmethod close ((conn swank-rlisp-connection) &key abort)
     207         (conn (make-instance 'remote-lisp-connection :control-stream socket)))
     208    (start-rlisp-process conn)))
     209
     210(defmethod close ((conn remote-lisp-connection) &key abort)
    494211  ;; TODO: kill process.
    495   (close (swank-command-stream conn) :abort abort))
    496 
    497 (defun send-string-to-swank (conn string)
    498   (let ((stream (swank-command-stream conn)))
    499     (with-rlisp-lock (conn)
    500       (format stream "~6,'0,X" (length string))
    501       (write-string string stream))
    502     (force-output stream)))
    503 
    504 (defvar +swank-io-package+
    505   (loop as name = (gensym "SwankIO/") while (find-package name)
    506     finally (let ((package (make-package name :use nil)))
    507               (import '(nil t quote) package)
    508               (return package))))
    509 
    510 (defun send-sexp-to-swank (conn sexp)
    511   (send-string-to-swank conn (with-standard-io-syntax
    512                                  (let ((*package* +swank-io-package+))
    513                                    (prin1-to-string sexp)))))
    514 
    515 (defun format-for-swank (fmt-string fmt-args)
    516   (with-standard-io-syntax
    517       (let ((*package* +swank-io-package+))
    518         (apply #'format nil fmt-string fmt-args))))
    519 
    520 (defun thread-id-for-execute (thread)
    521   (typecase thread
    522     (null t) ;; don't care
    523     (remote-lisp-thread (rlisp-thread-id thread))
    524     (t thread)))
    525 
    526 
    527 ;; Continuation will be executed in the current process.
    528 (defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key thread)
    529   (flet ((continuation (result)
    530            (ecase (car result)
    531              (:ok (apply continuation nil (cdr result)))
    532              (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
    533     (let* ((sexp `(:emacs-rex ,form-or-string
    534                               nil
    535                               ,(thread-id-for-execute thread)
    536                               ,(and continuation (register-rlisp-callback conn #'continuation)))))
    537       (if (stringp form-or-string)
    538         (send-string-to-swank conn (format-for-swank "(~s ~a ~s ~s ~s)" sexp))
    539         (send-sexp-to-swank conn sexp)))))
    540 
    541 (defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
    542   ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
    543   ;; will normally not return, don't register a continuation for it.
    544   (rlisp/execute conn `(invoke-restart ',name) nil :thread thread))
    545 
    546 (defmethod rlisp/toplevel ((conn swank-rlisp-connection) &key thread)
    547   (rlisp/execute conn `(toplevel) nil :thread thread))
    548 
    549 (defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
    550   (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
     212  (close (swink:connection-control-stream conn) :abort abort))
    551213
    552214(defun read-available-text (stream)
     
    558220
    559221;; Return text for remote evaluation.
    560 (defmethod toplevel-form-text ((stream input-stream))
    561   (when (peek-char t stream nil) ;; wait for the first one.
    562     (read-available-text stream)))
    563 
     222(defmethod wait-for-toplevel-form ((stream input-stream)) (peek-char t stream nil))
     223(defmethod toplevel-form-text ((stream input-stream)) (read-available-text stream))
     224
     225(defmethod wait-for-toplevel-form ((stream synonym-stream))
     226  (wait-for-toplevel-form (symbol-value (synonym-stream-symbol stream))))
    564227(defmethod toplevel-form-text ((stream synonym-stream))
    565228  (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
    566229
     230(defmethod wait-for-toplevel-form ((stream two-way-stream))
     231  (if (typep stream 'echo-stream)
     232    (call-next-method)
     233    (wait-for-toplevel-form (two-way-stream-input-stream stream))))
    567234(defmethod toplevel-form-text ((stream two-way-stream))
    568235  (if (typep stream 'echo-stream)
     
    570237    (toplevel-form-text (two-way-stream-input-stream stream))))
    571238
     239
     240(defmethod start-remote-listener ((rthread remote-lisp-thread) break-level)
     241  (when (swink:thread-control-process rthread) (error "Attempting to re-enter active listener"))
     242  (setf (rthread-break-level rthread) break-level)
     243  (create-rlisp-listener *application* rthread)
     244  ;; This is running in the server control process.  Don't process any other events until
     245  ;; the thread actually starts up.
     246  (process-wait "REPL startup" #'swink:thread-control-process rthread))
     247
     248;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
     249(defmethod exit-remote-listener ((rthread remote-lisp-thread))
     250  (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener window
     251  (let ((process (swink:thread-control-process rthread)))
     252    (setf (swink:thread-control-process rthread) nil)
     253    (when process
     254      ;; This runs unwind-protects, which should clean up any streams
     255      (process-kill process))))
     256
    572257;; pass this as the initial-function in make-mcl-listener-process
    573258(defmethod remote-listener-function ((rthread remote-lisp-thread))
    574   (setf (rlisp-thread-process rthread) *current-process*)
     259  (setf (swink:thread-control-process rthread) *current-process*)
    575260  (unless (or *inhibit-greeting* *quiet-flag*)
    576     (let ((conn (rlisp-thread-connection rthread)))
     261    (let ((conn (swink:thread-connection rthread)))
    577262      (format t "~&Welcome to ~A ~A on ~A!"
    578263              (rlisp-lisp-implementation-type conn)
    579264              (rlisp-lisp-implementation-version conn)
    580265              (rlisp-machine-instance conn))))
    581   (rlisp-read-loop rthread :break-level (rlisp-thread-break-level rthread)))
    582 
    583 ;; This can be invoked when the connection dies or break-loop is exited in a non-repl process.
    584 (defmethod exit-rlisp-listener ((rthread remote-lisp-thread))
    585   (application-ui-operation *application* :deactivate-rlisp-listener rthread) ;; deactivate listener
    586   (let ((process (rlisp-thread-process rthread)))
    587     (setf (rlisp-thread-process rthread) nil)
    588     (process-kill process)))
    589 
    590 (defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level)
    591   (when (rlisp-thread-process rthread)
    592     (error "Attempting to re-enter active listener"))
    593   (setf (rlisp-thread-break-level rthread) break-level)
    594   ;; The process creation would be a little different
    595   (create-rlisp-listener *application* rthread))
     266  (rlisp-read-loop rthread :break-level (rthread-break-level rthread)))
    596267
    597268(defmethod create-rlisp-listener ((application application) rthread)
    598   (assert (null (rlisp-thread-process rthread)))
     269  (assert (null (swink:thread-control-process rthread)))
    599270  ;; see make-mcl-listener-process
    600271  (error "Not implemented yet"))
     
    607278    (unwind-protect
    608279        (loop
    609           (setf (rlisp-thread-break-level rthread) break-level)
     280          (setf (rthread-break-level rthread) break-level)
    610281          (restart-case
    611282              ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue.
     
    652323(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
    653324  (let* ((input-stream *standard-input*)
    654          (output-stream *standard-output*)
    655325         (sem (make-semaphore))
    656326         (eof-count 0))
    657327    (loop
    658       (force-output output-stream)
    659       (print-listener-prompt output-stream t)
    660 
    661       (multiple-value-bind (text env)
    662                            ;; Reading is not re-entrant so events during reading need
    663                            ;; to abort the read to be handled.
    664                            (with-swank-events (rthread  :abort t)
    665                              (toplevel-form-text input-stream))
     328      (force-output)
     329      (print-listener-prompt *standard-output* t)
     330     
     331      (swink:with-event-handling (rthread :restart t)
     332        (wait-for-toplevel-form input-stream))
     333      (multiple-value-bind (text env) (toplevel-form-text input-stream)
    666334        (if (null text) ;; eof
    667335          (progn
     
    679347            ;;      (if print-result (toplevel-print values)))
    680348            (let* ((package-name (loop for sym in (car env) for val in (cdr env)
    681                                   when (eq sym '*package*) do (return val)))
    682                    (values (remote-listener-eval rthread text :package package-name :semaphore sem)))
    683               (fresh-line output-stream)
    684               (dolist (val values) (princ val output-stream) (terpri output-stream)))))))))
    685 
    686 
    687 (defmethod remote-listener-eval ((conn swank-rlisp-connection) text
    688                                  &key package thread (semaphore (make-semaphore)))
    689   (assert thread)
    690   (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)"
    691                        text package
    692                        ;; This will send intermediate :values messages
    693                        (and *verbose-eval-selection* t)))
    694          (return-values nil))
    695     (rlisp/execute conn
    696                    form
    697                    (lambda (error values)
    698                      ;; Error just means evaluation was aborted but we don't yet know why.  We will
    699                      ;; be told to either restart a readloop or exit it.  Stay in semaphore wait
    700                      ;; until then.
    701                      (unless error
    702                        (setq return-values values)
    703                        (signal-semaphore semaphore)))
    704                    :thread thread)
    705     (with-swank-events (thread)
    706       (wait-on-semaphore semaphore))
    707     ;; a list of strings representing each return value
    708     return-values))
    709 
    710 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    711 ;;
    712 ;; Server-side: support for a remote debugger
    713 ;;
    714 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    715 
    716 
    717 ;;TODO: This is per application but we may want to allow multiple remote debuggers, and have this track
    718 ;; all connections.   See also process-ui-object.
    719 (defclass rdebug-ui-object (ui-object)
    720   ((connection :initarg :connection :accessor rdebug-ui-connection)))
    721 
    722 ;; Currently built on swank.
    723 
    724 (defun swankvar (name &optional (package :swank))
    725   (symbol-value (find-symbol name package)))
    726 
    727 (defun (setf swankvar) (value name &optional (package :swank))
    728   (let ((sym (find-symbol name package)))
    729     (if (null sym)
    730       (warn "Couldn't find ~a::~a" package name)
    731       (set sym value))))
    732 
    733 (defun swankfun (name &optional (package :swank))
    734   (symbol-function (find-symbol name package)))
    735 
    736 #-bootstrapped
    737 (declaim (special *read-loop-function*))
    738 
    739 (defun rdebug-send (event)
    740   (funcall (swankfun "SEND-TO-EMACS")
    741            (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD-ID") x) x)) event)))
    742 
    743 (defun rdebug-listener-eval (string package-name verbose-eval-selection)
    744   (if package-name
    745     (let ((*package* (or (find-package package-name) *package*)))
    746       (rdebug-listener-eval string nil verbose-eval-selection))
    747     (with-input-from-string (sstream string)
    748       (let ((values nil))
    749         (loop
    750           (let ((form (read-toplevel-form sstream :eof-value sstream)))
    751             (when (eq form sstream)
    752               (finish-output)
    753               (return values))
    754             (when verbose-eval-selection
    755               (rdebug-send `(:values ,*current-process* ,values)))
    756             ;; there is more.
    757             (unless (check-toplevel-command form)
    758               ;; TODO: toplevel-eval checks package change and invokes application-ui-operation, need to send that back.
    759               (setq values (toplevel-eval form nil))
    760               (setq /// // // / / values)
    761               (unless (eq (car values) (%unbound-marker))
    762                 (setq *** ** ** * *  (%car values)))
    763               (setq values (mapcar #'write-to-string values)))))))))
    764 
    765 (defun rdebug-spawn-repl-thread (conn name)
    766   (process-run-function name
    767                         (lambda ()
    768                           (funcall (swankfun "CALL-WITH-CONNECTION") conn
    769                                    (lambda ()
    770                                      (rdebug-send `(:enter-break ,*current-process* 0))
    771                                      (let ((*read-loop-function* 'rdebug-read-loop)
    772                                            (*debugger-hook* nil)
    773                                            (*break-hook* nil))
    774                                        (unwind-protect
    775                                            (toplevel-loop)
    776                                          (rdebug-send `(:exit-break ,*current-process*)))))))))
    777 
    778 ;; Debugger invoked in a non-repl process.  This is called with all swank stuff already set up.
    779 (defun rdebug-invoke-debugger (condition)
    780    (when (eq *read-loop-function* 'rdebug-read-loop)
    781       (return-from rdebug-invoke-debugger))
    782     (rdebug-send `(:enter-break ,*current-process* 1))
    783     (unwind-protect
    784         (let ((*read-loop-function* 'rdebug-read-loop)
    785               (*debugger-hook* nil)
    786               (*break-hook* nil))
    787           (%break-message *break-loop-type* condition)
    788           ;; Like toplevel-loop but run break-loop to set up error context before going into read-loop
    789           (loop
    790             (catch :toplevel
    791               (break-loop condition))
    792             (when (eq *current-process* *initial-process*)
    793               (toplevel))))
    794       (rdebug-send `(:exit-break ,*current-process*))))
    795 
    796 
    797 ;; swank-like read loop except with all the standard ccl restarts and catches.
    798 ;; TODO: try to make the standard read-loop customizable enough to do this so don't have to replace it.
    799 (defun rdebug-read-loop (&key (break-level 0) &allow-other-keys)
    800   ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that won't do anything even if those
    801   ;; are set to something non-standard, since swank doesn't hang its protocol on the streams.
    802   (let ((*break-level* break-level)
    803         (*loading-file-source-file* nil)
    804         (*loading-toplevel-location* nil)
    805         *** ** * +++ ++ + /// // / -)
    806     (flet ((repl-until-abort ()
    807              (rdebug-send `(:read-loop ,*current-process* ,break-level))
    808              (restart-case
    809                  (catch :abort
    810                    (catch-cancel
    811                     (loop
    812                       (setq *break-level* break-level)
    813                       (let ((event (funcall (swankfun "WAIT-FOR-EVENT")
    814                                             `(or (:emacs-rex . _)
    815                                                  ;; some internal swank kludge...
    816                                                  (:sldb-return ,(1+ break-level))))))
    817                         (when (eql (car event) :sldb-return)
    818                           (abort))
    819                         ;; Execute some basic protocol function (not user code).
    820                         (apply (swankfun "EVAL-FOR-EMACS") (cdr event))))))
    821                (abort ()
    822                  :report (lambda (stream)
    823                            (if (eq break-level 0)
    824                              (format stream "Return to toplevel")
    825                              (format stream "Return to break level ~D" break-level)))
    826                  nil)
    827                (abort-break () (unless (eql break-level 0) (abort))))))
    828       (declare (ftype (function) exit-swank-loop))
    829       (unwind-protect
    830           (loop
    831             (repl-until-abort)
    832             ;(clear-input)
    833             ;(terpri)
    834             )
    835         (exit-swank-loop break-level)))))
    836 
    837  (defun safe-condition-string (condition)
    838    (or (ignore-errors (princ-to-string condition))
    839        (ignore-errors (prin1-to-string condition))
    840        (ignore-errors (format nil "Condition of type ~s"
    841                               (type-of condition)))
    842        (ignore-errors (and (typep condition 'error)
    843                            "<Unprintable error>"))
    844        "<Unprintable condition>"))
    845 
    846 ;; Find process to handle interactive abort, i.e. a local ^c.
    847 (defun rdebug-find-repl-thread ()
    848   (let ((conn (funcall (swankfun "DEFAULT-CONNECTION"))))
    849     (when conn
    850       ;; TODO: select the frontmost listener (this selects the last created one).
    851       (funcall (swankfun "FIND-REPL-THREAD") conn))))
    852 
    853 
    854 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    855 ;;
    856 ;; Standard swank startup
    857 ;;
    858 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    859 
    860 ;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
    861 
    862 (defun load-swank (load-path)
    863   (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so can tell if loaded
    864   (load (merge-pathnames load-path "swank-loader.lisp"))
    865   (unless (and (find-package :swank-loader)
    866                (find-symbol "INIT" :swank-loader))
    867     (error "~s is not a swank loader path" load-path))
    868   (funcall (find-symbol "INIT" :swank-loader))
    869   (unless (and (find-package :swank)
    870                (find-symbol "CREATE-SERVER" :swank))
    871     (error "Incompatible swank version loaded from ~s" load-path)))
    872 
    873 (defun start-swank-server (&key
    874                            (port (swankvar "DEFAULT-SERVER-PORT"))
    875                            (debug (swankvar "*LOG-EVENTS*"))
    876                            (dedicated-output-port (and (swankvar "*USE-DEDICATED-OUTPUT-STREAM*")
    877                                                        (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*")))
    878                            (globally-redirect-io (swankvar "*GLOBALLY-REDIRECT-IO*"))
    879                            (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
    880                            (indentation-updates (swankvar "*CONFIGURE-EMACS-INDENTATION*"))
    881                            (dont-close (swankvar "*DONT-CLOSE*"))
    882                            (coding-system "iso-latin-1-unix")
    883                            (style :spawn))
    884   "Assuming SWANK is already loaded, create a swank server on the specified port"
    885   (when debug
    886     (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
    887     (setf (swankvar "*SWANK-DEBUG-P*") t)
    888     (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
    889   (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedicated-output-port)))
    890     (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-port))
    891   (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
    892   (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
    893   (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
    894   (funcall (swankfun "CREATE-SERVER")
    895            :style style
    896            :port port
    897            :dont-close dont-close
    898            :coding-system coding-system))
    899 
    900 
    901 (defun swank-port-active? (port)
    902   (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
    903 
    904 
    905 ;; Special ccl slime extension to allow the client to specify the swank path
    906 
    907 (defvar *swank-loader-process* nil)
    908 (defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
    909 (defparameter *default-swank-loader-port* 4884)
    910 
    911 (defun stop-swank-loader ()
    912   (when *swank-loader-process*
    913     (process-kill (shiftf *swank-loader-process* nil))))
    914 
    915 (defun start-swank-loader (&optional (port *default-swank-loader-port*))
    916   (ignore-errors (stop-swank-loader))
    917   (let ((semaphore (make-semaphore))
    918         (errorp nil))
    919     (setq *swank-loader-process*
    920           ;; Wait for either a swank client to connect or the special ccl slime kludge
    921           (process-run-function "Swank Loader"
    922                                 (lambda (sem)
    923                                   (setq *swank-loader-process* *current-process*)
    924                                   (unwind-protect
    925                                       (with-open-socket (socket :connect :passive :local-port port
    926                                                                 :reuse-address t)
    927                                         (signal-semaphore (shiftf sem nil))
    928                                         (loop
    929                                           (let* ((stream (accept-connection socket))
    930                                                  (line (read-line stream nil)))
    931                                             (multiple-value-bind (path port)
    932                                                                  (parse-emacs-ccl-swank-request line)
    933                                               (let ((message (handler-case
    934                                                                  (if (swank-port-active? port)
    935                                                                    (format nil "Swank is already active on port ~s" port)
    936                                                                    (progn
    937                                                                      (load-swank path)
    938                                                                      (start-swank-server :port port)
    939                                                                      nil))
    940                                                                (error (c) (princ-to-string c)))))
    941                                                 (prin1 `(:active (and (swank-port-active? port) t)
    942                                                                  :loader ,path
    943                                                                  :message ,message
    944                                                                  :port ,port)
    945                                                        stream)
    946                                                 (finish-output stream))))))
    947                                     (when sem ;; in case exit before finished startup
    948                                       (setq errorp t)
    949                                       (signal-semaphore sem))))
    950                                 semaphore))
    951     (wait-on-semaphore semaphore)
    952     (when errorp
    953       (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
    954     *swank-loader-process*))
    955 
    956 (defun parse-emacs-ccl-swank-request (line)
    957   (let ((start (length $emacs-ccl-swank-request-marker)))
    958     (when (and (< start (length line))
    959                (string= $emacs-ccl-swank-request-marker line :end2 start))
    960       (let* ((split-pos (position #\: line :start start))
    961              (port (parse-integer line :junk-allowed nil :start start :end split-pos))
    962              (path-pos (position-if-not #'whitespacep line
    963                                         :start (if split-pos (1+ split-pos) start)))
    964              (path (subseq line path-pos
    965                            (1+ (position-if-not #'whitespacep line :from-end t)))))
    966         (values path port)))))
    967 
    968 
    969 
    970 
     349                                   when (eq sym '*package*) do (return val))))
     350              (if *verbose-eval-selection*
     351                (let ((state (send-event-for-value rthread `(:read-eval-print-one ,text ,package-name) :semaphore sem)))
     352                  (loop while state
     353                    do (force-output)
     354                    do (print-listener-prompt *standard-output* t)
     355                    do (send-event-for-value rthread `(:read-eval-print-next ,state) :semaphore sem)))
     356                (send-event-for-value rthread `(:read-eval-all-print-last ,text ,package-name) :semaphore sem)))))))))
     357
Note: See TracChangeset for help on using the changeset viewer.