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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.636 - (hide annotations)
Sun Feb 22 14:18:47 2009 UTC (5 years, 2 months ago) by trittweiler
Branch: MAIN
Changes since 1.635: +3 -0 lines
	`M-x slime-format-string-expand' displays the expansion of a
	format string.

	* slime.el (slime-string-at-point) New.
	(slime-string-at-point-or-error): New.
	(slime-format-string-expand): New; use them.

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