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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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