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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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