source: trunk/source/library/remote-lisp.lisp @ 15031

Last change on this file since 15031 was 15031, checked in by gz, 8 years ago

Support for reading user input from remote lisp. Easier test setup for remote listener

File size: 32.6 KB
Line 
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
91   (thread-process :initform nil :accessor rlisp-thread-process)
92   ;; Remote process doing the evaluation for this process.
93   (thread-id :initarg :thread-id :reader rlisp-thread-id)))
94
95(defmethod rlisp-host-description ((rthread remote-lisp-thread))
96  (rlisp-host-description (rlisp-thread-connection rthread)))
97
98(defmethod print-object ((rthread remote-lisp-thread) stream)
99  (print-unreadable-object (rthread stream :type t :identity t)
100    (format stream "~a thread ~a"
101            (rlisp-host-description rthread)
102            (rlisp-thread-id rthread))))
103
104(defmethod rlisp-thread-id ((thread-id integer)) thread-id)
105
106(defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
107
108(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread) &key (create t))
109  (declare (ignore create))
110  thread)
111
112(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer) &key (create t))
113  (with-rlisp-lock (conn)
114    (or (find id (rlisp-threads conn) :key #'rlisp-thread-id)
115        (and create
116             (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id)))
117               (push rthread (rlisp-threads conn))
118               rthread)))))
119
120(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
121  (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
122
123(defmethod rlisp/toplevel ((rthread remote-lisp-thread) &key)
124  (rlisp/toplevel (rlisp-thread-connection rthread) :thread rthread))
125
126(defmethod rlisp/execute ((rthread remote-lisp-thread) form continuation &key)
127  (rlisp/execute (rlisp-thread-connection rthread) form continuation :thread rthread))
128
129(defmethod rlisp/interrupt ((rthread remote-lisp-thread) &key)
130  (rlisp/interrupt (rlisp-thread-connection rthread) :thread rthread))
131
132(defmethod remote-listener-eval ((rthread remote-lisp-thread) text &rest keys &key &allow-other-keys)
133  (apply #'remote-listener-eval (rlisp-thread-connection rthread) text :thread rthread keys))
134
135(defclass swank-rlisp-connection (remote-lisp-connection)
136  (
137   ;; The socket to the swank server.  Only the connection process reads from it, without locking.
138   ;;  Anyone can write, but should grab the connection lock.
139   (command-stream :initarg :stream :reader swank-command-stream)
140   (read-buffer :initform (make-array 1024 :element-type 'character) :accessor swank-read-buffer)))
141
142(defmethod rlisp-host-description ((conn swank-rlisp-connection))
143  (let ((socket (swank-command-stream conn)))
144    (if (open-stream-p socket)
145      (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket))
146      ":CLOSED")))
147
148(defmethod print-object ((conn swank-rlisp-connection) stream)
149  (print-unreadable-object (conn stream :type t :identity t)
150    (format stream "~a @~a"
151            (rlisp-host-description conn)
152            (rlisp-machine-instance conn))))
153
154(defmethod start-rlisp-server ((conn swank-rlisp-connection))
155  ;; TODO: Make sure closing the connection kills the process or vice versa.
156  (assert (null (rlisp-server-process conn)))
157  (flet ((swank-event-loop (conn)
158           (setf (rlisp-server-process conn) *current-process*)
159           (loop
160             (let ((sexp (read-swank-event conn)))
161               (handle-swank-event conn (car sexp) (cdr sexp))))))
162    (setf (rlisp-server-process conn)
163          (process-run-function (format nil "Swank Client ~a" (remote-port (swank-command-stream conn)))
164                                #'swank-event-loop conn)))
165  (let ((sem (make-semaphore)) (abort nil))
166    ;; Patch up swank.  To be replaced someday by our own set of remote functions...
167    (rlisp/execute conn
168                  "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
169                     (CL:DEFUN SWANK::EVAL-REGION (STRING)
170                       (CL:WITH-INPUT-FROM-STRING (STREAM STRING)
171                         (CL:LET (CL:- VALUES)
172                           (CL:LOOP
173                             (CL:LET ((FORM (CL:READ STREAM () STREAM)))
174                               (CL:WHEN (CL:EQ FORM STREAM)
175                                 (CL:FINISH-OUTPUT)
176                                 (CL:RETURN (CL:VALUES VALUES CL:-)))
177                               (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FORM)
178                                 (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:SETQ CL:- FORM))))
179                               (CL:FINISH-OUTPUT))))))
180                     (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
181                       (SWANK::CREATE-REPL ())
182                       (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
183                         (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
184                         (SWANK::THREAD-ID THREAD)))
185                     (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING)
186                       (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION*
187                                 #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LISTENER-EVAL-FOR-IDE
188                                                    (CL:MAPCAR #'CL:WRITE-TO-STRING _)))))
189                         (SWANK::REPL-EVAL STRING)))
190                     (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTENER-EVAL-FOR-IDE))"
191                   (lambda (error result)
192                     (declare (ignore result))
193                     (when error
194                       (unwind-protect
195                           (error "Error initializing SWANK: ~s" error)
196                         (setq abort t)
197                         (signal-semaphore sem)))
198                     (signal-semaphore sem)))
199    (wait-on-semaphore sem)
200    (when abort (return-from start-rlisp-server nil))
201    (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
202                   (lambda (error info)
203                     (unless error
204                       (destructuring-bind (&key (features nil featuresp)
205                                                 machine
206                                                 lisp-implementation
207                                                 &allow-other-keys) info
208                         (let ((args nil))
209                           (when featuresp
210                             (setq args (list* :features features args)))
211                           (when (consp machine)
212                             (destructuring-bind (&key instance &allow-other-keys) machine
213                               (setq args (list* :machine-instance instance args))))
214                           (when (consp lisp-implementation)
215                             (destructuring-bind (&key type version &allow-other-keys) lisp-implementation
216                               (setq args (list* :lisp-implementation-type type
217                                                 :lisp-implementation-version version
218                                                 args))))
219                           (when args
220                             (apply #'update-rlisp-connection-info conn args)))))
221                     (signal-semaphore sem)))
222    (wait-on-semaphore sem)
223    conn))
224
225(defmethod output-stream-for-remote-lisp ((app application))
226  *standard-output*)
227
228(defmethod input-stream-for-remote-lisp ((app application))
229  *standard-input*)
230
231(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
232  (case event
233    (:return
234     (destructuring-bind (value id) args
235       (when id (invoke-rlisp-callback conn id value))))
236    (:invalid-rpc
237     (destructuring-bind (id message) args
238       (when id (remove-rlisp-object conn id))
239       (error "Invalid swank rpc: ~s" message)))
240    ((:debug :debug-activate :debug-return :debug-condition :read-aborted)
241     (destructuring-bind (thread-id &rest event-args) args
242       (let ((rthread (rlisp-thread conn thread-id)))
243         (unless (rlisp-thread-process rthread)
244           (error "Got swank event ~s ~s for thread ~s with no process" event args rthread))
245         (process-interrupt (rlisp-thread-process rthread)
246                            #'handle-swank-event
247                            rthread event event-args))))
248    (:new-features
249     (destructuring-bind (features) args
250       (update-rlisp-connection-info conn :features features)))
251    (:indentation-update
252     (destructuring-bind (name-indent-alist) args
253       (declare (ignore name-indent-alist))))
254    (:write-string
255     (destructuring-bind (string) args
256       (let ((stream (output-stream-for-remote-lisp *application*)))
257         (if (> (length string) 500)
258           (process-run-function "Long Remote Output" #'write-string string stream)
259           (write-string string stream)))))
260    (:read-string
261     (destructuring-bind (thread-id tag) args
262       (let ((rthread (rlisp-thread conn thread-id :create nil)))
263         (if (and rthread (rlisp-thread-process rthread))
264           (process-interrupt (rlisp-thread-process rthread)
265                              #'handle-swank-event
266                              rthread event `(,tag))
267           ;; not a listener thread.
268           ;; TODO: this needs to be wrapped in some error handling.
269           (process-run-function (format nil "Remote Input (~s)" thread-id)
270                                 #'rlisp-read-string
271                                 conn
272                                 (input-stream-for-remote-lisp *application*)
273                                 thread-id
274                                 tag)))))
275    (t (warn "Received unknown event ~s with args ~s" event args))))
276
277(define-condition rlisp-read-aborted ()
278  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
279
280(defun rlisp-read-string (conn stream thread-id tag)
281  (handler-bind ((rlisp-read-aborted (lambda (c)
282                                       (when (eql tag (rlisp-read-aborted-tag c))
283                                         (return-from rlisp-read-string)))))
284    (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
285                     (read-available-text stream))))
286      (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,text)))))
287
288(defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
289  (assert (eq (rlisp-thread-process rthread) *current-process*))
290  (ecase event
291    (:read-string
292     (destructuring-bind (tag) args
293       (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
294    (:read-aborted
295     (destructuring-bind (tag) args
296       (signal 'rlisp-read-aborted :tag tag)))
297    (:debug     ;; SLDB-SETUP
298     (destructuring-bind (level (condition-text condition-type extras)
299                                ;; list of (restart-name restart-description)
300                                restarts
301                                ;; list of (index frame-description &key restartable)
302                                backtrace
303                                ;; callbacks currently being evaluated in this thread.
304                                ;; Wonder what emacs does with that.
305                                pending-callbacks) args
306       (declare (ignorable condition-type extras backtrace pending-callbacks))
307       (format t "~&Error: ~a" condition-text)
308       (when *show-restarts-on-break*
309         (format t "~&Remote restarts:")
310         (loop for (name description) in restarts
311           do (format t "~&~a ~a" name description))
312         (fresh-line))
313       (rlisp-read-loop rthread :break-level level)))
314    (:debug-activate ;; SLDB-ACTIVATE
315     (destructuring-bind (level flag) args
316       (declare (ignore flag))
317       (unless (eql level *break-level*)
318         (warn "break level confusion is ~s expected ~s" *break-level* level))))
319    (:debug-condition ;; This seems to have something to do with errors in the debugger
320     (destructuring-bind (message) args
321       (format t "~&Swank error: ~s" message)))
322    (:debug-return
323     (destructuring-bind (level stepping-p) args
324       (declare (ignore stepping-p))
325       (unless (eql level *break-level*)
326         (invoke-restart 'debug-return level))))))
327
328
329;; This assumes connection process is the only thing that reads from the socket stream and uses
330;; the read-buffer, so don't need locking.
331(defun read-swank-event (conn)
332  (assert (eq (rlisp-server-process conn) *current-process*))
333  (let* ((stream (swank-command-stream conn))
334         (buffer (swank-read-buffer conn))
335         (count (stream-read-vector stream buffer 0 6)))
336    (when (< count 6) (signal-eof-error stream))
337    (setq count (parse-integer buffer :end 6 :radix 16))
338    (when (< (length buffer) count)
339      (setf (swank-read-buffer conn)
340            (setq buffer (make-array count :element-type 'character))))
341    (let ((len (stream-read-vector stream buffer 0 count)))
342      (when (< len count) (signal-eof-error stream))
343      ;; TODO: catch errors here and report them sanely.
344      ;; TODO: check that there aren't more forms in the string.
345      (with-standard-io-syntax
346          (let ((*package* +swank-io-package+)
347                (*read-eval* nil))
348            (read-from-string buffer t nil :end count))))))
349
350
351(defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
352  (let* ((semaphore (make-semaphore))
353         (return-error nil)
354         (return-id nil))
355    (rlisp/execute conn (format nil "(CCL::MAKE-SWANK-REPL-FOR-IDE ~s)" name)
356                   (lambda (error id)
357                     (setf return-error error)
358                     (setq return-id id)
359                     (signal-semaphore semaphore)))
360    (wait-on-semaphore semaphore)
361    (when return-error
362      (error "Remote eval error ~s" return-error))
363    (rlisp-thread conn return-id)))
364
365;; TODO: "coding-system".
366(defun connect-to-swank (host port &key (secret-file "home:.slime-secret"))
367  (let* ((socket (make-socket :remote-host host :remote-port port :nodelay t))
368         (conn (make-instance 'swank-rlisp-connection :stream socket)))
369    (when secret-file
370      (with-open-file (stream secret-file :if-does-not-exist nil)
371        (when stream
372          (let ((secret (read-line stream nil nil)))
373            (when secret
374              (send-string-to-swank conn secret))))))
375    (start-rlisp-server conn)))
376
377(defmethod close ((conn swank-rlisp-connection) &key abort)
378  ;; TODO: kill process.
379  (close (swank-command-stream conn) :abort abort))
380
381(defun send-string-to-swank (conn string)
382  (let ((stream (swank-command-stream conn)))
383    (with-rlisp-lock (conn)
384      (format stream "~6,'0,X" (length string))
385      (write-string string stream))
386    (force-output stream)))
387
388(defvar +swank-io-package+ 
389  (loop as name = (gensym "SwankIO/") while (find-package name)
390    finally (let ((package (make-package name :use nil)))
391              (import '(nil t quote) package)
392              (return package))))
393
394(defun send-sexp-to-swank (conn sexp)
395  (send-string-to-swank conn (with-standard-io-syntax
396                                 (let ((*package* +swank-io-package+))
397                                   (prin1-to-string sexp)))))
398
399(defun format-for-swank (fmt-string fmt-args)
400  (with-standard-io-syntax
401      (let ((*package* +swank-io-package+))
402        (apply #'format nil fmt-string fmt-args))))
403
404(defun thread-id-for-execute (thread)
405  (typecase thread
406    (null t) ;; don't care
407    (remote-lisp-thread (rlisp-thread-id thread))
408    (t thread)))
409
410
411;; Continuation is executed in the same process that invoked remote-execute.
412(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key package thread)
413  (flet ((continuation (result)
414           (ecase (car result)
415             (:ok (apply continuation nil (cdr result)))
416             (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
417    (let* ((sexp `(:emacs-rex ,form-or-string
418                              ,package
419                              ,(thread-id-for-execute thread)
420                              ,(and continuation (register-rlisp-callback conn #'continuation)))))
421      (if (stringp form-or-string)
422        (send-string-to-swank conn (format-for-swank "(~s ~a ~s ~s ~s)" sexp))
423        (send-sexp-to-swank conn sexp)))))
424
425
426(defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
427  ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
428  ;; will normally not return, don't register a continuation for it.
429  (rlisp/execute conn `(invoke-restart ',name) nil :thread thread))
430
431(defmethod rlisp/toplevel ((conn swank-rlisp-connection) &key thread)
432  (rlisp/execute conn `(toplevel) nil :thread thread))
433
434(defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
435  (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
436 
437;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string &key thread)
438;;  (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execute thread) ,tag ,string)))
439
440;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value &key thread)
441;;  (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value)))
442
443(defun read-available-text (stream)
444  (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0)
445    for ch = (stream-read-char-no-hang stream)
446    until (or (eq ch :eof) (null ch))
447    do (vector-push-extend ch buffer)
448    finally (return buffer)))
449 
450;; Return text for remote evaluation.
451(defmethod toplevel-form-text ((stream input-stream))
452  (when (peek-char t stream nil) ;; wait for the first one.
453    (read-available-text stream)))
454
455(defmethod toplevel-form-text ((stream synonym-stream))
456  (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
457
458(defmethod toplevel-form-text ((stream two-way-stream))
459  (if (typep stream 'echo-stream)
460    (call-next-method)
461    (toplevel-form-text (two-way-stream-input-stream stream))))
462
463;; pass this as the initial-function in make-mcl-listener-process
464(defmethod remote-listener-function ((rthread remote-lisp-thread))
465  (setf (rlisp-thread-process rthread) *current-process*)
466  (unless (or *inhibit-greeting* *quiet-flag*)
467    (let ((conn (rlisp-thread-connection rthread)))
468      (format t "~&Welcome to ~A ~A on ~A!"
469              (rlisp-lisp-implementation-type conn)
470              (rlisp-lisp-implementation-version conn)
471              (rlisp-machine-instance conn))))
472  (rlisp-read-loop rthread :break-level 0))
473 
474(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
475  (let* ((*break-level* break-level)  ;; used by prompt printing
476         (*last-break-level* break-level)  ;; ditto
477         (debug-return nil))
478    ;; When the user invokes a restart from a list, it will be a remote restart and
479    ;; we will pass the request to the remote.  However, there are some UI actions that invoke local
480    ;; restarts by name, e.g. cmd-/ will invoke 'continue.  We need catch those and pass them to
481    ;; the remote.  The remote will then do whatever the restart does, and will send 'debug-return's
482    ;; as needed.
483    (unwind-protect
484        (loop
485          (restart-case
486              ;; Do continue with a restart bind because don't want to abort whatever form is
487              ;; about to be sent for evaluation, just in case the continue doesn't end up doing
488              ;; anything on the remote end.
489              (restart-bind ((continue (lambda () (rlisp/invoke-restart rthread 'continue))))
490                (catch :toplevel
491                  (loop
492                    (catch :abort
493                      (loop
494                        (catch-cancel ;; exactly like :abort except prints Cancelled.
495                         (rlisp-read-loop-internal rthread))
496                        (rlisp/invoke-restart rthread 'abort)
497                        (format *terminal-io* "~&Cancelled")))
498                    (rlisp/invoke-restart rthread 'abort)))
499                (rlisp/toplevel rthread))
500            (abort () ;; intercept local attempt to abort
501              (rlisp/invoke-restart rthread 'abort))
502            (abort-break () ;; intercept local attempt to abort-break
503              (if (eq break-level 0)
504                (rlisp/invoke-restart rthread 'abort)
505                (rlisp/invoke-restart rthread 'abort-break)))
506            (muffle-warning (&optional condition) ;; not likely to be invoked interactively, but...
507              (assert (null condition)) ;; no way to pass that!
508              (rlisp/invoke-restart rthread 'muffle-warning))
509            (debug-return (target-level)
510               (when (> target-level break-level)
511                 (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
512               (when (< target-level break-level)
513                 (setq debug-return t)
514                 (invoke-restart 'debug-return target-level))))
515          (clear-input)
516          (fresh-line))
517      (unless debug-return
518        (warn "Unknown exit from rlisp-read-loop!")))))
519
520(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
521  (let* ((input-stream *standard-input*)
522         (output-stream *standard-output*)
523         (sem (make-semaphore))
524         (eof-count 0))
525    (loop
526      (force-output output-stream)
527      (print-listener-prompt output-stream t)
528      (multiple-value-bind (text env) (toplevel-form-text input-stream)
529        (if (null text) ;; eof
530          (progn
531            (when (> (incf eof-count) *consecutive-eof-limit*)
532              (#_ _exit 0))
533            (unless (and (not *batch-flag*)
534                         (not *quit-on-eof*)
535                         (stream-eof-transient-p input-stream))
536              (exit-interactive-process *current-process*))
537            (stream-clear-input input-stream)
538            (rlisp/invoke-restart rthread 'abort-break))
539          (progn
540            (setq eof-count 0)
541            ;;(let* ((values (toplevel-eval form env)))
542            ;;      (if print-result (toplevel-print values)))
543            (let* ((package-name (loop for sym in (car env) for val in (cdr env)
544                                  when (eq sym '*package*) do (return val)))
545                   (values (remote-listener-eval rthread text :package package-name :semaphore sem)))
546              (fresh-line output-stream)
547              (dolist (val values) (princ val output-stream) (terpri output-stream)))))))))
548
549
550(defmethod remote-listener-eval ((conn swank-rlisp-connection) text
551                                 &key package thread (semaphore (make-semaphore)))
552  (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text))
553         (return-values nil)
554         (return-error nil))
555    (rlisp/execute conn
556                   form
557                   (lambda (error values)
558                     (setq return-error error)
559                     (setq return-values values)
560                     (signal-semaphore semaphore))
561                   :package package
562                   :thread thread)
563    (wait-on-semaphore semaphore)
564    (when return-error
565      (error "Remote eval error ~s" return-error))
566    ;; a list of strings representing each return value
567    return-values))
568
569
570
571
572
573
574
575;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
576;;
577;; Server-side SWANK support
578;;
579;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
580
581;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
582
583(defun swankvar (name &optional (package :swank))
584  (symbol-value (find-symbol name package)))
585
586(defun (setf swankvar) (value name &optional (package :swank))
587  (let ((sym (find-symbol name package)))
588    (if (null sym)
589      (warn "Couldn't find ~a::~a" package name)
590      (set sym value))))
591
592(defun load-swank (load-path)
593  (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so can tell if loaded
594  (load (merge-pathnames load-path "swank-loader.lisp"))
595  (unless (and (find-package :swank-loader)
596               (find-symbol "INIT" :swank-loader))
597    (error "~s is not a swank loader path" load-path))
598  (funcall (find-symbol "INIT" :swank-loader))
599  (unless (and (find-package :swank)
600               (find-symbol "CREATE-SERVER" :swank))
601    (error "Incompatible swank version loaded from ~s" load-path)))
602
603(defun start-swank-server (&key
604                           (port (swankvar "DEFAULT-SERVER-PORT"))
605                           (debug (swankvar "*LOG-EVENTS*"))
606                           (dedicated-output-port (and (swankvar "*USE-DEDICATED-OUTPUT-STREAM*")
607                                                       (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*")))
608                           (globally-redirect-io (swankvar "*GLOBALLY-REDIRECT-IO*"))
609                           (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
610                           (indentation-updates (swankvar "*CONFIGURE-EMACS-INDENTATION*"))
611                           (dont-close (swankvar "*DONT-CLOSE*"))
612                           (coding-system "iso-latin-1-unix")
613                           (style :spawn))
614  "Assuming SWANK is already loaded, create a swank server on the specified port"
615  (when debug
616    (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
617    (setf (swankvar "*SWANK-DEBUG-P*") t)
618    (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
619  (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedicated-output-port)))
620    (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-port))
621  (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
622  (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
623  (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
624  (funcall (find-symbol "CREATE-SERVER" :swank)
625           :style style
626           :port port
627           :dont-close dont-close
628           :coding-system coding-system))
629
630
631(defun swank-port-active? (port)
632  (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
633
634
635;; Special ccl slime extension to allow the client to specify the swank path
636
637(defvar *swank-loader-process* nil)
638(defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
639(defparameter *default-swank-loader-port* 4884)
640
641(defun stop-swank-loader ()
642  (when *swank-loader-process*
643    (process-kill (shiftf *swank-loader-process* nil))))
644
645(defun start-swank-loader (&optional (port *default-swank-loader-port*))
646  (ignore-errors (stop-swank-loader))
647  (let ((semaphore (make-semaphore))
648        (errorp nil))
649    (setq *swank-loader-process*
650          ;; Wait for either a swank client to connect or the special ccl slime kludge
651          (process-run-function "Swank Loader"
652                                (lambda (sem)
653                                  (setq *swank-loader-process* *current-process*)
654                                  (unwind-protect
655                                      (with-open-socket (socket :connect :passive :local-port port
656                                                                :reuse-address t)
657                                        (signal-semaphore (shiftf sem nil))
658                                        (loop
659                                          (let* ((stream (accept-connection socket))
660                                                 (line (read-line stream nil)))
661                                            (multiple-value-bind (path port)
662                                                                 (parse-emacs-ccl-swank-request line)
663                                              (let ((message (handler-case
664                                                                 (if (swank-port-active? port)
665                                                                   (format nil "Swank is already active on port ~s" port)
666                                                                   (progn
667                                                                     (load-swank path)
668                                                                     (start-swank-server :port port)
669                                                                     nil))
670                                                               (error (c) (princ-to-string c)))))
671                                                (prin1 `(:active (and (swank-port-active? port) t)
672                                                                 :loader ,path
673                                                                 :message ,message
674                                                                 :port ,port)
675                                                       stream)
676                                                (finish-output stream))))))
677                                    (when sem ;; in case exit before finished startup
678                                      (setq errorp t)
679                                      (signal-semaphore sem))))
680                                semaphore))
681    (wait-on-semaphore semaphore)
682    (when errorp
683      (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
684    *swank-loader-process*))
685
686(defun parse-emacs-ccl-swank-request (line)
687  (let ((start (length $emacs-ccl-swank-request-marker)))
688    (when (and (< start (length line))
689               (string= $emacs-ccl-swank-request-marker line :end2 start))
690      (let* ((split-pos (position #\: line :start start))
691             (port (parse-integer line :junk-allowed nil :start start :end split-pos))
692             (path-pos (position-if-not #'whitespacep line
693                                        :start (if split-pos (1+ split-pos) start)))
694             (path (subseq line path-pos
695                           (1+ (position-if-not #'whitespacep line :from-end t)))))
696        (values path port)))))
697
698
699
700
Note: See TracBrowser for help on using the repository browser.