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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.586 - (hide annotations)
Fri Sep 12 12:27:37 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.585: +24 -15 lines
	New faces: `sldb-restartable-frame-line-face',
	           `sldb-non-restartable-frame-line-face'.

	The former is the face for frames that are surely restartable, the
	latter for frames that are surely not restartable. If
	restartability of a frame cannot be reliably determined, the face
	`sldb-frame-line-face' is used.

	At the moment, determination of frame restartability is supported
	by the SBCL backend only.

	* slime.el (sldb-frame.string): New.
	(sldb-frame.number): New.
	(sldb-frame.plist): New.
	(sldb-prune-initial-frames): Use them.
	(sldb-insert-frames): Ditto.
	(sldb-compute-frame-face): New.
	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
	frames with one of the faces described above.

	* swank.lisp (defslimefun backtrace): Changed return value; each
	frame is now accompanied with a PLIST which at the moment can
	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
	is restartable, or not.

	* swank-backend.lisp (defstruct swank-frame): New structure.
	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
	(print-frame): Renamed to PRINT-SWANK-FRAME.

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