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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.623 - (hide annotations)
Fri Jan 2 21:57:54 2009 UTC (5 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.622: +129 -4 lines
Experimental implementation of "channels".
The idea is to support arbitrary protocols without
changes to the low level event dispatcher.

* slime.el (slime-make-channel, slime-close-channel)
(slime-channel-send, slime-send-to-remote-channel): New functions.
(slime-define-channel-type, slime-define-channel-method): New
macros.
(slime-dispatch-event): Support channel events.
* swank.lisp (channel, listener-channel): New classes.
(channel-send, send-to-remote-channel): New functions.
(create-listener): New function.  Test case for channel code.
(process-requests): Process channel events.
1 heller 1.418 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 dbarlow 1.27 ;;;
3 lgorrie 1.194 ;;; This code has been placed in the Public Domain. All warranties
4     ;;; are disclaimed.
5 dbarlow 1.27 ;;;
6 lgorrie 1.194 ;;;; swank.lisp
7 dbarlow 1.27 ;;;
8 lgorrie 1.194 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9     ;;; code in this file is purely portable Common Lisp. We do require a
10     ;;; smattering of non-portable functions in order to write the server,
11     ;;; so we have defined them in `swank-backend.lisp' and implemented
12     ;;; them separately for each Lisp implementation. These extensions are
13     ;;; available to us here via the `SWANK-BACKEND' package.
14 heller 1.26
15 heller 1.58 (defpackage :swank
16 heller 1.528 (:use :cl :swank-backend)
17 lgorrie 1.152 (:export #:startup-multiprocessing
18 heller 1.138 #:start-server
19 heller 1.178 #:create-server
20 heller 1.521 #:stop-server
21     #:restart-server
22 heller 1.138 #:ed-in-emacs
23 nsiivola 1.426 #:inspect-in-emacs
24 lgorrie 1.157 #:print-indentation-lossage
25 heller 1.561 #:invoke-slime-debugger
26 lgorrie 1.177 #:swank-debugger-hook
27 heller 1.528 #:emacs-inspect
28     ;;#:inspect-slot-for-emacs
29 lgorrie 1.194 ;; These are user-configurable variables:
30 lgorrie 1.152 #:*communication-style*
31 mbaringer 1.413 #:*dont-close*
32 lgorrie 1.152 #:*log-events*
33 lgorrie 1.283 #:*log-output*
34 lgorrie 1.152 #:*use-dedicated-output-stream*
35 mbaringer 1.313 #:*dedicated-output-stream-port*
36 lgorrie 1.157 #:*configure-emacs-indentation*
37 heller 1.189 #:*readtable-alist*
38 lgorrie 1.197 #:*globally-redirect-io*
39 lgorrie 1.223 #:*global-debugger*
40 nsiivola 1.599 #:*backtrace-printer-bindings*
41     #:*default-worker-thread-bindings*
42     #:*macroexpand-printer-bindings*
43 heller 1.282 #:*sldb-printer-bindings*
44     #:*swank-pprint-bindings*
45 lgorrie 1.300 #:*record-repl-results*
46 mbaringer 1.478 #:*debug-on-swank-error*
47 nsiivola 1.600 #:*inspector-verbose*
48 lgorrie 1.194 ;; These are re-exported directly from the backend:
49 lgorrie 1.209 #:buffer-first-change
50 heller 1.139 #:frame-source-location-for-emacs
51 wjenkner 1.146 #:restart-frame
52 trittweiler 1.548 #:sldb-step
53 heller 1.240 #:sldb-break
54     #:sldb-break-on-return
55 heller 1.142 #:profiled-functions
56     #:profile-report
57     #:profile-reset
58     #:unprofile-all
59     #:profile-package
60 heller 1.189 #:default-directory
61 heller 1.150 #:set-default-directory
62 trittweiler 1.585 #:quit-lisp))
63 dbarlow 1.27
64 heller 1.265 (in-package :swank)
65 heller 1.189
66 heller 1.343
67 lgorrie 1.194 ;;;; Top-level variables, constants, macros
68    
69     (defconstant cl-package (find-package :cl)
70     "The COMMON-LISP package.")
71    
72     (defconstant keyword-package (find-package :keyword)
73     "The KEYWORD package.")
74 heller 1.31
75 heller 1.278 (defvar *canonical-package-nicknames*
76 heller 1.348 `((:common-lisp-user . :cl-user))
77 pseibel 1.211 "Canonical package names to use instead of shortest name/nickname.")
78    
79     (defvar *auto-abbreviate-dotted-packages* t
80 heller 1.348 "Abbreviate dotted package names to their last component if T.")
81 pseibel 1.211
82 dbarlow 1.27 (defvar *swank-io-package*
83 heller 1.153 (let ((package (make-package :swank-io-package :use '())))
84 heller 1.26 (import '(nil t quote) package)
85 ellerh 1.7 package))
86    
87 lgorrie 1.194 (defconstant default-server-port 4005
88     "The default TCP port for the server (when started manually).")
89 dbarlow 1.28
90     (defvar *swank-debug-p* t
91     "When true, print extra debugging information.")
92    
93 heller 1.282 (defvar *sldb-printer-bindings*
94 heller 1.428 `((*print-pretty* . t)
95 heller 1.282 (*print-level* . 4)
96     (*print-length* . 10)
97     (*print-circle* . t)
98     (*print-readably* . nil)
99     (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
100     (*print-gensym* . t)
101     (*print-base* . 10)
102     (*print-radix* . nil)
103     (*print-array* . t)
104 heller 1.428 (*print-lines* . 10)
105 heller 1.453 (*print-escape* . t)
106 heller 1.520 (*print-right-margin* . 65))
107 heller 1.282 "A set of printer variables used in the debugger.")
108    
109 heller 1.574 (defvar *backtrace-pprint-dispatch-table*
110     (let ((table (copy-pprint-dispatch nil)))
111     (flet ((escape-string (stream string)
112 heller 1.594 (cond (*print-escape*
113     (write-char #\" stream)
114     (loop for c across string do
115     (case c
116     (#\" (write-string "\\\"" stream))
117     (#\newline (write-string "\\n" stream))
118     (#\return (write-string "\\r" stream))
119     (t (write-char c stream))))
120     (write-char #\" stream))
121 heller 1.602 (t (write-string string stream)))))
122 heller 1.574 (set-pprint-dispatch 'string #'escape-string 0 table)
123     table)))
124    
125 heller 1.520 (defvar *backtrace-printer-bindings*
126 heller 1.574 `((*print-pretty* . t)
127     (*print-readably* . nil)
128 heller 1.520 (*print-level* . 4)
129 heller 1.574 (*print-length* . 6)
130     (*print-lines* . 1)
131     (*print-right-margin* . 200)
132     (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
133 heller 1.520 "Pretter settings for printing backtraces.")
134    
135 heller 1.282 (defvar *default-worker-thread-bindings* '()
136     "An alist to initialize dynamic variables in worker threads.
137     The list has the form ((VAR . VALUE) ...). Each variable VAR will be
138     bound to the corresponding VALUE.")
139    
140     (defun call-with-bindings (alist fun)
141     "Call FUN with variables bound according to ALIST.
142     ALIST is a list of the form ((VAR . VAL) ...)."
143 heller 1.288 (let* ((rlist (reverse alist))
144     (vars (mapcar #'car rlist))
145     (vals (mapcar #'cdr rlist)))
146 heller 1.282 (progv vars vals
147     (funcall fun))))
148    
149 heller 1.288 (defmacro with-bindings (alist &body body)
150     "See `call-with-bindings'."
151     `(call-with-bindings ,alist (lambda () ,@body)))
152    
153 lgorrie 1.194 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
154     ;;; RPC.
155 heller 1.47
156 lgorrie 1.157 (defmacro defslimefun (name arglist &body rest)
157 lgorrie 1.194 "A DEFUN for functions that Emacs can call by RPC."
158 heller 1.47 `(progn
159 heller 1.250 (defun ,name ,arglist ,@rest)
160     ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
161     (eval-when (:compile-toplevel :load-toplevel :execute)
162 heller 1.568 (export ',name (symbol-package ',name)))))
163 heller 1.47
164 heller 1.113 (defun missing-arg ()
165 lgorrie 1.194 "A function that the compiler knows will never to return a value.
166     You can use (MISSING-ARG) as the initform for defstruct slots that
167     must always be supplied. This way the :TYPE slot option need not
168     include some arbitrary initial value like NIL."
169 heller 1.113 (error "A required &KEY or &OPTIONAL argument was not supplied."))
170    
171 heller 1.343
172 lgorrie 1.197 ;;;; Hooks
173     ;;;
174     ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
175     ;;; simple indirection. The interface is more CLish than the Emacs
176     ;;; Lisp one.
177    
178     (defmacro add-hook (place function)
179 heller 1.222 "Add FUNCTION to the list of values on PLACE."
180 lgorrie 1.197 `(pushnew ,function ,place))
181    
182     (defun run-hook (functions &rest arguments)
183     "Call each of FUNCTIONS with ARGUMENTS."
184     (dolist (function functions)
185     (apply function arguments)))
186    
187     (defvar *new-connection-hook* '()
188     "This hook is run each time a connection is established.
189     The connection structure is given as the argument.
190     Backend code should treat the connection structure as opaque.")
191    
192     (defvar *connection-closed-hook* '()
193     "This hook is run when a connection is closed.
194     The connection as passed as an argument.
195     Backend code should treat the connection structure as opaque.")
196    
197     (defvar *pre-reply-hook* '()
198     "Hook run (without arguments) immediately before replying to an RPC.")
199    
200 heller 1.405 (defvar *after-init-hook* '()
201     "Hook run after user init files are loaded.")
202    
203 heller 1.343
204 lgorrie 1.96 ;;;; Connections
205     ;;;
206     ;;; Connection structures represent the network connections between
207     ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
208     ;;; streams that redirect to Emacs, and optionally a second socket
209     ;;; used solely to pipe user-output to Emacs (an optimization).
210     ;;;
211 lgorrie 1.90
212     (defstruct (connection
213 lgorrie 1.215 (:conc-name connection.)
214     (:print-function print-connection))
215 lgorrie 1.90 ;; Raw I/O stream of socket connection.
216 heller 1.113 (socket-io (missing-arg) :type stream :read-only t)
217 lgorrie 1.96 ;; Optional dedicated output socket (backending `user-output' slot).
218     ;; Has a slot so that it can be closed with the connection.
219     (dedicated-output nil :type (or stream null))
220 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
221 lgorrie 1.96 ;; redirected to Emacs.
222     (user-input nil :type (or stream null))
223     (user-output nil :type (or stream null))
224 heller 1.112 (user-io nil :type (or stream null))
225 heller 1.615 ;; Bindings used for this connection (usually streams)
226     env
227 mkoeppe 1.499 ;; A stream that we use for *trace-output*; if nil, we user user-output.
228     (trace-output nil :type (or stream null))
229 mkoeppe 1.445 ;; A stream where we send REPL results.
230     (repl-results nil :type (or stream null))
231 lgorrie 1.194 ;; In multithreaded systems we delegate certain tasks to specific
232     ;; threads. The `reader-thread' is responsible for reading network
233     ;; requests from Emacs and sending them to the `control-thread'; the
234     ;; `control-thread' is responsible for dispatching requests to the
235     ;; threads that should handle them; the `repl-thread' is the one
236     ;; that evaluates REPL expressions. The control thread dispatches
237     ;; all REPL evaluations to the REPL thread and for other requests it
238     ;; spawns new threads.
239     reader-thread
240 heller 1.134 control-thread
241 lgorrie 1.173 repl-thread
242 heller 1.613 auto-flush-thread
243 lgorrie 1.194 ;; Callback functions:
244     ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
245     ;; from Emacs.
246     (serve-requests (missing-arg) :type function)
247     ;; (CLEANUP <this-connection>) is called when the connection is
248     ;; closed.
249 heller 1.113 (cleanup nil :type (or null function))
250 lgorrie 1.194 ;; Cache of macro-indentation information that has been sent to Emacs.
251     ;; This is used for preparing deltas to update Emacs's knowledge.
252     ;; Maps: symbol -> indentation-specification
253 lgorrie 1.157 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
254 lgorrie 1.194 ;; The list of packages represented in the cache:
255 heller 1.261 (indentation-cache-packages '())
256     ;; The communication style used.
257     (communication-style nil :type (member nil :spawn :sigio :fd-handler))
258 heller 1.264 ;; The coding system for network streams.
259 heller 1.566 coding-system
260     ;; The SIGINT handler we should restore when the connection is
261     ;; closed.
262     saved-sigint-handler)
263 lgorrie 1.215
264     (defun print-connection (conn stream depth)
265     (declare (ignore depth))
266     (print-unreadable-object (conn stream :type t :identity t)))
267 heller 1.115
268 lgorrie 1.157 (defvar *connections* '()
269     "List of all active connections, with the most recent at the front.")
270    
271 heller 1.112 (defvar *emacs-connection* nil
272 lgorrie 1.194 "The connection to Emacs currently in use.")
273 lgorrie 1.96
274 heller 1.115 (defvar *swank-state-stack* '()
275     "A list of symbols describing the current state. Used for debugging
276     and to detect situations where interrupts can be ignored.")
277 lgorrie 1.90
278 lgorrie 1.157 (defun default-connection ()
279     "Return the 'default' Emacs connection.
280 lgorrie 1.194 This connection can be used to talk with Emacs when no specific
281     connection is in use, i.e. *EMACS-CONNECTION* is NIL.
282    
283 lgorrie 1.157 The default connection is defined (quite arbitrarily) as the most
284     recently established one."
285 lgorrie 1.194 (first *connections*))
286 lgorrie 1.157
287 heller 1.112 (defslimefun state-stack ()
288 heller 1.115 "Return the value of *SWANK-STATE-STACK*."
289 heller 1.112 *swank-state-stack*)
290    
291 heller 1.587 (defslimefun ping (tag)
292     tag)
293    
294 heller 1.390 ;; A conditions to include backtrace information
295     (define-condition swank-error (error)
296     ((condition :initarg :condition :reader swank-error.condition)
297     (backtrace :initarg :backtrace :reader swank-error.backtrace))
298 lgorrie 1.90 (:report (lambda (condition stream)
299 heller 1.390 (princ (swank-error.condition condition) stream))))
300    
301     (defun make-swank-error (condition)
302 heller 1.556 (make-condition 'swank-error :condition condition
303     :backtrace (safe-backtrace)))
304    
305     (defun safe-backtrace ()
306     (ignore-errors
307     (call-with-debugging-environment
308     (lambda () (backtrace 0 nil)))))
309 lgorrie 1.90
310 heller 1.563 (defvar *debug-on-swank-error* nil
311     "When non-nil invoke the system debugger on swank internal errors.
312     Do not set this to T unless you want to debug swank internals.")
313    
314     (defmacro with-swank-error-handler ((connection) &body body)
315     (let ((var (gensym)))
316     `(let ((,var ,connection))
317     (handler-case
318     (handler-bind ((swank-error
319     (lambda (condition)
320     (when *debug-on-swank-error*
321     (invoke-default-debugger condition)))))
322     (progn ,@body))
323     (swank-error (condition)
324     (close-connection ,var
325     (swank-error.condition condition)
326     (swank-error.backtrace condition)))))))
327    
328     (defmacro with-panic-handler ((connection) &body body)
329     (let ((var (gensym)))
330     `(let ((,var ,connection))
331     (handler-bind ((serious-condition
332     (lambda (condition)
333     (close-connection ,var condition (safe-backtrace)))))
334     . ,body))))
335    
336 lgorrie 1.197 (add-hook *new-connection-hook* 'notify-backend-of-connection)
337     (defun notify-backend-of-connection (connection)
338 heller 1.261 (declare (ignore connection))
339     (emacs-connected))
340 lgorrie 1.197
341 heller 1.343
342 trittweiler 1.505 ;;;; Utilities
343    
344     ;;;;; Helper macros
345 lgorrie 1.96
346 heller 1.588 ;; If true execute interrupts, otherwise queue them.
347     ;; Note: `with-connection' binds *pending-slime-interrupts*.
348 heller 1.566 (defvar *slime-interrupts-enabled*)
349    
350 heller 1.588 (defmacro with-interrupts-enabled% (flag body)
351 heller 1.566 `(progn
352     (check-slime-interrupts)
353 heller 1.587 (multiple-value-prog1
354 heller 1.588 (let ((*slime-interrupts-enabled* ,flag))
355 heller 1.587 ,@body)
356     (check-slime-interrupts))))
357 heller 1.566
358 heller 1.588 (defmacro with-slime-interrupts (&body body)
359     `(with-interrupts-enabled% t ,body))
360    
361 heller 1.566 (defmacro without-slime-interrupts (&body body)
362 heller 1.588 `(with-interrupts-enabled% nil ,body))
363 heller 1.566
364     (defun invoke-or-queue-interrupt (function)
365 heller 1.619 (log-event "invoke-or-queue-interrupt: ~a~%" function)
366 heller 1.566 (cond ((not (boundp '*slime-interrupts-enabled*))
367     (without-slime-interrupts
368     (funcall function)))
369     (*slime-interrupts-enabled*
370 heller 1.619 (log-event "interrupts-enabled~%")
371 heller 1.566 (funcall function))
372     (t
373 heller 1.587 (setq *pending-slime-interrupts*
374     (nconc *pending-slime-interrupts*
375     (list function)))
376     (cond ((cdr *pending-slime-interrupts*)
377 heller 1.619 (log-event "too many queued interrupts~%")
378 heller 1.587 (check-slime-interrupts))
379     (t
380 heller 1.609 (log-event "queue-interrupt: ~a" function)
381     (signal 'slime-interrupt-queued))))))
382 heller 1.566
383     (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
384     (with-simple-restart (continue "Continue from break.")
385     (invoke-slime-debugger (coerce-to-condition datum args))))
386    
387     (defun coerce-to-condition (datum args)
388     (etypecase datum
389     (string (make-condition 'simple-error :format-control datum
390     :format-arguments args))
391     (symbol (apply #'make-condition datum args))))
392    
393 lgorrie 1.174 (defmacro with-io-redirection ((connection) &body body)
394 heller 1.615 "Execute BODY I/O redirection to CONNECTION. "
395     `(with-bindings (connection.env ,connection)
396     . ,body))
397 heller 1.293
398 heller 1.153 (defmacro with-connection ((connection) &body body)
399     "Execute BODY in the context of CONNECTION."
400 heller 1.293 `(call-with-connection ,connection (lambda () ,@body)))
401    
402 heller 1.563 (defun call-with-connection (connection function)
403 heller 1.587 (if (eq *emacs-connection* connection)
404     (funcall function)
405 heller 1.588 (let ((*emacs-connection* connection)
406     (*pending-slime-interrupts* '()))
407 heller 1.587 (without-slime-interrupts
408     (with-swank-error-handler (*emacs-connection*)
409     (with-io-redirection (*emacs-connection*)
410     (call-with-debugger-hook #'swank-debugger-hook function)))))))
411 lgorrie 1.96
412 trittweiler 1.584 (defun call-with-retry-restart (msg thunk)
413 heller 1.605 (loop (with-simple-restart (retry "~a" msg)
414     (return (funcall thunk)))))
415 trittweiler 1.584
416     (defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
417     (check-type msg string)
418     `(call-with-retry-restart ,msg #'(lambda () ,@body)))
419    
420     ;;; FIXME: Can this be removed with the introduction of
421     ;;; WITH/WITHOUT-SLIME-INTERRUPTS.
422 heller 1.103 (defmacro without-interrupts (&body body)
423     `(call-without-interrupts (lambda () ,@body)))
424 heller 1.112
425     (defmacro destructure-case (value &rest patterns)
426     "Dispatch VALUE to one of PATTERNS.
427     A cross between `case' and `destructuring-bind'.
428     The pattern syntax is:
429     ((HEAD . ARGS) . BODY)
430     The list of patterns is searched for a HEAD `eq' to the car of
431     VALUE. If one is found, the BODY is executed with ARGS bound to the
432     corresponding values in the CDR of VALUE."
433     (let ((operator (gensym "op-"))
434     (operands (gensym "rand-"))
435     (tmp (gensym "tmp-")))
436     `(let* ((,tmp ,value)
437     (,operator (car ,tmp))
438     (,operands (cdr ,tmp)))
439 heller 1.250 (case ,operator
440     ,@(loop for (pattern . body) in patterns collect
441     (if (eq pattern t)
442     `(t ,@body)
443     (destructuring-bind (op &rest rands) pattern
444     `(,op (destructuring-bind ,rands ,operands
445     ,@body)))))
446     ,@(if (eq (caar (last patterns)) t)
447     '()
448     `((t (error "destructure-case failed: ~S" ,tmp))))))))
449 heller 1.242
450 heller 1.556 (defmacro with-struct* ((conc-name get obj) &body body)
451     (let ((var (gensym)))
452     `(let ((,var ,obj))
453     (macrolet ((,get (slot)
454     (let ((getter (intern (concatenate 'string
455     ',(string conc-name)
456     (string slot))
457     (symbol-package ',conc-name))))
458     `(,getter ,',var))))
459     ,@body))))
460    
461 lgorrie 1.157 (defmacro with-temp-package (var &body body)
462     "Execute BODY with VAR bound to a temporary package.
463     The package is deleted before returning."
464     `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
465 heller 1.250 (unwind-protect (progn ,@body)
466     (delete-package ,var))))
467 lgorrie 1.157
468 trittweiler 1.505 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
469     "Just like do-symbols, but makes sure a symbol is visited only once."
470     (let ((seen-ht (gensym "SEEN-HT")))
471     `(let ((,seen-ht (make-hash-table :test #'eq)))
472     (do-symbols (,var ,package ,result-form)
473     (unless (gethash ,var ,seen-ht)
474     (setf (gethash ,var ,seen-ht) t)
475     ,@body)))))
476    
477 heller 1.556 (defun use-threads-p ()
478     (eq (connection.communication-style *emacs-connection*) :spawn))
479    
480 heller 1.557 (defun current-thread-id ()
481     (thread-id (current-thread)))
482    
483 trittweiler 1.584
484 trittweiler 1.505
485     ;;;;; Logging
486    
487 heller 1.266 (defvar *log-events* nil)
488 heller 1.560 (defvar *log-output* nil) ; should be nil for image dumpers
489    
490     (defun init-log-output ()
491 heller 1.614 (unless *log-output*
492     (setq *log-output* (real-output-stream *error-output*))))
493    
494     (defun real-input-stream (stream)
495     (typecase stream
496     (synonym-stream
497     (real-input-stream (symbol-value (synonym-stream-symbol stream))))
498     (two-way-stream
499     (real-input-stream (two-way-stream-input-stream stream)))
500     (t stream)))
501    
502     (defun real-output-stream (stream)
503     (typecase stream
504     (synonym-stream
505     (real-output-stream (symbol-value (synonym-stream-symbol stream))))
506     (two-way-stream
507     (real-output-stream (two-way-stream-output-stream stream)))
508     (t stream)))
509 heller 1.560
510     (add-hook *after-init-hook* 'init-log-output)
511    
512 heller 1.356 (defvar *event-history* (make-array 40 :initial-element nil)
513     "A ring buffer to record events for better error messages.")
514     (defvar *event-history-index* 0)
515     (defvar *enable-event-history* t)
516 heller 1.266
517     (defun log-event (format-string &rest args)
518     "Write a message to *terminal-io* when *log-events* is non-nil.
519     Useful for low level debugging."
520 mbaringer 1.478 (with-standard-io-syntax
521     (let ((*print-readably* nil)
522     (*print-pretty* nil)
523     (*package* *swank-io-package*))
524     (when *enable-event-history*
525     (setf (aref *event-history* *event-history-index*)
526     (format nil "~?" format-string args))
527     (setf *event-history-index*
528     (mod (1+ *event-history-index*) (length *event-history*))))
529     (when *log-events*
530 heller 1.549 (write-string (escape-non-ascii (format nil "~?" format-string args))
531     *log-output*)
532 mbaringer 1.478 (force-output *log-output*)))))
533 heller 1.266
534 heller 1.356 (defun event-history-to-list ()
535     "Return the list of events (older events first)."
536     (let ((arr *event-history*)
537     (idx *event-history-index*))
538     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
539    
540     (defun dump-event-history (stream)
541     (dolist (e (event-history-to-list))
542     (dump-event e stream)))
543    
544     (defun dump-event (event stream)
545     (cond ((stringp event)
546     (write-string (escape-non-ascii event) stream))
547     ((null event))
548 heller 1.549 (t
549     (write-string
550     (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
551     stream))))
552 heller 1.356
553     (defun escape-non-ascii (string)
554     "Return a string like STRING but with non-ascii chars escaped."
555     (cond ((ascii-string-p string) string)
556     (t (with-output-to-string (out)
557     (loop for c across string do
558     (cond ((ascii-char-p c) (write-char c out))
559     (t (format out "\\x~4,'0X" (char-code c)))))))))
560    
561     (defun ascii-string-p (o)
562     (and (stringp o)
563     (every #'ascii-char-p o)))
564    
565     (defun ascii-char-p (c)
566     (<= (char-code c) 127))
567    
568 trittweiler 1.505
569     ;;;;; Symbols
570    
571     (defun symbol-status (symbol &optional (package (symbol-package symbol)))
572     "Returns one of
573    
574     :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
575    
576     :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
577    
578     :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
579     but is not _present_ in PACKAGE,
580    
581     or NIL if SYMBOL is not _accessible_ in PACKAGE.
582    
583    
584     Be aware not to get confused with :INTERNAL and how \"internal
585     symbols\" are defined in the spec; there is a slight mismatch of
586     definition with the Spec and what's commonly meant when talking
587     about internal symbols most times. As the spec says:
588    
589     In a package P, a symbol S is
590    
591     _accessible_ if S is either _present_ in P itself or was
592     inherited from another package Q (which implies
593     that S is _external_ in Q.)
594    
595     You can check that with: (AND (SYMBOL-STATUS S P) T)
596    
597    
598     _present_ if either P is the /home package/ of S or S has been
599     imported into P or exported from P by IMPORT, or
600     EXPORT respectively.
601    
602     Or more simply, if S is not _inherited_.
603    
604     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
605     (AND STATUS
606     (NOT (EQ STATUS :INHERITED))))
607    
608    
609     _external_ if S is going to be inherited into any package that
610     /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
611     DEFPACKAGE.
612    
613     Note that _external_ implies _present_, since to
614     make a symbol _external_, you'd have to use EXPORT
615     which will automatically make the symbol _present_.
616    
617     You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
618    
619    
620     _internal_ if S is _accessible_ but not _external_.
621    
622     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
623     (AND STATUS
624     (NOT (EQ STATUS :EXTERNAL))))
625    
626    
627     Notice that this is *different* to
628     (EQ (SYMBOL-STATUS S P) :INTERNAL)
629     because what the spec considers _internal_ is split up into two
630     explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
631     CL:FIND-SYMBOL does.
632    
633     The rationale is that most times when you speak about \"internal\"
634     symbols, you're actually not including the symbols inherited
635     from other packages, but only about the symbols directly specific
636     to the package in question.
637     "
638     (when package ; may be NIL when symbol is completely uninterned.
639     (check-type symbol symbol) (check-type package package)
640     (multiple-value-bind (present-symbol status)
641     (find-symbol (symbol-name symbol) package)
642     (and (eq symbol present-symbol) status))))
643    
644     (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
645     "True if SYMBOL is external in PACKAGE.
646     If PACKAGE is not specified, the home package of SYMBOL is used."
647     (eq (symbol-status symbol package) :external))
648    
649    
650     (defun classify-symbol (symbol)
651 trittweiler 1.539 "Returns a list of classifiers that classify SYMBOL according to its
652     underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
653     variable.) The list may contain the following classification
654     keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
655     :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
656 trittweiler 1.505 (check-type symbol symbol)
657 trittweiler 1.539 (flet ((type-specifier-p (s)
658     (or (documentation s 'type)
659     (not (eq (type-specifier-arglist s) :not-available)))))
660     (let (result)
661     (when (boundp symbol) (push (if (constantp symbol)
662     :constant :boundp) result))
663     (when (fboundp symbol) (push :fboundp result))
664     (when (type-specifier-p symbol) (push :typespec result))
665     (when (find-class symbol nil) (push :class result))
666     (when (macro-function symbol) (push :macro result))
667     (when (special-operator-p symbol) (push :special-operator result))
668     (when (find-package symbol) (push :package result))
669     (when (typep (ignore-errors (fdefinition symbol))
670     'generic-function)
671     (push :generic-function result))
672    
673     result)))
674 trittweiler 1.505
675     (defun symbol-classification->string (flags)
676 trittweiler 1.539 (format nil "~A~A~A~A~A~A~A~A"
677     (if (or (member :boundp flags)
678     (member :constant flags)) "b" "-")
679 trittweiler 1.505 (if (member :fboundp flags) "f" "-")
680     (if (member :generic-function flags) "g" "-")
681     (if (member :class flags) "c" "-")
682 trittweiler 1.539 (if (member :typespec flags) "t" "-")
683 trittweiler 1.505 (if (member :macro flags) "m" "-")
684     (if (member :special-operator flags) "s" "-")
685     (if (member :package flags) "p" "-")))
686 mbaringer 1.411
687 heller 1.343
688 lgorrie 1.90 ;;;; TCP Server
689 dbarlow 1.28
690 heller 1.377 (defvar *use-dedicated-output-stream* nil
691 mbaringer 1.313 "When T swank will attempt to create a second connection to
692     Emacs which is used just to send output.")
693 heller 1.352
694 mbaringer 1.313 (defvar *dedicated-output-stream-port* 0
695 heller 1.330 "Which port we should use for the dedicated output stream.")
696    
697 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
698 heller 1.79
699 mbaringer 1.413 (defvar *dont-close* nil
700     "Default value of :dont-close argument to start-server and
701     create-server.")
702    
703 heller 1.352 (defvar *dedicated-output-stream-buffering*
704     (if (eq *communication-style* :spawn) :full :none)
705     "The buffering scheme that should be used for the output stream.
706     Valid values are :none, :line, and :full.")
707    
708 heller 1.419 (defvar *coding-system* "iso-latin-1-unix")
709    
710 heller 1.521 (defvar *listener-sockets* nil
711     "A property list of lists containing style, socket pairs used
712     by swank server listeners, keyed on socket port number. They
713     are used to close sockets on server shutdown or restart.")
714    
715 heller 1.264 (defun start-server (port-file &key (style *communication-style*)
716 mbaringer 1.413 (dont-close *dont-close*)
717 heller 1.418 (coding-system *coding-system*))
718 lgorrie 1.212 "Start the server and write the listen port number to PORT-FILE.
719     This is the entry point for Emacs."
720 heller 1.516 (setup-server 0 (lambda (port)
721     (announce-server-port port-file port))
722     style dont-close
723     (find-external-format-or-lose coding-system)))
724 heller 1.178
725 lgorrie 1.194 (defun create-server (&key (port default-server-port)
726 heller 1.178 (style *communication-style*)
727 heller 1.418 (dont-close *dont-close*)
728     (coding-system *coding-system*))
729 lgorrie 1.212 "Start a SWANK server on PORT running in STYLE.
730     If DONT-CLOSE is true then the listen socket will accept multiple
731     connections, otherwise it will be closed after the first."
732 heller 1.264 (setup-server port #'simple-announce-function style dont-close
733 heller 1.418 (find-external-format-or-lose coding-system)))
734    
735     (defun find-external-format-or-lose (coding-system)
736     (or (find-external-format coding-system)
737     (error "Unsupported coding system: ~s" coding-system)))
738 heller 1.178
739 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
740    
741 heller 1.264 (defun setup-server (port announce-fn style dont-close external-format)
742 heller 1.111 (declare (type function announce-fn))
743 heller 1.560 (init-log-output)
744 heller 1.119 (let* ((socket (create-socket *loopback-interface* port))
745 heller 1.521 (local-port (local-port socket)))
746     (funcall announce-fn local-port)
747 heller 1.264 (flet ((serve ()
748     (serve-connection socket style dont-close external-format)))
749     (ecase style
750     (:spawn
751 heller 1.516 (initialize-multiprocessing
752     (lambda ()
753     (spawn (lambda ()
754 heller 1.537 (cond ((not dont-close) (serve))
755     (t (loop (ignore-errors (serve))))))
756     :name (cat "Swank " (princ-to-string port))))))
757 heller 1.264 ((:fd-handler :sigio)
758     (add-fd-handler socket (lambda () (serve))))
759 heller 1.349 ((nil) (loop do (serve) while dont-close)))
760 heller 1.521 (setf (getf *listener-sockets* port) (list style socket))
761     local-port)))
762    
763     (defun stop-server (port)
764     "Stop server running on PORT."
765     (let* ((socket-description (getf *listener-sockets* port))
766     (style (first socket-description))
767     (socket (second socket-description)))
768     (ecase style
769     (:spawn
770     (let ((thread-position
771     (position-if
772     (lambda (x)
773 heller 1.613 (string-equal (second x)
774     (cat "Swank " (princ-to-string port))))
775 heller 1.521 (list-threads))))
776     (when thread-position
777     (kill-nth-thread thread-position)
778     (close-socket socket)
779     (remf *listener-sockets* port))))
780     ((:fd-handler :sigio)
781     (remove-fd-handlers socket)
782     (close-socket socket)
783     (remf *listener-sockets* port)))))
784    
785     (defun restart-server (&key (port default-server-port)
786     (style *communication-style*)
787     (dont-close *dont-close*)
788     (coding-system *coding-system*))
789     "Stop the server listening on PORT, then start a new SWANK server
790     on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
791     will accept multiple connections, otherwise it will be closed after the
792     first."
793     (stop-server port)
794     (sleep 5)
795     (create-server :port port :style style :dont-close dont-close
796     :coding-system coding-system))
797    
798 lgorrie 1.96
799 heller 1.264 (defun serve-connection (socket style dont-close external-format)
800 dcrosher 1.368 (let ((closed-socket-p nil))
801     (unwind-protect
802     (let ((client (accept-authenticated-connection
803     socket :external-format external-format)))
804     (unless dont-close
805     (close-socket socket)
806     (setf closed-socket-p t))
807 heller 1.418 (let ((connection (create-connection client style)))
808 dcrosher 1.368 (run-hook *new-connection-hook* connection)
809     (push connection *connections*)
810     (serve-requests connection)))
811     (unless (or dont-close closed-socket-p)
812     (close-socket socket)))))
813 heller 1.112
814 lgorrie 1.296 (defun accept-authenticated-connection (&rest args)
815     (let ((new (apply #'accept-connection args))
816 dcrosher 1.368 (success nil))
817     (unwind-protect
818     (let ((secret (slime-secret)))
819     (when secret
820     (set-stream-timeout new 20)
821     (let ((first-val (decode-message new)))
822     (unless (and (stringp first-val) (string= first-val secret))
823     (error "Incoming connection doesn't know the password."))))
824     (set-stream-timeout new nil)
825     (setf success t))
826     (unless success
827     (close new :abort t)))
828 lgorrie 1.296 new))
829    
830     (defun slime-secret ()
831     "Finds the magic secret from the user's home directory. Returns nil
832     if the file doesn't exist; otherwise the first line of the file."
833     (with-open-file (in
834 lgorrie 1.297 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
835 lgorrie 1.296 :if-does-not-exist nil)
836     (and in (read-line in nil ""))))
837    
838 heller 1.112 (defun serve-requests (connection)
839 heller 1.115 "Read and process all requests on connections."
840 heller 1.112 (funcall (connection.serve-requests connection) connection))
841    
842 heller 1.94 (defun announce-server-port (file port)
843     (with-open-file (s file
844     :direction :output
845 lgorrie 1.296 :if-exists :error
846 heller 1.94 :if-does-not-exist :create)
847     (format s "~S~%" port))
848     (simple-announce-function port))
849 lgorrie 1.90
850 heller 1.115 (defun simple-announce-function (port)
851     (when *swank-debug-p*
852 heller 1.511 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
853     (force-output *log-output*)))
854 heller 1.115
855 heller 1.153 (defun open-streams (connection)
856 mkoeppe 1.445 "Return the 5 streams for IO redirection:
857     DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
858 heller 1.581 (let* ((output-fn (make-output-function connection))
859     (input-fn
860     (lambda ()
861     (with-connection (connection)
862     (with-simple-restart (abort-read
863     "Abort reading input from Emacs.")
864     (read-user-input-from-emacs)))))
865     (dedicated-output (if *use-dedicated-output-stream*
866     (open-dedicated-output-stream
867     (connection.socket-io connection))))
868     (out (make-output-stream output-fn))
869     (in (make-input-stream input-fn))
870     (out (or dedicated-output out))
871     (io (make-two-way-stream in out))
872     (repl-results (make-output-stream-for-target connection
873     :repl-result)))
874     (when (eq (connection.communication-style connection) :spawn)
875 heller 1.613 (setf (connection.auto-flush-thread connection)
876     (spawn (lambda () (auto-flush-loop out))
877     :name "auto-flush-thread")))
878 heller 1.581 (values dedicated-output in out io repl-results)))
879 lgorrie 1.90
880 heller 1.549 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
881 heller 1.153 (defun make-output-function (connection)
882 heller 1.549 "Create function to send user output to Emacs."
883 heller 1.559 (let ((i 0) (tag 0) (l 0))
884 heller 1.549 (lambda (string)
885     (with-connection (connection)
886 heller 1.591 (multiple-value-setq (i tag l)
887     (send-user-output string i tag l))))))
888    
889     (defvar *maximum-pipelined-output-chunks* 50)
890     (defvar *maximum-pipelined-output-length* (* 80 20 5))
891     (defun send-user-output (string pcount tag plength)
892     ;; send output with flow control
893     (when (or (> pcount *maximum-pipelined-output-chunks*)
894     (> plength *maximum-pipelined-output-length*))
895     (setf tag (mod (1+ tag) 1000))
896     (send-to-emacs `(:ping ,(current-thread-id) ,tag))
897     (with-simple-restart (abort "Abort sending output to Emacs.")
898     (wait-for-event `(:emacs-pong ,tag)))
899     (setf pcount 0)
900     (setf plength 0))
901     (send-to-emacs `(:write-string ,string))
902     (values (1+ pcount) tag (+ plength (length string))))
903 heller 1.97
904 mkoeppe 1.445 (defun make-output-function-for-target (connection target)
905     "Create a function to send user output to a specific TARGET in Emacs."
906     (lambda (string)
907     (with-connection (connection)
908     (with-simple-restart
909     (abort "Abort sending output to Emacs.")
910 mkoeppe 1.502 (send-to-emacs `(:write-string ,string ,target))))))
911 mkoeppe 1.445
912 mkoeppe 1.499 (defun make-output-stream-for-target (connection target)
913     "Create a stream that sends output to a specific TARGET in Emacs."
914 heller 1.581 (make-output-stream (make-output-function-for-target connection target)))
915 mkoeppe 1.499
916 heller 1.418 (defun open-dedicated-output-stream (socket-io)
917 lgorrie 1.90 "Open a dedicated output connection to the Emacs on SOCKET-IO.
918     Return an output stream suitable for writing program output.
919    
920     This is an optimized way for Lisp to deliver output to Emacs."
921 dcrosher 1.368 (let ((socket (create-socket *loopback-interface*
922     *dedicated-output-stream-port*)))
923     (unwind-protect
924     (let ((port (local-port socket)))
925     (encode-message `(:open-dedicated-output-stream ,port) socket-io)
926 heller 1.418 (let ((dedicated (accept-authenticated-connection
927     socket
928     :external-format
929     (or (ignore-errors
930     (stream-external-format socket-io))
931     :default)
932 dcrosher 1.368 :buffering *dedicated-output-stream-buffering*
933     :timeout 30)))
934     (close-socket socket)
935     (setf socket nil)
936     dedicated))
937     (when socket
938     (close-socket socket)))))
939 lgorrie 1.90
940 heller 1.597 ;; The restart that will be invoked when the user calls sldb-quit.
941     ;; This restart will be named "abort" because many people press "a"
942     ;; instead of "q" in the debugger.
943     (defvar *sldb-quit-restart*)
944    
945     ;; Establish a top-level restart and execute BODY.
946     ;; Execute K if the restart is invoked.
947     (defmacro with-top-level-restart ((connection k) &body body)
948     `(with-connection (,connection)
949     (restart-case
950     (let ((*sldb-quit-restart* (find-restart 'abort)))
951     . ,body)
952     (abort (&optional v)
953     :report "Return to SLIME's top level."
954     (declare (ignore v))
955     (force-user-output)
956     ,k))))
957 heller 1.456
958 heller 1.597 (defun handle-requests (connection &optional timeout)
959     "Read and process :emacs-rex requests.
960 heller 1.562 The processing is done in the extent of the toplevel restart."
961 heller 1.597 (cond ((boundp '*sldb-quit-restart*)
962     (process-requests timeout))
963     (t
964     (tagbody
965     start
966     (with-top-level-restart (connection (go start))
967     (process-requests timeout))))))
968 heller 1.562
969 heller 1.597 (defun process-requests (timeout)
970 heller 1.562 "Read and process requests from Emacs."
971     (loop
972 heller 1.589 (multiple-value-bind (event timeout?)
973 heller 1.623 (wait-for-event `(or (:emacs-rex . _)
974     (:emacs-channel-send . _))
975     timeout)
976 heller 1.597 (when timeout? (return))
977 heller 1.623 (destructure-case event
978     ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
979     ((:emacs-channel-send channel (selector &rest args))
980     (channel-send channel selector args))))))
981 heller 1.97
982 heller 1.112 (defun current-socket-io ()
983     (connection.socket-io *emacs-connection*))
984    
985 heller 1.556 (defun close-connection (c condition backtrace)
986 heller 1.566 (let ((*debugger-hook* nil))
987 heller 1.579 (log-event "close-connection: ~a ...~%" condition)
988 heller 1.511 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
989 heller 1.113 (let ((cleanup (connection.cleanup c)))
990     (when cleanup
991     (funcall cleanup c)))
992 heller 1.112 (close (connection.socket-io c))
993     (when (connection.dedicated-output c)
994 lgorrie 1.157 (close (connection.dedicated-output c)))
995 lgorrie 1.197 (setf *connections* (remove c *connections*))
996 lgorrie 1.217 (run-hook *connection-closed-hook* c)
997 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
998 heller 1.511 (finish-output *log-output*)
999     (format *log-output* "~&;; Event history start:~%")
1000     (dump-event-history *log-output*)
1001     (format *log-output* ";; Event history end.~%~
1002 heller 1.390 ;; Backtrace:~%~{~A~%~}~
1003 heller 1.356 ;; Connection to Emacs lost. [~%~
1004     ;; condition: ~A~%~
1005     ;; type: ~S~%~
1006 heller 1.418 ;; encoding: ~A style: ~S dedicated: ~S]~%"
1007 heller 1.390 backtrace
1008 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
1009     (type-of condition)
1010 heller 1.418 (ignore-errors (stream-external-format (connection.socket-io c)))
1011 heller 1.356 (connection.communication-style c)
1012     *use-dedicated-output-stream*)
1013 heller 1.579 (finish-output *log-output*))
1014     (log-event "close-connection ~a ... done.~%" condition)))
1015 heller 1.180
1016     ;;;;;; Thread based communication
1017    
1018 heller 1.204 (defvar *active-threads* '())
1019    
1020 heller 1.555 (defun read-loop (connection)
1021 heller 1.556 (let ((input-stream (connection.socket-io connection))
1022     (control-thread (connection.control-thread connection)))
1023 heller 1.563 (with-swank-error-handler (connection)
1024 heller 1.555 (loop (send control-thread (decode-message input-stream))))))
1025    
1026     (defun dispatch-loop (connection)
1027 heller 1.556 (let ((*emacs-connection* connection))
1028 heller 1.563 (with-panic-handler (connection)
1029 heller 1.587 (loop (dispatch-event (receive))))))
1030 heller 1.241
1031 heller 1.554 (defvar *auto-flush-interval* 0.2)
1032    
1033     (defun auto-flush-loop (stream)
1034     (loop
1035     (when (not (and (open-stream-p stream)
1036     (output-stream-p stream)))
1037     (return nil))
1038     (finish-output stream)
1039     (sleep *auto-flush-interval*)))
1040    
1041 heller 1.556 (defun find-repl-thread (connection)
1042     (cond ((not (use-threads-p))
1043     (current-thread))
1044     (t
1045     (let ((thread (connection.repl-thread connection)))
1046 heller 1.619 (cond ((not thread) nil)
1047     ((thread-alive-p thread) thread)
1048 heller 1.556 (t
1049     (setf (connection.repl-thread connection)
1050     (spawn-repl-thread connection "new-repl-thread"))))))))
1051    
1052 heller 1.241 (defun find-worker-thread (id)
1053     (etypecase id
1054     ((member t)
1055     (car *active-threads*))
1056     ((member :repl-thread)
1057 heller 1.556 (find-repl-thread *emacs-connection*))
1058 heller 1.241 (fixnum
1059     (find-thread id))))
1060    
1061 heller 1.204 (defun interrupt-worker-thread (id)
1062 heller 1.241 (let ((thread (or (find-worker-thread id)
1063 heller 1.619 (find-repl-thread *emacs-connection*)
1064     ;; FIXME: to something better here
1065     (spawn (lambda ()) :name "ephemeral"))))
1066     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1067     (assert thread)
1068 heller 1.556 (signal-interrupt thread
1069 heller 1.619 (lambda ()
1070 heller 1.553 (invoke-or-queue-interrupt #'simple-break)))))
1071 heller 1.112
1072 heller 1.204 (defun thread-for-evaluation (id)
1073 heller 1.180 "Find or create a thread to evaluate the next request."
1074     (let ((c *emacs-connection*))
1075 heller 1.204 (etypecase id
1076 heller 1.180 ((member t)
1077 heller 1.556 (cond ((use-threads-p) (spawn-worker-thread c))
1078     (t (current-thread))))
1079 heller 1.180 ((member :repl-thread)
1080 heller 1.556 (find-repl-thread c))
1081 heller 1.180 (fixnum
1082 heller 1.204 (find-thread id)))))
1083 heller 1.274
1084     (defun spawn-worker-thread (connection)
1085     (spawn (lambda ()
1086 heller 1.288 (with-bindings *default-worker-thread-bindings*
1087 heller 1.597 (with-top-level-restart (connection nil)
1088     (apply #'eval-for-emacs
1089     (cdr (wait-for-event `(:emacs-rex . _)))))))
1090 heller 1.274 :name "worker"))
1091    
1092 heller 1.291 (defun spawn-repl-thread (connection name)
1093     (spawn (lambda ()
1094     (with-bindings *default-worker-thread-bindings*
1095     (repl-loop connection)))
1096     :name name))
1097    
1098 heller 1.557 (defun dispatch-event (event)
1099 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
1100 heller 1.556 (log-event "dispatch-event: ~s~%" event)
1101 heller 1.112 (destructure-case event
1102 heller 1.204 ((:emacs-rex form package thread-id id)
1103     (let ((thread (thread-for-evaluation thread-id)))
1104     (push thread *active-threads*)
1105 heller 1.557 (send-event thread `(:emacs-rex ,form ,package ,id))))
1106 heller 1.112 ((:return thread &rest args)
1107 heller 1.204 (let ((tail (member thread *active-threads*)))
1108     (setq *active-threads* (nconc (ldiff *active-threads* tail)
1109 heller 1.557 (cdr tail))))
1110     (encode-message `(:return ,@args) (current-socket-io)))
1111 heller 1.204 ((:emacs-interrupt thread-id)
1112     (interrupt-worker-thread thread-id))
1113 heller 1.622 (((:write-string
1114     :debug :debug-condition :debug-activate :debug-return :channel-send
1115 heller 1.557 :presentation-start :presentation-end
1116     :new-package :new-features :ed :%apply :indentation-update
1117     :eval :eval-no-wait :background-message :inspect :ping
1118     :y-or-n-p :read-string :read-aborted)
1119 heller 1.112 &rest _)
1120     (declare (ignore _))
1121 heller 1.557 (encode-message event (current-socket-io)))
1122     (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1123 heller 1.566 (send-event (find-thread thread-id) (cons (car event) args)))
1124 heller 1.623 ((:emacs-channel-send channel-id msg)
1125     (let ((ch (find-channel channel-id)))
1126     (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1127 heller 1.566 (((:end-of-stream))
1128 heller 1.569 (close-connection *emacs-connection* nil (safe-backtrace)))
1129     ((:reader-error packet condition)
1130     (encode-message `(:reader-error ,packet
1131     ,(safe-condition-message condition))
1132     (current-socket-io)))))
1133 heller 1.556
1134     (defvar *event-queue* '())
1135 heller 1.587 (defvar *events-enqueued* 0)
1136 heller 1.556
1137     (defun send-event (thread event)
1138     (log-event "send-event: ~s ~s~%" thread event)
1139     (cond ((use-threads-p) (send thread event))
1140 heller 1.587 (t (setf *event-queue* (nconc *event-queue* (list event)))
1141     (setf *events-enqueued* (mod (1+ *events-enqueued*)
1142     most-positive-fixnum)))))
1143 heller 1.556
1144     (defun send-to-emacs (event)
1145     "Send EVENT to Emacs."
1146 heller 1.566 ;;(log-event "send-to-emacs: ~a" event)
1147 heller 1.556 (cond ((use-threads-p)
1148     (send (connection.control-thread *emacs-connection*) event))
1149     (t (dispatch-event event))))
1150    
1151 heller 1.619 (defun signal-interrupt (thread interrupt)
1152     (log-event "signal-interrupt [~a]: ~a ~a~%" (use-threads-p) thread interrupt)
1153 heller 1.556 (cond ((use-threads-p) (interrupt-thread thread interrupt))
1154     (t (funcall interrupt))))
1155    
1156 heller 1.589 (defun wait-for-event (pattern &optional timeout)
1157 heller 1.562 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1158 heller 1.587 (without-slime-interrupts
1159     (cond ((use-threads-p)
1160     (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1161     (t
1162 heller 1.589 (wait-for-event/event-loop pattern timeout)))))
1163 heller 1.556
1164 heller 1.589 (defun wait-for-event/event-loop (pattern timeout)
1165 heller 1.562 (assert (or (not timeout) (eq timeout t)))
1166 heller 1.556 (loop
1167 heller 1.589 (check-slime-interrupts)
1168 heller 1.587 (let ((event (poll-for-event pattern)))
1169     (when event (return (car event))))
1170     (let ((events-enqueued *events-enqueued*)
1171     (ready (wait-for-input (list (current-socket-io)) timeout)))
1172     (cond ((and timeout (not ready))
1173     (return (values nil t)))
1174     ((or (/= events-enqueued *events-enqueued*)
1175     (eq ready :interrupt))
1176     ;; rescan event queue, interrupts may enqueue new events
1177     )
1178     (t
1179     (assert (equal ready (list (current-socket-io))))
1180     (dispatch-event (decode-message (current-socket-io))))))))
1181    
1182     (defun poll-for-event (pattern)
1183     (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1184     *event-queue*)))
1185     (when tail
1186     (setq *event-queue* (nconc (ldiff *event-queue* tail)
1187     (cdr tail)))
1188     tail)))
1189 heller 1.556
1190     (defun event-match-p (event pattern)
1191     (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1192     (member pattern '(nil t)))
1193     (equal event pattern))
1194     ((symbolp pattern) t)
1195     ((consp pattern)
1196 heller 1.589 (case (car pattern)
1197     ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1198     (t (and (consp event)
1199     (and (event-match-p (car event) (car pattern))
1200     (event-match-p (cdr event) (cdr pattern)))))))
1201     (t (error "Invalid pattern: ~S" pattern))))
1202 heller 1.112
1203 heller 1.153 (defun spawn-threads-for-connection (connection)
1204 heller 1.555 (setf (connection.control-thread connection)
1205     (spawn (lambda () (control-thread connection))
1206     :name "control-thread"))
1207     connection)
1208    
1209     (defun control-thread (connection)
1210 heller 1.556 (with-struct* (connection. @ connection)
1211     (setf (@ control-thread) (current-thread))
1212     (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1213     :name "reader-thread"))
1214     (dispatch-loop connection)))
1215 heller 1.153
1216 lgorrie 1.236 (defun cleanup-connection-threads (connection)
1217 heller 1.266 (let ((threads (list (connection.repl-thread connection)
1218     (connection.reader-thread connection)
1219 heller 1.613 (connection.control-thread connection)
1220     (connection.auto-flush-thread connection))))
1221 heller 1.266 (dolist (thread threads)
1222 heller 1.357 (when (and thread
1223     (thread-alive-p thread)
1224     (not (equal (current-thread) thread)))
1225 heller 1.266 (kill-thread thread)))))
1226 lgorrie 1.236
1227 lgorrie 1.173 (defun repl-loop (connection)
1228 heller 1.562 (handle-requests connection))
1229 heller 1.396
1230 heller 1.123 ;;;;;; Signal driven IO
1231    
1232 heller 1.112 (defun install-sigio-handler (connection)
1233 heller 1.566 (add-sigio-handler (connection.socket-io connection)
1234     (lambda () (process-io-interrupt connection)))
1235 heller 1.597 (handle-requests connection t))
1236 heller 1.566
1237 heller 1.579 (defvar *io-interupt-level* 0)
1238    
1239 heller 1.566 (defun process-io-interrupt (connection)
1240 heller 1.578 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1241     (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1242     (invoke-or-queue-interrupt
1243 heller 1.597 (lambda () (handle-requests connection t))))
1244 heller 1.578 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1245 heller 1.566
1246 heller 1.123 (defun deinstall-sigio-handler (connection)
1247 heller 1.566 (log-event "deinstall-sigio-handler...~%")
1248 heller 1.579 (remove-sigio-handlers (connection.socket-io connection))
1249 heller 1.566 (log-event "deinstall-sigio-handler...done~%"))
1250 heller 1.123
1251     ;;;;;; SERVE-EVENT based IO
1252    
1253     (defun install-fd-handler (connection)
1254 heller 1.566 (add-fd-handler (connection.socket-io connection)
1255 heller 1.597 (lambda () (handle-requests connection t)))
1256 heller 1.566 (setf (connection.saved-sigint-handler connection)
1257 heller 1.567 (install-sigint-handler
1258     (lambda ()
1259     (invoke-or-queue-interrupt
1260     (lambda ()
1261 heller 1.571 (with-connection (connection)
1262 heller 1.587 (dispatch-interrupt-event)))))))
1263 heller 1.597 (handle-requests connection t))
1264 heller 1.123
1265 heller 1.587 (defun dispatch-interrupt-event ()
1266     (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
1267    
1268 heller 1.123 (defun deinstall-fd-handler (connection)
1269 heller 1.577 (log-event "deinstall-fd-handler~%")
1270 heller 1.566 (remove-fd-handlers (connection.socket-io connection))
1271     (install-sigint-handler (connection.saved-sigint-handler connection)))
1272 heller 1.123
1273     ;;;;;; Simple sequential IO
1274 heller 1.112
1275     (defun simple-serve-requests (connection)
1276 heller 1.390 (unwind-protect
1277 heller 1.566 (call-with-user-break-handler
1278 heller 1.567 (lambda ()
1279 heller 1.587 (invoke-or-queue-interrupt #'dispatch-interrupt-event))
1280 heller 1.566 (lambda ()
1281     (with-simple-restart (close-connection "Close SLIME connection")
1282 heller 1.614 ;;(handle-requests connection)
1283     (let* ((stdin (real-input-stream *standard-input*))
1284     (*standard-input* (make-repl-input-stream connection
1285     stdin)))
1286 heller 1.619 (with-connection (connection)
1287     (simple-repl))))))
1288 heller 1.556 (close-connection connection nil (safe-backtrace))))
1289 heller 1.112
1290 heller 1.614 (defun simple-repl ()
1291     (loop
1292     (with-simple-restart (abort "Abort")
1293     (format t "~&~a> " (package-string-for-prompt *package*))
1294     (force-output)
1295     (let ((form (read)))
1296     (fresh-line)
1297     (let ((- form)
1298     (values (multiple-value-list (eval form))))
1299     (setq *** ** ** * * (car values)
1300     /// // // / / values
1301     +++ ++ ++ + + form)
1302     (cond ((null values) (format t "~&; No values"))
1303     (t (mapc (lambda (v) (format t "~&~s" v)) values))))))))
1304    
1305     (defun make-repl-input-stream (connection stdin)
1306     (make-input-stream
1307     (lambda ()
1308     (loop
1309     (let* ((socket (connection.socket-io connection))
1310     (inputs (list socket stdin))
1311     (ready (wait-for-input inputs)))
1312     (cond ((eq ready :interrupt)
1313     (check-slime-interrupts))
1314     ((member socket ready)
1315     (handle-requests connection t))
1316     ((member stdin ready)
1317     (return (read-non-blocking stdin)))
1318     (t (assert (null ready)))))))))
1319    
1320     (defun read-non-blocking (stream)
1321     (with-output-to-string (str)
1322     (loop (let ((c (read-char-no-hang stream)))
1323     (unless c (return))
1324     (write-char c str)))))
1325    
1326 heller 1.418 (defun create-connection (socket-io style)
1327 dcrosher 1.368 (let ((success nil))
1328     (unwind-protect
1329     (let ((c (ecase style
1330     (:spawn
1331     (make-connection :socket-io socket-io
1332     :serve-requests #'spawn-threads-for-connection
1333     :cleanup #'cleanup-connection-threads))
1334     (:sigio
1335     (make-connection :socket-io socket-io
1336     :serve-requests #'install-sigio-handler
1337     :cleanup #'deinstall-sigio-handler))
1338     (:fd-handler
1339     (make-connection :socket-io socket-io
1340     :serve-requests #'install-fd-handler
1341     :cleanup #'deinstall-fd-handler))
1342     ((nil)
1343     (make-connection :socket-io socket-io
1344 heller 1.549 :serve-requests #'simple-serve-requests))
1345     )))
1346 dcrosher 1.368 (setf (connection.communication-style c) style)
1347     (setf success t)
1348     c)
1349     (unless success
1350     (close socket-io :abort t)))))
1351 heller 1.180
1352 lgorrie 1.80
1353 lgorrie 1.62 ;;;; IO to Emacs
1354     ;;;
1355 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
1356     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1357     ;;; contains the appropriate streams, so all we have to do is make the
1358     ;;; right bindings.
1359    
1360     ;;;;; Global I/O redirection framework
1361     ;;;
1362     ;;; Optionally, the top-level global bindings of the standard streams
1363     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1364     ;;; redirect the streams into the connection, and they keep going into
1365     ;;; that connection even if more are established. If the connection
1366     ;;; handling the streams closes then another is chosen, or if there
1367     ;;; are no connections then we revert to the original (real) streams.
1368     ;;;
1369     ;;; It is slightly tricky to assign the global values of standard
1370     ;;; streams because they are often shadowed by dynamic bindings. We
1371     ;;; solve this problem by introducing an extra indirection via synonym
1372     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1373     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1374     ;;; variables, so they can always be assigned to affect a global
1375     ;;; change.
1376    
1377 heller 1.405 (defvar *globally-redirect-io* nil
1378 lgorrie 1.197 "When non-nil globally redirect all standard streams to Emacs.")
1379    
1380 heller 1.405 ;;;;; Global redirection setup
1381    
1382     (defvar *saved-global-streams* '()
1383     "A plist to save and restore redirected stream objects.
1384     E.g. the value for '*standard-output* holds the stream object
1385     for *standard-output* before we install our redirection.")
1386    
1387     (defun setup-stream-indirection (stream-var &optional stream)
1388 lgorrie 1.197 "Setup redirection scaffolding for a global stream variable.
1389     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1390    
1391 heller 1.405 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1392 lgorrie 1.197
1393     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1394     *STANDARD-INPUT*.
1395    
1396     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1397     *CURRENT-STANDARD-INPUT*.
1398    
1399     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1400 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
1401     the effective global value even when *STANDARD-INPUT* is shadowed by a
1402     dynamic binding."
1403 heller 1.405 (let ((current-stream-var (prefixed-var '#:current stream-var))
1404     (stream (or stream (symbol-value stream-var))))
1405     ;; Save the real stream value for the future.
1406     (setf (getf *saved-global-streams* stream-var) stream)
1407     ;; Define a new variable for the effective stream.
1408     ;; This can be reassigned.
1409     (proclaim `(special ,current-stream-var))
1410     (set current-stream-var stream)
1411     ;; Assign the real binding as a synonym for the current one.
1412     (set stream-var (make-synonym-stream current-stream-var))))
1413    
1414     (defun prefixed-var (prefix variable-symbol)
1415     "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1416     (let ((basename (subseq (symbol-name variable-symbol) 1)))
1417     (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1418 lgorrie 1.199
1419 heller 1.405 (defvar *standard-output-streams*
1420 lgorrie 1.197 '(*standard-output* *error-output* *trace-output*)
1421     "The symbols naming standard output streams.")
1422    
1423 heller 1.405 (defvar *standard-input-streams*
1424 lgorrie 1.197 '(*standard-input*)
1425     "The symbols naming standard input streams.")
1426    
1427 heller 1.405 (defvar *standard-io-streams*
1428 lgorrie 1.197 '(*debug-io* *query-io* *terminal-io*)
1429     "The symbols naming standard io streams.")
1430    
1431 heller 1.405 (defun init-global-stream-redirection ()
1432     (when *globally-redirect-io*
1433 heller 1.537 (assert (not *saved-global-streams*) () "Streams already redirected.")
1434     (mapc #'setup-stream-indirection
1435 heller 1.405 (append *standard-output-streams*
1436     *standard-input-streams*
1437     *standard-io-streams*))))
1438    
1439     (add-hook *after-init-hook* 'init-global-stream-redirection)
1440    
1441 lgorrie 1.197 (defun globally-redirect-io-to-connection (connection)
1442     "Set the standard I/O streams to redirect to CONNECTION.
1443     Assigns *CURRENT-<STREAM>* for all standard streams."
1444     (dolist (o *standard-output-streams*)
1445 dcrosher 1.363 (set (prefixed-var '#:current o)
1446 lgorrie 1.197 (connection.user-output connection)))
1447     ;; FIXME: If we redirect standard input to Emacs then we get the
1448     ;; regular Lisp top-level trying to read from our REPL.
1449     ;;
1450     ;; Perhaps the ideal would be for the real top-level to run in a
1451     ;; thread with local bindings for all the standard streams. Failing
1452     ;; that we probably would like to inhibit it from reading while
1453     ;; Emacs is connected.
1454     ;;
1455     ;; Meanwhile we just leave *standard-input* alone.
1456     #+NIL
1457     (dolist (i *standard-input-streams*)
1458 dcrosher 1.363 (set (prefixed-var '#:current i)
1459 lgorrie 1.197 (connection.user-input connection)))
1460     (dolist (io *standard-io-streams*)
1461 dcrosher 1.363 (set (prefixed-var '#:current io)
1462 lgorrie 1.197 (connection.user-io connection))))
1463    
1464     (defun revert-global-io-redirection ()
1465     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1466     (dolist (stream-var (append *standard-output-streams*
1467     *standard-input-streams*
1468     *standard-io-streams*))
1469 dcrosher 1.363 (set (prefixed-var '#:current stream-var)
1470 heller 1.405 (getf *saved-global-streams* stream-var))))
1471 lgorrie 1.197
1472     ;;;;; Global redirection hooks
1473    
1474     (defvar *global-stdio-connection* nil
1475     "The connection to which standard I/O streams are globally redirected.
1476     NIL if streams are not globally redirected.")
1477    
1478     (defun maybe-redirect-global-io (connection)
1479 heller 1.620 "Consider globally redirecting to CONNECTION."
1480     (when (and *globally-redirect-io* (null *global-stdio-connection*)
1481     (connection.user-io connection))
1482 lgorrie 1.197 (setq *global-stdio-connection* connection)
1483     (globally-redirect-io-to-connection connection)))
1484    
1485     (defun update-redirection-after-close (closed-connection)
1486     "Update redirection after a connection closes."
1487 heller 1.511 (check-type closed-connection connection)
1488 lgorrie 1.197 (when (eq *global-stdio-connection* closed-connection)
1489     (if (and (default-connection) *globally-redirect-io*)
1490     ;; Redirect to another connection.
1491     (globally-redirect-io-to-connection (default-connection))
1492     ;; No more connections, revert to the real streams.
1493     (progn (revert-global-io-redirection)
1494     (setq *global-stdio-connection* nil)))))
1495    
1496     (add-hook *connection-closed-hook* 'update-redirection-after-close)
1497    
1498     ;;;;; Redirection during requests
1499     ;;;
1500     ;;; We always redirect the standard streams to Emacs while evaluating
1501     ;;; an RPC. This is done with simple dynamic bindings.
1502 dbarlow 1.28
1503 heller 1.615 (defslimefun create-repl (target)
1504     (assert (eq target nil))
1505     (let ((conn *emacs-connection*))
1506     (initialize-streams-for-connection conn)
1507     (with-struct* (connection. @ conn)
1508     (setf (@ env)
1509     `((*standard-output* . ,(@ user-output))
1510 heller 1.616 (*standard-input* . ,(@ user-input))
1511     (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1512     (*error-output* . ,(@ user-output))
1513     (*debug-io* . ,(@ user-io))
1514     (*query-io* . ,(@ user-io))
1515     (*terminal-io* . ,(@ user-io))))
1516 heller 1.620 (maybe-redirect-global-io conn)
1517 heller 1.617 (when (use-threads-p)
1518 heller 1.615 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1519 heller 1.617 (list (package-name *package*)
1520     (package-string-for-prompt *package*)))))
1521 heller 1.615
1522     (defun initialize-streams-for-connection (connection)
1523     (multiple-value-bind (dedicated in out io repl-results)
1524     (open-streams connection)
1525     (setf (connection.dedicated-output connection) dedicated
1526     (connection.user-io connection) io
1527     (connection.user-output connection) out
1528     (connection.user-input connection) in
1529     (connection.repl-results connection) repl-results)
1530     connection))
1531 lgorrie 1.90
1532 heller 1.623
1533     ;;; Channels
1534    
1535     (progn
1536    
1537     (defvar *channels* '())
1538     (defvar *channel-counter* 0)
1539    
1540     (defclass channel ()
1541     ((id :reader channel-id)
1542     (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1543     (name :initarg :name :initform nil)))
1544    
1545     (defmethod initialize-instance ((ch channel) &rest initargs)
1546     (declare (ignore initargs))
1547     (call-next-method)
1548     (with-slots (id) ch
1549     (setf id (incf *channel-counter*))
1550     (push (cons id ch) *channels*)))
1551    
1552     (defmethod print-object ((c channel) stream)
1553     (print-unreadable-object (c stream :type t)
1554     (with-slots (id name) c
1555     (format stream "~d ~a" id name))))
1556    
1557     (defun find-channel (id)
1558     (cdr (assoc id *channels*)))
1559    
1560     (defgeneric channel-send (channel selector args))
1561    
1562     (defmacro define-channel-method (selector (channel &rest args) &body body)
1563     `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1564     (destructuring-bind ,args args
1565     . ,body)))
1566    
1567     (defun send-to-remote-channel (channel-id msg)
1568     (send-to-emacs `(:channel-send ,channel-id ,msg)))
1569    
1570     (defclass listener-channel (channel)
1571     ((remote :initarg :remote)
1572     (env :initarg :env)))
1573    
1574     (defslimefun create-listener (remote)
1575     (let* ((pkg *package*)
1576     (conn *emacs-connection*)
1577     (ch (make-instance 'listener-channel
1578     :remote remote
1579     :env (initial-listener-bindings remote))))
1580    
1581     (with-slots (thread id) ch
1582     (when (use-threads-p)
1583     (setf thread (spawn-listener-thread ch conn)))
1584     (list id
1585     (thread-id thread)
1586     (package-name pkg)
1587     (package-string-for-prompt pkg)))))
1588    
1589     (defun initial-listener-bindings (remote)
1590     `((*package* . ,*package*)
1591     (*standard-output*
1592     . ,(make-listener-output-stream remote))
1593     (*standard-input*
1594     . ,(make-listener-input-stream remote))))
1595    
1596     (defun spawn-listener-thread (channel connection)
1597     (spawn (lambda ()
1598     (with-connection (connection)
1599     (loop
1600     (destructure-case (wait-for-event `(:emacs-channel-send . _))
1601     ((:emacs-channel-send c (selector &rest args))
1602     (assert (eq c channel))
1603     (channel-send channel selector args))))))
1604     :name "swank-listener-thread"))
1605    
1606     (define-channel-method :eval ((c listener-channel) string)
1607     (with-slots (remote env) c
1608     (let ((aborted t))
1609     (with-bindings env
1610     (unwind-protect
1611     (let* ((form (read-from-string string))
1612     (value (eval form)))
1613     (send-to-remote-channel remote
1614     `(:write-result
1615     ,(prin1-to-string value)))
1616     (setq aborted nil))
1617     (force-output)
1618     (setf env (loop for (sym) in env
1619     collect (cons sym (symbol-value sym))))
1620     (let ((pkg (package-name *package*))
1621     (prompt (package-string-for-prompt *package*)))
1622     (send-to-remote-channel remote
1623     (if aborted
1624     `(:evaluation-aborted ,pkg ,prompt)
1625     `(:prompt ,pkg ,prompt)))))))))
1626    
1627     (defun make-listener-output-stream (remote)
1628     (make-output-stream (lambda (string)
1629     (send-to-remote-channel remote
1630     `(:write-string ,string)))))
1631    
1632     (defun make-listener-input-stream (remote)
1633     (make-input-stream
1634     (lambda ()
1635     (force-output)
1636     (let ((tag (make-tag)))
1637     (send-to-remote-channel remote
1638     `(:read-string ,(current-thread-id) ,tag))
1639     (let ((ok nil))
1640     (unwind-protect
1641     (prog1 (caddr (wait-for-event
1642     `(:emacs-return-string ,tag value)))
1643     (setq ok t))
1644     (unless ok
1645     (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1646    
1647     )
1648    
1649 trittweiler 1.545 (defun call-with-thread-description (description thunk)
1650 heller 1.553 ;; For `M-x slime-list-threads': Display what threads
1651     ;; created by swank are currently doing.
1652     (flet ((request-to-string (req)
1653     (remove #\Newline
1654     (string-trim '(#\Space #\Tab)
1655     (prin1-to-string req))))
1656     (truncate-string (str n)
1657     (format nil "~A..." (subseq str 0 (min (length str) n)))))
1658     (let* ((thread (current-thread))
1659     (old-description (thread-description thread)))
1660     (set-thread-description thread
1661     (truncate-string (request-to-string description)
1662     55))
1663     (unwind-protect (funcall thunk)
1664     (set-thread-description thread old-description)))))
1665 trittweiler 1.545
1666 heller 1.615
1667    
1668    
1669 trittweiler 1.545 (defmacro with-thread-description (description &body body)
1670     `(call-with-thread-description ,description #'(lambda () ,@body)))
1671    
1672 heller 1.587 (defun decode-message (stream)
1673 heller 1.390 "Read an S-expression from STREAM using the SLIME protocol."
1674 heller 1.566 ;;(log-event "decode-message~%")
1675 heller 1.112 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1676 heller 1.390 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1677 heller 1.587 (let ((packet (read-packet stream)))
1678     (handler-case (values (read-form packet) nil)
1679     (reader-error (c)
1680     `(:reader-error ,packet ,c)))))))
1681 heller 1.566
1682 heller 1.589 ;; use peek-char to detect EOF, read-sequence may return 0 instead of
1683     ;; signaling a condition.
1684 heller 1.566 (defun read-packet (stream)
1685 heller 1.589 (peek-char nil stream)
1686 heller 1.566 (let* ((header (read-chunk stream 6))
1687     (length (parse-integer header :radix #x10))
1688     (payload (read-chunk stream length)))
1689     (log-event "READ: ~S~%" payload)
1690     payload))
1691    
1692     (defun read-chunk (stream length)
1693     (let* ((buffer (make-string length))
1694     (count (read-sequence buffer stream)))
1695     (assert (= count length) () "Short read: length=~D count=~D" length count)
1696     buffer))
1697 dbarlow 1.28
1698     (defun read-form (string)
1699     (with-standard-io-syntax
1700     (let ((*package* *swank-io-package*))
1701     (read-from-string string))))
1702    
1703 heller 1.562 (defun input-available-p (stream)
1704     ;; return true iff we can read from STREAM without waiting or if we
1705     ;; hit EOF
1706     (let ((c (read-char-no-hang stream nil :eof)))
1707     (cond ((not c) nil)
1708     ((eq c :eof) t)
1709     (t
1710     (unread-char c stream)
1711     t))))
1712    
1713 lgorrie 1.50 (defvar *slime-features* nil
1714     "The feature list that has been sent to Emacs.")
1715    
1716 lgorrie 1.104 (defun send-oob-to-emacs (object)
1717 heller 1.112 (send-to-emacs object))
1718    
1719     (defun encode-message (message stream)
1720     (let* ((string (prin1-to-string-for-emacs message))
1721 heller 1.330 (length (length string)))
1722 heller 1.575 (assert (<= length #xffffff))
1723 heller 1.112 (log-event "WRITE: ~A~%" string)
1724 heller 1.575 (let ((*print-pretty* nil))
1725     (format stream "~6,'0x" length))
1726     (write-string string stream)
1727 heller 1.330 ;;(terpri stream)
1728 heller 1.357 (finish-output stream)))
1729 lgorrie 1.104
1730 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
1731 heller 1.31 (with-standard-io-syntax
1732     (let ((*print-case* :downcase)
1733 heller 1.185 (*print-readably* nil)
1734 heller 1.31 (*print-pretty* nil)
1735     (*package* *swank-io-package*))
1736     (prin1-to-string object))))
1737 dbarlow 1.28
1738 heller 1.112 (defun force-user-output ()
1739 heller 1.551 (force-output (connection.user-io *emacs-connection*)))
1740 heller 1.112
1741 heller 1.592 (add-hook *pre-reply-hook* 'force-user-output)
1742    
1743 heller 1.112 (defun clear-user-input ()
1744     (clear-input (connection.user-input *emacs-connection*)))
1745 lgorrie 1.62
1746 heller 1.557 (defvar *tag-counter* 0)
1747 lgorrie 1.91
1748 heller 1.557 (defun make-tag ()
1749     (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1750 heller 1.232
1751 heller 1.112 (defun read-user-input-from-emacs ()
1752 heller 1.557 (let ((tag (make-tag)))
1753 heller 1.117 (force-output)
1754 heller 1.557 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1755 lgorrie 1.90 (let ((ok nil))
1756 lgorrie 1.62 (unwind-protect
1757 heller 1.557 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1758 lgorrie 1.62 (setq ok t))
1759     (unless ok
1760 heller 1.557 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1761 mkoeppe 1.327
1762 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1763 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1764 heller 1.557 (let ((tag (make-tag))
1765 heller 1.330 (question (apply #'format nil format-string arguments)))
1766 mkoeppe 1.327 (force-output)
1767 heller 1.557 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1768     (caddr (wait-for-event `(:emacs-return ,tag result)))))
1769 mbaringer 1.279
1770 mbaringer 1.346 (defun process-form-for-emacs (form)
1771     "Returns a string which emacs will read as equivalent to
1772     FORM. FORM can contain lists, strings, characters, symbols and
1773     numbers.
1774    
1775     Characters are converted emacs' ?<char> notaion, strings are left
1776     as they are (except for espacing any nested \" chars, numbers are
1777 alendvai 1.447 printed in base 10 and symbols are printed as their symbol-name
1778 mbaringer 1.346 converted to lower case."
1779     (etypecase form
1780     (string (format nil "~S" form))
1781     (cons (format nil "(~A . ~A)"
1782     (process-form-for-emacs (car form))
1783     (process-form-for-emacs (cdr form))))
1784     (character (format nil "?~C" form))
1785 alendvai 1.447 (symbol (concatenate 'string (when (eq (symbol-package form)
1786     #.(find-package "KEYWORD"))
1787     ":")
1788     (string-downcase (symbol-name form))))
1789 mbaringer 1.346 (number (let ((*print-base* 10))
1790     (princ-to-string form)))))
1791    
1792 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1793     "Eval FORM in Emacs."
1794 mbaringer 1.346 (cond (nowait
1795     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1796     (t
1797     (force-output)
1798 heller 1.557 (let ((tag (make-tag)))
1799     (send-to-emacs `(:eval ,(current-thread-id) ,tag
1800     ,(process-form-for-emacs form)))
1801     (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1802     (destructure-case value
1803     ((:ok value) value)
1804     ((:abort) (abort))))))))
1805 heller 1.337
1806 mbaringer 1.414 (defvar *swank-wire-protocol-version* nil
1807 heller 1.418 "The version of the swank/slime communication protocol.")
1808 mbaringer 1.414
1809 heller 1.126 (defslimefun connection-info ()
1810 heller 1.343 "Return a key-value list of the form:
1811 heller 1.418 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1812 heller 1.343 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1813     STYLE: the communication style
1814 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1815 heller 1.343 FEATURES: a list of keywords
1816 mbaringer 1.413 PACKAGE: a list (&key NAME PROMPT)
1817 heller 1.418 VERSION: the protocol version"
1818 heller 1.260 (setq *slime-features* *features*)
1819 heller 1.343 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1820     :lisp-implementation (:type ,(lisp-implementation-type)
1821 heller 1.350 :name ,(lisp-implementation-type-name)
1822 heller 1.343 :version ,(lisp-implementation-version))
1823     :machine (:instance ,(machine-instance)
1824     :type ,(machine-type)
1825     :version ,(machine-version))
1826     :features ,(features-for-emacs)
1827 heller 1.518 :modules ,*modules*
1828 heller 1.343 :package (:name ,(package-name *package*)
1829 mbaringer 1.413 :prompt ,(package-string-for-prompt *package*))
1830 heller 1.418 :version ,*swank-wire-protocol-version*))
1831 lgorrie 1.62
1832 heller 1.551 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1833 heller 1.339 (let* ((s *standard-output*)
1834     (*trace-output* (make-broadcast-stream s *log-output*)))
1835 heller 1.337 (time (progn
1836     (dotimes (i n)
1837     (format s "~D abcdefghijklm~%" i)
1838     (when (zerop (mod n m))
1839 heller 1.551 (finish-output s)))
1840 heller 1.337 (finish-output s)
1841 heller 1.339 (when *emacs-connection*
1842     (eval-in-emacs '(message "done.")))))
1843     (terpri *trace-output*)
1844     (finish-output *trace-output*)
1845 heller 1.337 nil))
1846    
1847 lgorrie 1.62
1848     ;;;; Reading and printing
1849 dbarlow 1.28
1850 heller 1.207 (defmacro define-special (name doc)
1851     "Define a special variable NAME with doc string DOC.
1852 heller 1.232 This is like defvar, but NAME will not be initialized."
1853 heller 1.207 `(progn
1854     (defvar ,name)
1855 heller 1.240 (setf (documentation ',name 'variable) ,doc)))
1856 heller 1.207
1857     (define-special *buffer-package*
1858     "Package corresponding to slime-buffer-package.
1859 dbarlow 1.28
1860 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1861 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1862    
1863 heller 1.207 (define-special *buffer-readtable*
1864     "Readtable associated with the current buffer")
1865 heller 1.189
1866 heller 1.568 (defmacro with-buffer-syntax ((&optional package) &body body)
1867 heller 1.189 "Execute BODY with appropriate *package* and *readtable* bindings.
1868    
1869     This should be used for code that is conceptionally executed in an
1870     Emacs buffer."
1871 heller 1.568 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1872 heller 1.293
1873 heller 1.568 (defun call-with-buffer-syntax (package fun)
1874     (let ((*package* (if package
1875     (guess-buffer-package package)
1876     *buffer-package*)))
1877 heller 1.293 ;; Don't shadow *readtable* unnecessarily because that prevents
1878     ;; the user from assigning to it.
1879     (if (eq *readtable* *buffer-readtable*)
1880     (call-with-syntax-hooks fun)
1881     (let ((*readtable* *buffer-readtable*))
1882     (call-with-syntax-hooks fun)))))
1883 heller 1.189
1884 heller 1.330 (defun to-string (object)
1885     "Write OBJECT in the *BUFFER-PACKAGE*.
1886 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1887     gracefully."
1888 heller 1.330 (with-buffer-syntax ()
1889     (let ((*print-readably* nil))
1890 nsiivola 1.354 (handler-case
1891     (prin1-to-string object)
1892     (error ()
1893     (with-output-to-string (s)
1894     (print-unreadable-object (object s :type t :identity t)
1895     (princ "<<error printing object>>" s))))))))
1896 heller 1.330
1897 dbarlow 1.28 (defun from-string (string)
1898     "Read string in the *BUFFER-PACKAGE*"
1899 heller 1.189 (with-buffer-syntax ()
1900     (let ((*read-suppress* nil))
1901     (read-from-string string))))
1902 lgorrie 1.60
1903 heller 1.568 (defun parse-string (string package)
1904     "Read STRING in PACKAGE."
1905     (with-buffer-syntax (package)
1906     (let ((*read-suppress* nil))
1907     (read-from-string string))))
1908    
1909 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
1910     (defun tokenize-symbol (string)
1911 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
1912     and is tokenized accordingly. The result is returned in three
1913     values: The package identifier part, the actual symbol identifier
1914     part, and a flag if the STRING represents a symbol that is
1915     internal to the package identifier part. (Notice that the flag is
1916     also true with an empty package identifier part, as the STRING is
1917     considered to represent a symbol internal to some current package.)"
1918 heller 1.245 (let ((package (let ((pos (position #\: string)))
1919     (if pos (subseq string 0 pos) nil)))
1920     (symbol (let ((pos (position #\: string :from-end t)))
1921     (if pos (subseq string (1+ pos)) string)))
1922 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
1923 heller 1.245 (values symbol package internp)))
1924    
1925 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1926 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
1927 mkoeppe 1.370 (let ((package nil)
1928     (token (make-array (length string) :element-type 'character
1929     :fill-pointer 0))
1930     (backslash nil)
1931     (vertical nil)
1932     (internp nil))
1933     (loop for char across string
1934     do (cond
1935     (backslash
1936     (vector-push-extend char token)
1937     (setq backslash nil))
1938     ((char= char #\\) ; Quotes next character, even within |...|
1939     (setq backslash t))
1940     ((char= char #\|)
1941     (setq vertical t))
1942     (vertical
1943     (vector-push-extend char token))
1944     ((char= char #\:)
1945     (if package
1946     (setq internp t)
1947     (setq package token
1948     token (make-array (length string)
1949     :element-type 'character
1950     :fill-pointer 0))))
1951     (t
1952     (vector-push-extend (casify-char char) token))))
1953 mbaringer 1.467 (values token package (or (not package) internp))))
1954 mkoeppe 1.370
1955 trittweiler 1.488 (defun untokenize-symbol (package-name internal-p symbol-name)
1956     "The inverse of TOKENIZE-SYMBOL.
1957    
1958     (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1959     (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1960     (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1961     "
1962 heller 1.507 (cond ((not package-name) symbol-name)
1963     (internal-p (cat package-name "::" symbol-name))
1964     (t (cat package-name ":" symbol-name))))
1965 trittweiler 1.488
1966 mkoeppe 1.370 (defun casify-char (char)
1967     "Convert CHAR accoring to readtable-case."
1968 heller 1.245 (ecase (readtable-case *readtable*)
1969 mkoeppe 1.370 (:preserve char)
1970     (:upcase (char-upcase char))
1971     (:downcase (char-downcase char))
1972     (:invert (if (upper-case-p char)
1973     (char-downcase char)
1974     (char-upcase char)))))
1975 heller 1.245
1976 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1977 heller 1.189 "Find the symbol named STRING.
1978 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1979 mkoeppe 1.370 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1980 heller 1.277 (let ((package (cond ((string= pname "") keyword-package)
1981 mkoeppe 1.370 (pname (find-package pname))
1982 heller 1.277 (t package))))
1983     (if package
1984 trittweiler 1.500 (multiple-value-bind (symbol flag) (find-symbol sname package)
1985     (values symbol flag sname package))
1986     (values nil nil nil nil)))))
1987 heller 1.189
1988 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1989     (multiple-value-bind (symbol status) (parse-symbol string package)
1990     (if status
1991     (values symbol status)
1992 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
1993 heller 1.207
1994 heller 1.189 (defun parse-package (string)
1995     "Find the package named STRING.
1996     Return the package or nil."
1997 heller 1.517 ;; STRING comes usually from a (in-package STRING) form.
1998     (ignore-errors
1999     (find-package (let ((*package* *swank-io-package*))
2000     (read-from-string string)))))
2001 heller 1.190
2002 heller 1.458 (defun unparse-name (string)
2003     "Print the name STRING according to the current printer settings."
2004     ;; this is intended for package or symbol names
2005     (subseq (prin1-to-string (make-symbol string)) 2))
2006    
2007 heller 1.459 (defun guess-package (string)
2008     "Guess which package corresponds to STRING.
2009     Return nil if no package matches."
2010 nsiivola 1.595 (when string
2011     (or (find-package string)
2012     (parse-package string)
2013     (if (find #\! string) ; for SBCL
2014     (guess-package (substitute #\- #\! string))))))
2015 dbarlow 1.28
2016 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
2017 heller 1.189 "An alist mapping package names to readtables.")
2018    
2019 heller 1.459 (defun guess-buffer-readtable (package-name)
2020     (let ((package (guess-package package-name)))
2021     (or (and package
2022     (cdr (assoc (package-name package) *readtable-alist*
2023     :test #'string=)))
2024     *readtable*)))
2025 heller 1.189
2026 lgorrie 1.62
2027 lgorrie 1.218 ;;;; Evaluation
2028    
2029 heller 1.278 (defvar *pending-continuations* '()
2030     "List of continuations for Emacs. (thread local)")
2031    
2032 lgorrie 1.218 (defun guess-buffer-package (string)
2033     "Return a package for STRING.
2034     Fall back to the the current if no such package exists."
2035 heller 1.459 (or (and string (guess-package string))
2036 lgorrie 1.218 *package*))
2037    
2038     (defun eval-for-emacs (form buffer-package id)
2039 mbaringer 1.466 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2040 lgorrie 1.218 Return the result to the continuation ID.
2041     Errors are trapped and invoke our debugger."
2042 heller 1.567 (let (ok result)
2043     (unwind-protect
2044     (let ((*buffer-package* (guess-buffer-package buffer-package))
2045     (*buffer-readtable* (guess-buffer-readtable buffer-package))
2046     (*pending-continuations* (cons id *pending-continuations*)))
2047     (check-type *buffer-package* package)
2048     (check-type *buffer-readtable* readtable)
2049 trittweiler 1.584 ;; APPLY would be cleaner than EVAL.
2050     ;;(setq result (apply (car form) (cdr form)))
2051     (setq result (with-slime-interrupts (eval form)))
2052 heller 1.567 (run-hook *pre-reply-hook*)
2053     (setq ok t))
2054     (send-to-emacs `(:return ,(current-thread)
2055     ,(if ok
2056     `(:ok ,result)
2057     `(:abort))
2058     ,id)))))
2059 lgorrie 1.218
2060 heller 1.337 (defvar *echo-area-prefix* "=> "
2061     "A prefix that `format-values-for-echo-area' should use.")
2062    
2063 lgorrie 1.218 (defun format-values-for-echo-area (values)
2064     (with-buffer-syntax ()
2065     (let ((*print-readably* nil))
2066 heller 1.242 (cond ((null values) "; No value")
2067 heller 1.525 ((and (integerp (car values)) (null (cdr values)))
2068 heller 1.242 (let ((i (car values)))
2069 heller 1.337 (format nil "~A~D (#x~X, #o~O, #b~B)"
2070     *echo-area-prefix* i i i i)))
2071 heller 1.511 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
2072 lgorrie 1.218
2073     (defslimefun interactive-eval (string)
2074 heller 1.331 (with-buffer-syntax ()
2075 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2076     (let ((values (multiple-value-list (eval (from-string string)))))
2077 heller 1.612 (fresh-line)
2078 trittweiler 1.584 (finish-output)
2079     (format-values-for-echo-area values)))))
2080 lgorrie 1.218
2081 heller 1.278 (defslimefun eval-and-grab-output (string)
2082     (with-buffer-syntax ()
2083 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2084     (let* ((s (make-string-output-stream))
2085     (*standard-output* s)
2086     (values (multiple-value-list (eval (from-string string)))))
2087     (list (get-output-stream-string s)
2088     (format nil "~{~S~^~%~}" values))))))
2089 heller 1.278
2090 heller 1.503 (defun eval-region (string)
2091     "Evaluate STRING.
2092     Return the results of the last form as a list and as secondary value the
2093     last form."
2094     (with-input-from-string (stream string)
2095     (let (- values)
2096     (loop
2097     (let ((form (read stream nil stream)))
2098     (when (eq form stream)
2099 heller 1.612 (fresh-line)
2100     (finish-output)
2101 heller 1.503 (return (values values -)))
2102     (setq - form)
2103     (setq values (multiple-value-list (eval form)))
2104     (finish-output))))))
2105 lgorrie 1.218
2106     (defslimefun interactive-eval-region (string)
2107     (with-buffer-syntax ()
2108 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2109     (format-values-for-echo-area (eval-region string)))))
2110 lgorrie 1.218
2111     (defslimefun re-evaluate-defvar (for