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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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