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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.572 - (hide annotations)
Fri Aug 22 14:28:40 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.571: +14 -10 lines
	Compiling a file `let*.lisp' on SBCL via C-c C-k resulted in an
	error, because it parsed the asterisk to a wild pathname. Fix
	that.

	* swank-backend.lisp (definterface parse-emacs-filename): New.
	PARSE-NAMESTRING by default.

	* swank-sbcl.lisp (defimplementation parse-emacs-filename): Use
	SB-EXT:PARSE-NATIVE-NAMESTRING.

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