1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2011 Clozure Associates |
---|
4 | ;;; This file is part of Clozure CL. |
---|
5 | ;;; |
---|
6 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | ;;; |
---|
17 | |
---|
18 | (in-package :ccl) |
---|
19 | |
---|
20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
21 | ;; |
---|
22 | ;; Client-side remote lisp support |
---|
23 | ;; |
---|
24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
25 | |
---|
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) |
---|
36 | (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type) |
---|
37 | (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version) |
---|
38 | (machine-instance :initform "???" :accessor rlisp-machine-instance))) |
---|
39 | |
---|
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))) |
---|
44 | |
---|
45 | (defmethod update-rlisp-connection-info ((conn remote-lisp-connection) |
---|
46 | &key lisp-implementation-type |
---|
47 | lisp-implementation-version |
---|
48 | machine-instance |
---|
49 | (features nil featuresp)) |
---|
50 | (with-rlisp-lock (conn) |
---|
51 | (when featuresp |
---|
52 | (setf (rlisp-features conn) features)) |
---|
53 | (when machine-instance |
---|
54 | (setf (rlisp-machine-instance conn) machine-instance)) |
---|
55 | (when lisp-implementation-type |
---|
56 | (setf (rlisp-lisp-implementation-type conn) lisp-implementation-type)) |
---|
57 | (when lisp-implementation-version |
---|
58 | (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version)))) |
---|
59 | |
---|
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))) |
---|
96 | |
---|
97 | (defmethod rlisp-host-description ((rthread remote-lisp-thread)) |
---|
98 | (rlisp-host-description (rlisp-thread-connection rthread))) |
---|
99 | |
---|
100 | (defmethod print-object ((rthread remote-lisp-thread) stream) |
---|
101 | (print-unreadable-object (rthread stream :type t :identity t) |
---|
102 | (format stream "~a thread ~a" |
---|
103 | (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))) |
---|
152 | (if (open-stream-p socket) |
---|
153 | (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket)) |
---|
154 | ":CLOSED"))) |
---|
155 | |
---|
156 | (defmethod print-object ((conn swank-rlisp-connection) stream) |
---|
157 | (print-unreadable-object (conn stream :type t :identity t) |
---|
158 | (format stream "~a @~a" |
---|
159 | (rlisp-host-description conn) |
---|
160 | (rlisp-machine-instance conn)))) |
---|
161 | |
---|
162 | |
---|
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 | |
---|
386 | |
---|
387 | (define-condition rlisp-read-aborted () |
---|
388 | ((tag :initarg :tag :reader rlisp-read-aborted-tag))) |
---|
389 | |
---|
390 | (defun rlisp-read-string (conn stream thread-id tag) |
---|
391 | (handler-bind ((rlisp-read-aborted (lambda (c) |
---|
392 | (when (eql tag (rlisp-read-aborted-tag c)) |
---|
393 | (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")) |
---|
483 | (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) |
---|
494 | ;; 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)))) |
---|
551 | |
---|
552 | (defun read-available-text (stream) |
---|
553 | (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0) |
---|
554 | for ch = (stream-read-char-no-hang stream) |
---|
555 | until (or (eq ch :eof) (null ch)) |
---|
556 | do (vector-push-extend ch buffer) |
---|
557 | finally (return buffer))) |
---|
558 | |
---|
559 | ;; 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 | |
---|
564 | (defmethod toplevel-form-text ((stream synonym-stream)) |
---|
565 | (toplevel-form-text (symbol-value (synonym-stream-symbol stream)))) |
---|
566 | |
---|
567 | (defmethod toplevel-form-text ((stream two-way-stream)) |
---|
568 | (if (typep stream 'echo-stream) |
---|
569 | (call-next-method) |
---|
570 | (toplevel-form-text (two-way-stream-input-stream stream)))) |
---|
571 | |
---|
572 | ;; pass this as the initial-function in make-mcl-listener-process |
---|
573 | (defmethod remote-listener-function ((rthread remote-lisp-thread)) |
---|
574 | (setf (rlisp-thread-process rthread) *current-process*) |
---|
575 | (unless (or *inhibit-greeting* *quiet-flag*) |
---|
576 | (let ((conn (rlisp-thread-connection rthread))) |
---|
577 | (format t "~&Welcome to ~A ~A on ~A!" |
---|
578 | (rlisp-lisp-implementation-type conn) |
---|
579 | (rlisp-lisp-implementation-version conn) |
---|
580 | (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)) |
---|
596 | |
---|
597 | (defmethod create-rlisp-listener ((application application) rthread) |
---|
598 | (assert (null (rlisp-thread-process rthread))) |
---|
599 | ;; see make-mcl-listener-process |
---|
600 | (error "Not implemented yet")) |
---|
601 | |
---|
602 | ;; IDE read-loop with remote evaluation. |
---|
603 | (defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level) |
---|
604 | (let* ((*break-level* break-level) ;; used by prompt printing |
---|
605 | (*last-break-level* break-level) ;; ditto |
---|
606 | (debug-return nil)) |
---|
607 | (unwind-protect |
---|
608 | (loop |
---|
609 | (setf (rlisp-thread-break-level rthread) break-level) |
---|
610 | (restart-case |
---|
611 | ;; There are some UI actions that invoke local restarts by name, e.g. cmd-/ will invoke 'continue. |
---|
612 | ;; Catch those and just pass them to the remote. The remote will then do whatever the restart |
---|
613 | ;; does, and will send back unwinding directions if appropriate. |
---|
614 | ;; Do continue with a restart-bind because don't want to abort whatever form is |
---|
615 | ;; about to be sent for evaluation, just in case the continue doesn't end up doing |
---|
616 | ;; anything on the remote end. |
---|
617 | (restart-bind ((continue (lambda () (rlisp/invoke-restart rthread 'continue)))) |
---|
618 | (catch :toplevel |
---|
619 | (loop |
---|
620 | (catch :abort |
---|
621 | (loop |
---|
622 | (catch-cancel ;; exactly like :abort except prints Cancelled. |
---|
623 | (rlisp-read-loop-internal rthread)) |
---|
624 | (rlisp/invoke-restart rthread 'abort) |
---|
625 | (format *terminal-io* "~&Cancelled"))) |
---|
626 | (rlisp/invoke-restart rthread 'abort))) |
---|
627 | (rlisp/toplevel rthread)) |
---|
628 | ;; These are invoked via invoke-restart-no-return, so must take non-local exit. |
---|
629 | (abort () (rlisp/invoke-restart rthread 'abort)) |
---|
630 | (abort-break () (if (eql break-level 0) |
---|
631 | (rlisp/invoke-restart rthread 'abort) |
---|
632 | (rlisp/invoke-restart rthread 'abort-break))) |
---|
633 | ;; This is invoked when remote unwinds |
---|
634 | (debug-return (target-level) |
---|
635 | (setq debug-return t) |
---|
636 | (when (eql target-level break-level) |
---|
637 | (return-from rlisp-read-loop)) |
---|
638 | (when (> target-level break-level) |
---|
639 | (error "Missed target level in debug-return - want ~s have ~s" target-level break-level)) |
---|
640 | (invoke-restart 'debug-return target-level)) |
---|
641 | (debug-restart (target-level) |
---|
642 | (unless (eql target-level break-level) |
---|
643 | (when (> target-level break-level) |
---|
644 | (error "Missed target level in debug-restart - want ~s have ~s" target-level break-level)) |
---|
645 | (setq debug-return t) |
---|
646 | (invoke-restart 'debug-restart target-level)))) |
---|
647 | (clear-input) |
---|
648 | (fresh-line)) |
---|
649 | (unless debug-return |
---|
650 | (warn "Unknown exit from rlisp-read-loop!"))))) |
---|
651 | |
---|
652 | (defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread)) |
---|
653 | (let* ((input-stream *standard-input*) |
---|
654 | (output-stream *standard-output*) |
---|
655 | (sem (make-semaphore)) |
---|
656 | (eof-count 0)) |
---|
657 | (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)) |
---|
666 | (if (null text) ;; eof |
---|
667 | (progn |
---|
668 | (when (> (incf eof-count) *consecutive-eof-limit*) |
---|
669 | (#_ _exit 0)) |
---|
670 | (unless (and (not *batch-flag*) |
---|
671 | (not *quit-on-eof*) |
---|
672 | (stream-eof-transient-p input-stream)) |
---|
673 | (exit-interactive-process *current-process*)) |
---|
674 | (stream-clear-input input-stream) |
---|
675 | (rlisp/invoke-restart rthread 'abort-break)) |
---|
676 | (progn |
---|
677 | (setq eof-count 0) |
---|
678 | ;;(let* ((values (toplevel-eval form env))) |
---|
679 | ;; (if print-result (toplevel-print values))) |
---|
680 | (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 | |
---|