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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.674 - (show annotations)
Thu Dec 10 23:15:42 2009 UTC (4 years, 4 months ago) by trittweiler
Branch: MAIN
Changes since 1.673: +43 -24 lines
	Add `M-x slime-toggle-debug-on-swank-error'.

	In "Debug on SWANK error" mode, errors which are normally caught
	to not annoy the user, will now drop into the debugger.

	Additionally, the backend won't do any backtrace magic so you'll
	see the full backtrace with all its glory details.

	SBCL only so far.

	* slime.el (slime-toggle-debug-on-swank-error): New.

	* swank.lisp (toggle-debug-on-swank-error): New slimefun.
	(debug-on-swank-error): New function. SETFable.
	(invoke-default-debugger): Use CALL-WITH-DEBUGGER-HOOK so we're
	trapped into the native debugger on SBCL (previously we weren't
	due to SB-EXT:*INVOKE-DEBUGGER-HOOK*.)

	* swank.lisp: Rename SWANK-ERROR to SWANK-PROTOCOL-ERROR.
1 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 ;;;
3 ;;; This code has been placed in the Public Domain. All warranties
4 ;;; are disclaimed.
5 ;;;
6 ;;;; swank.lisp
7 ;;;
8 ;;; 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
15 (defpackage :swank
16 (:use :cl :swank-backend :swank-match)
17 (:export #:startup-multiprocessing
18 #:start-server
19 #:create-server
20 #:stop-server
21 #:restart-server
22 #:ed-in-emacs
23 #:inspect-in-emacs
24 #:print-indentation-lossage
25 #:invoke-slime-debugger
26 #:swank-debugger-hook
27 #:emacs-inspect
28 ;;#:inspect-slot-for-emacs
29 ;; These are user-configurable variables:
30 #:*communication-style*
31 #:*dont-close*
32 #:*fasl-pathname-function*
33 #:*log-events*
34 #:*log-output*
35 #:*use-dedicated-output-stream*
36 #:*dedicated-output-stream-port*
37 #:*configure-emacs-indentation*
38 #:*readtable-alist*
39 #:*globally-redirect-io*
40 #:*global-debugger*
41 #:*backtrace-printer-bindings*
42 #:*default-worker-thread-bindings*
43 #:*macroexpand-printer-bindings*
44 #:*sldb-printer-bindings*
45 #:*swank-pprint-bindings*
46 #:*record-repl-results*
47 #:*inspector-verbose*
48 ;; This is SETFable.
49 #:debug-on-swank-error
50 ;; These are re-exported directly from the backend:
51 #:buffer-first-change
52 #:frame-source-location
53 #:restart-frame
54 #:sldb-step
55 #:sldb-break
56 #:sldb-break-on-return
57 #:profiled-functions
58 #:profile-report
59 #:profile-reset
60 #:unprofile-all
61 #:profile-package
62 #:default-directory
63 #:set-default-directory
64 #:quit-lisp))
65
66 (in-package :swank)
67
68
69 ;;;; Top-level variables, constants, macros
70
71 (defconstant cl-package (find-package :cl)
72 "The COMMON-LISP package.")
73
74 (defconstant keyword-package (find-package :keyword)
75 "The KEYWORD package.")
76
77 (defvar *canonical-package-nicknames*
78 `((:common-lisp-user . :cl-user))
79 "Canonical package names to use instead of shortest name/nickname.")
80
81 (defvar *auto-abbreviate-dotted-packages* t
82 "Abbreviate dotted package names to their last component if T.")
83
84 (defvar *swank-io-package*
85 (let ((package (make-package :swank-io-package :use '())))
86 (import '(nil t quote) package)
87 package))
88
89 (defconstant default-server-port 4005
90 "The default TCP port for the server (when started manually).")
91
92 (defvar *swank-debug-p* t
93 "When true, print extra debugging information.")
94
95 ;;;;; SLDB customized pprint dispatch table
96 ;;;
97 ;;; CLHS 22.1.3.4, and CLHS 22.1.3.6 do not specify *PRINT-LENGTH* to
98 ;;; affect the printing of strings and bit-vectors.
99 ;;;
100 ;;; We use a customized pprint dispatch table to do it for us.
101
102 (defvar *sldb-string-length* nil)
103 (defvar *sldb-bitvector-length* nil)
104
105 (defvar *sldb-pprint-dispatch-table*
106 (let ((initial-table (copy-pprint-dispatch nil))
107 (result-table (copy-pprint-dispatch nil)))
108 (flet ((sldb-bitvector-pprint (stream bitvector)
109 ;;; Truncate bit-vectors according to *SLDB-BITVECTOR-LENGTH*.
110 (if (not *sldb-bitvector-length*)
111 (write bitvector :stream stream :circle nil
112 :pprint-dispatch initial-table)
113 (loop initially (write-string "#*" stream)
114 for i from 0 and bit across bitvector do
115 (when (= i *sldb-bitvector-length*)
116 (write-string "..." stream)
117 (loop-finish))
118 (write-char (if (= bit 0) #\0 #\1) stream))))
119 (sldb-string-pprint (stream string)
120 ;;; Truncate strings according to *SLDB-STRING-LENGTH*.
121 (cond ((not *print-escape*)
122 (write-string string stream))
123 ((not *sldb-string-length*)
124 (write string :stream stream :circle nil
125 :pprint-dispatch initial-table))
126 (t
127 (escape-string string stream
128 :length *sldb-string-length*)))))
129 (set-pprint-dispatch 'bit-vector #'sldb-bitvector-pprint 0 result-table)
130 (set-pprint-dispatch 'string #'sldb-string-pprint 0 result-table)
131 result-table)))
132
133 (defvar *sldb-printer-bindings*
134 `((*print-pretty* . t)
135 (*print-level* . 4)
136 (*print-length* . 10)
137 (*print-circle* . t)
138 (*print-readably* . nil)
139 (*print-pprint-dispatch* . ,*sldb-pprint-dispatch-table*)
140 (*print-gensym* . t)
141 (*print-base* . 10)
142 (*print-radix* . nil)
143 (*print-array* . t)
144 (*print-lines* . nil)
145 (*print-escape* . t)
146 (*print-right-margin* . 65)
147 (*sldb-bitvector-length* . 25)
148 (*sldb-string-length* . 50))
149 "A set of printer variables used in the debugger.")
150
151 (defvar *backtrace-pprint-dispatch-table*
152 (let ((table (copy-pprint-dispatch nil)))
153 (flet ((print-string (stream string)
154 (cond (*print-escape*
155 (escape-string string stream
156 :map '((#\" . "\\\"")
157 (#\\ . "\\\\")
158 (#\newline . "\\n")
159 (#\return . "\\r"))))
160 (t (write-string string stream)))))
161 (set-pprint-dispatch 'string #'print-string 0 table)
162 table)))
163
164 (defvar *backtrace-printer-bindings*
165 `((*print-pretty* . t)
166 (*print-readably* . nil)
167 (*print-level* . 4)
168 (*print-length* . 6)
169 (*print-lines* . 1)
170 (*print-right-margin* . 200)
171 (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
172 "Pretter settings for printing backtraces.")
173
174 (defvar *default-worker-thread-bindings* '()
175 "An alist to initialize dynamic variables in worker threads.
176 The list has the form ((VAR . VALUE) ...). Each variable VAR will be
177 bound to the corresponding VALUE.")
178
179 (defun call-with-bindings (alist fun)
180 "Call FUN with variables bound according to ALIST.
181 ALIST is a list of the form ((VAR . VAL) ...)."
182 (let* ((rlist (reverse alist))
183 (vars (mapcar #'car rlist))
184 (vals (mapcar #'cdr rlist)))
185 (progv vars vals
186 (funcall fun))))
187
188 (defmacro with-bindings (alist &body body)
189 "See `call-with-bindings'."
190 `(call-with-bindings ,alist (lambda () ,@body)))
191
192 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
193 ;;; RPC.
194
195 (defmacro defslimefun (name arglist &body rest)
196 "A DEFUN for functions that Emacs can call by RPC."
197 `(progn
198 (defun ,name ,arglist ,@rest)
199 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
200 (eval-when (:compile-toplevel :load-toplevel :execute)
201 (export ',name (symbol-package ',name)))))
202
203 (defun missing-arg ()
204 "A function that the compiler knows will never to return a value.
205 You can use (MISSING-ARG) as the initform for defstruct slots that
206 must always be supplied. This way the :TYPE slot option need not
207 include some arbitrary initial value like NIL."
208 (error "A required &KEY or &OPTIONAL argument was not supplied."))
209
210
211 ;;;; Hooks
212 ;;;
213 ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
214 ;;; simple indirection. The interface is more CLish than the Emacs
215 ;;; Lisp one.
216
217 (defmacro add-hook (place function)
218 "Add FUNCTION to the list of values on PLACE."
219 `(pushnew ,function ,place))
220
221 (defun run-hook (functions &rest arguments)
222 "Call each of FUNCTIONS with ARGUMENTS."
223 (dolist (function functions)
224 (apply function arguments)))
225
226 (defvar *new-connection-hook* '()
227 "This hook is run each time a connection is established.
228 The connection structure is given as the argument.
229 Backend code should treat the connection structure as opaque.")
230
231 (defvar *connection-closed-hook* '()
232 "This hook is run when a connection is closed.
233 The connection as passed as an argument.
234 Backend code should treat the connection structure as opaque.")
235
236 (defvar *pre-reply-hook* '()
237 "Hook run (without arguments) immediately before replying to an RPC.")
238
239 (defvar *after-init-hook* '()
240 "Hook run after user init files are loaded.")
241
242
243 ;;;; Connections
244 ;;;
245 ;;; Connection structures represent the network connections between
246 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
247 ;;; streams that redirect to Emacs, and optionally a second socket
248 ;;; used solely to pipe user-output to Emacs (an optimization). This
249 ;;; is also the place where we keep everything that needs to be
250 ;;; freed/closed/killed when we disconnect.
251
252 (defstruct (connection
253 (:conc-name connection.)
254 (:print-function print-connection))
255 ;; Raw I/O stream of socket connection.
256 (socket-io (missing-arg) :type stream :read-only t)
257 ;; Optional dedicated output socket (backending `user-output' slot).
258 ;; Has a slot so that it can be closed with the connection.
259 (dedicated-output nil :type (or stream null))
260 ;; Streams that can be used for user interaction, with requests
261 ;; redirected to Emacs.
262 (user-input nil :type (or stream null))
263 (user-output nil :type (or stream null))
264 (user-io nil :type (or stream null))
265 ;; Bindings used for this connection (usually streams)
266 env
267 ;; A stream that we use for *trace-output*; if nil, we user user-output.
268 (trace-output nil :type (or stream null))
269 ;; A stream where we send REPL results.
270 (repl-results nil :type (or stream null))
271 ;; In multithreaded systems we delegate certain tasks to specific
272 ;; threads. The `reader-thread' is responsible for reading network
273 ;; requests from Emacs and sending them to the `control-thread'; the
274 ;; `control-thread' is responsible for dispatching requests to the
275 ;; threads that should handle them; the `repl-thread' is the one
276 ;; that evaluates REPL expressions. The control thread dispatches
277 ;; all REPL evaluations to the REPL thread and for other requests it
278 ;; spawns new threads.
279 reader-thread
280 control-thread
281 repl-thread
282 auto-flush-thread
283 ;; Callback functions:
284 ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
285 ;; from Emacs.
286 (serve-requests (missing-arg) :type function)
287 ;; (CLEANUP <this-connection>) is called when the connection is
288 ;; closed.
289 (cleanup nil :type (or null function))
290 ;; Cache of macro-indentation information that has been sent to Emacs.
291 ;; This is used for preparing deltas to update Emacs's knowledge.
292 ;; Maps: symbol -> indentation-specification
293 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
294 ;; The list of packages represented in the cache:
295 (indentation-cache-packages '())
296 ;; The communication style used.
297 (communication-style nil :type (member nil :spawn :sigio :fd-handler))
298 ;; The coding system for network streams.
299 coding-system
300 ;; The SIGINT handler we should restore when the connection is
301 ;; closed.
302 saved-sigint-handler)
303
304 (defun print-connection (conn stream depth)
305 (declare (ignore depth))
306 (print-unreadable-object (conn stream :type t :identity t)))
307
308 (defvar *connections* '()
309 "List of all active connections, with the most recent at the front.")
310
311 (defvar *emacs-connection* nil
312 "The connection to Emacs currently in use.")
313
314 (defvar *swank-state-stack* '()
315 "A list of symbols describing the current state. Used for debugging
316 and to detect situations where interrupts can be ignored.")
317
318 (defun default-connection ()
319 "Return the 'default' Emacs connection.
320 This connection can be used to talk with Emacs when no specific
321 connection is in use, i.e. *EMACS-CONNECTION* is NIL.
322
323 The default connection is defined (quite arbitrarily) as the most
324 recently established one."
325 (first *connections*))
326
327 (defslimefun state-stack ()
328 "Return the value of *SWANK-STATE-STACK*."
329 *swank-state-stack*)
330
331 (defslimefun ping (tag)
332 tag)
333
334 ;; A condition to include backtrace information
335 (define-condition swank-protocol-error (error)
336 ((condition :initarg :condition :reader swank-protocol-error.condition)
337 (backtrace :initarg :backtrace :reader swank-protocol-error.backtrace))
338 (:report (lambda (condition stream)
339 (princ (swank-protocol-error.condition condition) stream))))
340
341 (defun make-swank-protocol-error (condition)
342 (make-condition 'swank-protocol-error :condition condition
343 :backtrace (safe-backtrace)))
344
345 (defun safe-backtrace ()
346 (ignore-errors
347 (call-with-debugging-environment
348 (lambda () (backtrace 0 nil)))))
349
350 (defvar *debug-on-swank-protocol-error* nil
351 "When non-nil invoke the system debugger on errors that were
352 signalled during decoding/encoding the wire protocol. Do not set this
353 to T unless you want to debug swank internals.")
354
355 (defmacro with-swank-protocol-error-handler ((connection) &body body)
356 (let ((var (gensym)))
357 `(let ((,var ,connection))
358 (handler-case
359 (handler-bind ((swank-protocol-error
360 (lambda (condition)
361 (format t "~&+++ SWANK-PROTOCOL-ERROR: ~S ~S~%"
362 *debug-on-swank-protocol-error*
363 condition)
364 (when *debug-on-swank-protocol-error*
365 (format t "~&+++ INVOKE-DEFAULT-DEBUGGER +++ ~S~%" condition)
366 (invoke-default-debugger condition)))))
367 (progn ,@body))
368 (swank-protocol-error (condition)
369 (close-connection ,var
370 (swank-protocol-error.condition condition)
371 (swank-protocol-error.backtrace condition)))))))
372
373 (defmacro with-panic-handler ((connection) &body body)
374 (let ((var (gensym)))
375 `(let ((,var ,connection))
376 (handler-bind ((serious-condition
377 (lambda (condition)
378 (close-connection ,var condition (safe-backtrace)))))
379 . ,body))))
380
381 (add-hook *new-connection-hook* 'notify-backend-of-connection)
382 (defun notify-backend-of-connection (connection)
383 (declare (ignore connection))
384 (emacs-connected))
385
386
387 ;;;; Utilities
388
389 ;;;;; Helper macros
390
391 ;; If true execute interrupts, otherwise queue them.
392 ;; Note: `with-connection' binds *pending-slime-interrupts*.
393 (defvar *slime-interrupts-enabled*)
394
395 (defmacro with-interrupts-enabled% (flag body)
396 `(progn
397 (check-slime-interrupts)
398 (multiple-value-prog1
399 (let ((*slime-interrupts-enabled* ,flag))
400 ,@body)
401 (check-slime-interrupts))))
402
403 (defmacro with-slime-interrupts (&body body)
404 `(with-interrupts-enabled% t ,body))
405
406 (defmacro without-slime-interrupts (&body body)
407 `(with-interrupts-enabled% nil ,body))
408
409 (defun invoke-or-queue-interrupt (function)
410 (log-event "invoke-or-queue-interrupt: ~a~%" function)
411 (cond ((not (boundp '*slime-interrupts-enabled*))
412 (without-slime-interrupts
413 (funcall function)))
414 (*slime-interrupts-enabled*
415 (log-event "interrupts-enabled~%")
416 (funcall function))
417 (t
418 (setq *pending-slime-interrupts*
419 (nconc *pending-slime-interrupts*
420 (list function)))
421 (cond ((cdr *pending-slime-interrupts*)
422 (log-event "too many queued interrupts~%")
423 (check-slime-interrupts))
424 (t
425 (log-event "queue-interrupt: ~a" function)
426 (when *interrupt-queued-handler*
427 (funcall *interrupt-queued-handler*)))))))
428
429 (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
430 (with-simple-restart (continue "Continue from break.")
431 (invoke-slime-debugger (coerce-to-condition datum args))))
432
433 (defun coerce-to-condition (datum args)
434 (etypecase datum
435 (string (make-condition 'simple-error :format-control datum
436 :format-arguments args))
437 (symbol (apply #'make-condition datum args))))
438
439 (defmacro with-io-redirection ((connection) &body body)
440 "Execute BODY I/O redirection to CONNECTION. "
441 `(with-bindings (connection.env ,connection)
442 . ,body))
443
444 (defmacro with-connection ((connection) &body body)
445 "Execute BODY in the context of CONNECTION."
446 `(call-with-connection ,connection (lambda () ,@body)))
447
448 (defun call-with-connection (connection function)
449 (if (eq *emacs-connection* connection)
450 (funcall function)
451 (let ((*emacs-connection* connection)
452 (*pending-slime-interrupts* '()))
453 (without-slime-interrupts
454 (with-swank-protocol-error-handler (*emacs-connection*)
455 (with-io-redirection (*emacs-connection*)
456 (call-with-debugger-hook #'swank-debugger-hook function)))))))
457
458 (defun call-with-retry-restart (msg thunk)
459 (loop (with-simple-restart (retry "~a" msg)
460 (return (funcall thunk)))))
461
462 (defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
463 (check-type msg string)
464 `(call-with-retry-restart ,msg #'(lambda () ,@body)))
465
466 (defmacro destructure-case (value &rest patterns)
467 "Dispatch VALUE to one of PATTERNS.
468 A cross between `case' and `destructuring-bind'.
469 The pattern syntax is:
470 ((HEAD . ARGS) . BODY)
471 The list of patterns is searched for a HEAD `eq' to the car of
472 VALUE. If one is found, the BODY is executed with ARGS bound to the
473 corresponding values in the CDR of VALUE."
474 (let ((operator (gensym "op-"))
475 (operands (gensym "rand-"))
476 (tmp (gensym "tmp-")))
477 `(let* ((,tmp ,value)
478 (,operator (car ,tmp))
479 (,operands (cdr ,tmp)))
480 (case ,operator
481 ,@(loop for (pattern . body) in patterns collect
482 (if (eq pattern t)
483 `(t ,@body)
484 (destructuring-bind (op &rest rands) pattern
485 `(,op (destructuring-bind ,rands ,operands
486 ,@body)))))
487 ,@(if (eq (caar (last patterns)) t)
488 '()
489 `((t (error "destructure-case failed: ~S" ,tmp))))))))
490
491 (defmacro with-struct* ((conc-name get obj) &body body)
492 (let ((var (gensym)))
493 `(let ((,var ,obj))
494 (macrolet ((,get (slot)
495 (let ((getter (intern (concatenate 'string
496 ',(string conc-name)
497 (string slot))
498 (symbol-package ',conc-name))))
499 `(,getter ,',var))))
500 ,@body))))
501
502 (defmacro with-temp-package (var &body body)
503 "Execute BODY with VAR bound to a temporary package.
504 The package is deleted before returning."
505 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
506 (unwind-protect (progn ,@body)
507 (delete-package ,var))))
508
509 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
510 "Just like do-symbols, but makes sure a symbol is visited only once."
511 (let ((seen-ht (gensym "SEEN-HT")))
512 `(let ((,seen-ht (make-hash-table :test #'eq)))
513 (do-symbols (,var ,package ,result-form)
514 (unless (gethash ,var ,seen-ht)
515 (setf (gethash ,var ,seen-ht) t)
516 (tagbody ,@body))))))
517
518 (defun use-threads-p ()
519 (eq (connection.communication-style *emacs-connection*) :spawn))
520
521 (defun current-thread-id ()
522 (thread-id (current-thread)))
523
524
525
526 ;;;;; Logging
527
528 (defvar *log-events* nil)
529 (defvar *log-output* nil) ; should be nil for image dumpers
530
531 (defun init-log-output ()
532 (unless *log-output*
533 (setq *log-output* (real-output-stream *error-output*))))
534
535 (defun real-input-stream (stream)
536 (typecase stream
537 (synonym-stream
538 (real-input-stream (symbol-value (synonym-stream-symbol stream))))
539 (two-way-stream
540 (real-input-stream (two-way-stream-input-stream stream)))
541 (t stream)))
542
543 (defun real-output-stream (stream)
544 (typecase stream
545 (synonym-stream
546 (real-output-stream (symbol-value (synonym-stream-symbol stream))))
547 (two-way-stream
548 (real-output-stream (two-way-stream-output-stream stream)))
549 (t stream)))
550
551 (add-hook *after-init-hook* 'init-log-output)
552
553 (defvar *event-history* (make-array 40 :initial-element nil)
554 "A ring buffer to record events for better error messages.")
555 (defvar *event-history-index* 0)
556 (defvar *enable-event-history* t)
557
558 (defun log-event (format-string &rest args)
559 "Write a message to *terminal-io* when *log-events* is non-nil.
560 Useful for low level debugging."
561 (with-standard-io-syntax
562 (let ((*print-readably* nil)
563 (*print-pretty* nil)
564 (*package* *swank-io-package*))
565 (when *enable-event-history*
566 (setf (aref *event-history* *event-history-index*)
567 (format nil "~?" format-string args))
568 (setf *event-history-index*
569 (mod (1+ *event-history-index*) (length *event-history*))))
570 (when *log-events*
571 (write-string (escape-non-ascii (format nil "~?" format-string args))
572 *log-output*)
573 (force-output *log-output*)))))
574
575 (defun event-history-to-list ()
576 "Return the list of events (older events first)."
577 (let ((arr *event-history*)
578 (idx *event-history-index*))
579 (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
580
581 (defun dump-event-history (stream)
582 (dolist (e (event-history-to-list))
583 (dump-event e stream)))
584
585 (defun dump-event (event stream)
586 (cond ((stringp event)
587 (write-string (escape-non-ascii event) stream))
588 ((null event))
589 (t
590 (write-string
591 (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
592 stream))))
593
594 (defun escape-non-ascii (string)
595 "Return a string like STRING but with non-ascii chars escaped."
596 (cond ((ascii-string-p string) string)
597 (t (with-output-to-string (out)
598 (loop for c across string do
599 (cond ((ascii-char-p c) (write-char c out))
600 (t (format out "\\x~4,'0X" (char-code c)))))))))
601
602 (defun ascii-string-p (o)
603 (and (stringp o)
604 (every #'ascii-char-p o)))
605
606 (defun ascii-char-p (c)
607 (<= (char-code c) 127))
608
609
610 ;;;;; Symbols
611
612 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
613 "Returns one of
614
615 :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
616
617 :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
618
619 :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
620 but is not _present_ in PACKAGE,
621
622 or NIL if SYMBOL is not _accessible_ in PACKAGE.
623
624
625 Be aware not to get confused with :INTERNAL and how \"internal
626 symbols\" are defined in the spec; there is a slight mismatch of
627 definition with the Spec and what's commonly meant when talking
628 about internal symbols most times. As the spec says:
629
630 In a package P, a symbol S is
631
632 _accessible_ if S is either _present_ in P itself or was
633 inherited from another package Q (which implies
634 that S is _external_ in Q.)
635
636 You can check that with: (AND (SYMBOL-STATUS S P) T)
637
638
639 _present_ if either P is the /home package/ of S or S has been
640 imported into P or exported from P by IMPORT, or
641 EXPORT respectively.
642
643 Or more simply, if S is not _inherited_.
644
645 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
646 (AND STATUS
647 (NOT (EQ STATUS :INHERITED))))
648
649
650 _external_ if S is going to be inherited into any package that
651 /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
652 DEFPACKAGE.
653
654 Note that _external_ implies _present_, since to
655 make a symbol _external_, you'd have to use EXPORT
656 which will automatically make the symbol _present_.
657
658 You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
659
660
661 _internal_ if S is _accessible_ but not _external_.
662
663 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
664 (AND STATUS
665 (NOT (EQ STATUS :EXTERNAL))))
666
667
668 Notice that this is *different* to
669 (EQ (SYMBOL-STATUS S P) :INTERNAL)
670 because what the spec considers _internal_ is split up into two
671 explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
672 CL:FIND-SYMBOL does.
673
674 The rationale is that most times when you speak about \"internal\"
675 symbols, you're actually not including the symbols inherited
676 from other packages, but only about the symbols directly specific
677 to the package in question.
678 "
679 (when package ; may be NIL when symbol is completely uninterned.
680 (check-type symbol symbol) (check-type package package)
681 (multiple-value-bind (present-symbol status)
682 (find-symbol (symbol-name symbol) package)
683 (and (eq symbol present-symbol) status))))
684
685 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
686 "True if SYMBOL is external in PACKAGE.
687 If PACKAGE is not specified, the home package of SYMBOL is used."
688 (eq (symbol-status symbol package) :external))
689
690
691 (defun classify-symbol (symbol)
692 "Returns a list of classifiers that classify SYMBOL according to its
693 underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
694 variable.) The list may contain the following classification
695 keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
696 :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
697 (check-type symbol symbol)
698 (flet ((type-specifier-p (s)
699 (or (documentation s 'type)
700 (not (eq (type-specifier-arglist s) :not-available)))))
701 (let (result)
702 (when (boundp symbol) (push (if (constantp symbol)
703 :constant :boundp) result))
704 (when (fboundp symbol) (push :fboundp result))
705 (when (type-specifier-p symbol) (push :typespec result))
706 (when (find-class symbol nil) (push :class result))
707 (when (macro-function symbol) (push :macro result))
708 (when (special-operator-p symbol) (push :special-operator result))
709 (when (find-package symbol) (push :package result))
710 (when (and (fboundp symbol)
711 (typep (ignore-errors (fdefinition symbol))
712 'generic-function))
713 (push :generic-function result))
714
715 result)))
716
717 (defun symbol-classification->string (flags)
718 (format nil "~A~A~A~A~A~A~A~A"
719 (if (or (member :boundp flags)
720 (member :constant flags)) "b" "-")
721 (if (member :fboundp flags) "f" "-")
722 (if (member :generic-function flags) "g" "-")
723 (if (member :class flags) "c" "-")
724 (if (member :typespec flags) "t" "-")
725 (if (member :macro flags) "m" "-")
726 (if (member :special-operator flags) "s" "-")
727 (if (member :package flags) "p" "-")))
728
729
730 ;;;; TCP Server
731
732 (defvar *use-dedicated-output-stream* nil
733 "When T swank will attempt to create a second connection to
734 Emacs which is used just to send output.")
735
736 (defvar *dedicated-output-stream-port* 0
737 "Which port we should use for the dedicated output stream.")
738
739 (defvar *communication-style* (preferred-communication-style))
740
741 (defvar *dont-close* nil
742 "Default value of :dont-close argument to start-server and
743 create-server.")
744
745 (defvar *dedicated-output-stream-buffering*
746 (if (eq *communication-style* :spawn) :full :none)
747 "The buffering scheme that should be used for the output stream.
748 Valid values are :none, :line, and :full.")
749
750 (defvar *coding-system* "iso-latin-1-unix")
751
752 (defvar *listener-sockets* nil
753 "A property list of lists containing style, socket pairs used
754 by swank server listeners, keyed on socket port number. They
755 are used to close sockets on server shutdown or restart.")
756
757 (defun start-server (port-file &key (style *communication-style*)
758 (dont-close *dont-close*)
759 (coding-system *coding-system*))
760 "Start the server and write the listen port number to PORT-FILE.
761 This is the entry point for Emacs."
762 (setup-server 0 (lambda (port)
763 (announce-server-port port-file port))
764 style dont-close
765 (find-external-format-or-lose coding-system)))
766
767 (defun create-server (&key (port default-server-port)
768 (style *communication-style*)
769 (dont-close *dont-close*)
770 (coding-system *coding-system*))
771 "Start a SWANK server on PORT running in STYLE.
772 If DONT-CLOSE is true then the listen socket will accept multiple
773 connections, otherwise it will be closed after the first."
774 (setup-server port #'simple-announce-function style dont-close
775 (find-external-format-or-lose coding-system)))
776
777 (defun find-external-format-or-lose (coding-system)
778 (or (find-external-format coding-system)
779 (error "Unsupported coding system: ~s" coding-system)))
780
781 (defparameter *loopback-interface* "127.0.0.1")
782
783 (defun setup-server (port announce-fn style dont-close external-format)
784 (declare (type function announce-fn))
785 (init-log-output)
786 (let* ((socket (create-socket *loopback-interface* port))
787 (local-port (local-port socket)))
788 (funcall announce-fn local-port)
789 (flet ((serve ()
790 (serve-connection socket style dont-close external-format)))
791 (ecase style
792 (:spawn
793 (initialize-multiprocessing
794 (lambda ()
795 (spawn (lambda ()
796 (cond ((not dont-close) (serve))
797 (t (loop (ignore-errors (serve))))))
798 :name (cat "Swank " (princ-to-string port))))))
799 ((:fd-handler :sigio)
800 (add-fd-handler socket (lambda () (serve))))
801 ((nil) (loop do (serve) while dont-close)))
802 (setf (getf *listener-sockets* port) (list style socket))
803 local-port)))
804
805 (defun stop-server (port)
806 "Stop server running on PORT."
807 (let* ((socket-description (getf *listener-sockets* port))
808 (style (first socket-description))
809 (socket (second socket-description)))
810 (ecase style
811 (:spawn
812 (let ((thread-position
813 (position-if
814 (lambda (x)
815 (string-equal (second x)
816 (cat "Swank " (princ-to-string port))))
817 (list-threads))))
818 (when thread-position
819 (kill-nth-thread (1- thread-position))
820 (close-socket socket)
821 (remf *listener-sockets* port))))
822 ((:fd-handler :sigio)
823 (remove-fd-handlers socket)
824 (close-socket socket)
825 (remf *listener-sockets* port)))))
826
827 (defun restart-server (&key (port default-server-port)
828 (style *communication-style*)
829 (dont-close *dont-close*)
830 (coding-system *coding-system*))
831 "Stop the server listening on PORT, then start a new SWANK server
832 on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
833 will accept multiple connections, otherwise it will be closed after the
834 first."
835 (stop-server port)
836 (sleep 5)
837 (create-server :port port :style style :dont-close dont-close
838 :coding-system coding-system))
839
840
841 (defun serve-connection (socket style dont-close external-format)
842 (let ((closed-socket-p nil))
843 (unwind-protect
844 (let ((client (accept-authenticated-connection
845 socket :external-format external-format)))
846 (unless dont-close
847 (close-socket socket)
848 (setf closed-socket-p t))
849 (let ((connection (create-connection client style)))
850 (run-hook *new-connection-hook* connection)
851 (push connection *connections*)
852 (serve-requests connection)))
853 (unless (or dont-close closed-socket-p)
854 (close-socket socket)))))
855
856 (defun accept-authenticated-connection (&rest args)
857 (let ((new (apply #'accept-connection args))
858 (success nil))
859 (unwind-protect
860 (let ((secret (slime-secret)))
861 (when secret
862 (set-stream-timeout new 20)
863 (let ((first-val (decode-message new)))
864 (unless (and (stringp first-val) (string= first-val secret))
865 (error "Incoming connection doesn't know the password."))))
866 (set-stream-timeout new nil)
867 (setf success t))
868 (unless success
869 (close new :abort t)))
870 new))
871
872 (defun slime-secret ()
873 "Finds the magic secret from the user's home directory. Returns nil
874 if the file doesn't exist; otherwise the first line of the file."
875 (with-open-file (in
876 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
877 :if-does-not-exist nil)
878 (and in (read-line in nil ""))))
879
880 (defun serve-requests (connection)
881 "Read and process all requests on connections."
882 (funcall (connection.serve-requests connection) connection))
883
884 (defun announce-server-port (file port)
885 (with-open-file (s file
886 :direction :output
887 :if-exists :error
888 :if-does-not-exist :create)
889 (format s "~S~%" port))
890 (simple-announce-function port))
891
892 (defun simple-announce-function (port)
893 (when *swank-debug-p*
894 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
895 (force-output *log-output*)))
896
897 (defun open-streams (connection)
898 "Return the 5 streams for IO redirection:
899 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
900 (let* ((input-fn
901 (lambda ()
902 (with-connection (connection)
903 (with-simple-restart (abort-read
904 "Abort reading input from Emacs.")
905 (read-user-input-from-emacs)))))
906 (dedicated-output (if *use-dedicated-output-stream*
907 (open-dedicated-output-stream
908 (connection.socket-io connection))))
909 (in (make-input-stream input-fn))
910 (out (or dedicated-output
911 (make-output-stream (make-output-function connection))))
912 (io (make-two-way-stream in out))
913 (repl-results (make-output-stream-for-target connection
914 :repl-result)))
915 (when (eq (connection.communication-style connection) :spawn)
916 (setf (connection.auto-flush-thread connection)
917 (spawn (lambda () (auto-flush-loop out))
918 :name "auto-flush-thread")))
919 (values dedicated-output in out io repl-results)))
920
921 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
922 (defun make-output-function (connection)
923 "Create function to send user output to Emacs."
924 (let ((i 0) (tag 0) (l 0))
925 (lambda (string)
926 (with-connection (connection)
927 (multiple-value-setq (i tag l)
928 (send-user-output string i tag l))))))
929
930 (defvar *maximum-pipelined-output-chunks* 50)
931 (defvar *maximum-pipelined-output-length* (* 80 20 5))
932 (defun send-user-output (string pcount tag plength)
933 ;; send output with flow control
934 (when (or (> pcount *maximum-pipelined-output-chunks*)
935 (> plength *maximum-pipelined-output-length*))
936 (setf tag (mod (1+ tag) 1000))
937 (send-to-emacs `(:ping ,(current-thread-id) ,tag))
938 (with-simple-restart (abort "Abort sending output to Emacs.")
939 (wait-for-event `(:emacs-pong ,tag)))
940 (setf pcount 0)
941 (setf plength 0))
942 (send-to-emacs `(:write-string ,string))
943 (values (1+ pcount) tag (+ plength (length string))))
944
945 (defun make-output-function-for-target (connection target)
946 "Create a function to send user output to a specific TARGET in Emacs."
947 (lambda (string)
948 (with-connection (connection)
949 (with-simple-restart
950 (abort "Abort sending output to Emacs.")
951 (send-to-emacs `(:write-string ,string ,target))))))
952
953 (defun make-output-stream-for-target (connection target)
954 "Create a stream that sends output to a specific TARGET in Emacs."
955 (make-output-stream (make-output-function-for-target connection target)))
956
957 (defun open-dedicated-output-stream (socket-io)
958 "Open a dedicated output connection to the Emacs on SOCKET-IO.
959 Return an output stream suitable for writing program output.
960
961 This is an optimized way for Lisp to deliver output to Emacs."
962 (let ((socket (create-socket *loopback-interface*
963 *dedicated-output-stream-port*)))
964 (unwind-protect
965 (let ((port (local-port socket)))
966 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
967 (let ((dedicated (accept-authenticated-connection
968 socket
969 :external-format
970 (or (ignore-errors
971 (stream-external-format socket-io))
972 :default)
973 :buffering *dedicated-output-stream-buffering*
974 :timeout 30)))
975 (close-socket socket)
976 (setf socket nil)
977 dedicated))
978 (when socket
979 (close-socket socket)))))
980
981 ;; The restart that will be invoked when the user calls sldb-quit.
982 ;; This restart will be named "abort" because many people press "a"
983 ;; instead of "q" in the debugger.
984 (defvar *sldb-quit-restart*)
985
986 ;; Establish a top-level restart and execute BODY.
987 ;; Execute K if the restart is invoked.
988 (defmacro with-top-level-restart ((connection k) &body body)
989 `(with-connection (,connection)
990 (restart-case
991 (let ((*sldb-quit-restart* (find-restart 'abort)))
992 . ,body)
993 (abort (&optional v)
994 :report "Return to SLIME's top level."
995 (declare (ignore v))
996 (force-user-output)
997 ,k))))
998
999 (defun handle-requests (connection &optional timeout)
1000 "Read and process :emacs-rex requests.
1001 The processing is done in the extent of the toplevel restart."
1002 (cond ((boundp '*sldb-quit-restart*)
1003 (process-requests timeout))
1004 (t
1005 (tagbody
1006 start
1007 (with-top-level-restart (connection (go start))
1008 (process-requests timeout))))))
1009
1010 (defun process-requests (timeout)
1011 "Read and process requests from Emacs."
1012 (loop
1013 (multiple-value-bind (event timeout?)
1014 (wait-for-event `(or (:emacs-rex . _)
1015 (:emacs-channel-send . _))
1016 timeout)
1017 (when timeout? (return))
1018 (destructure-case event
1019 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
1020 ((:emacs-channel-send channel (selector &rest args))
1021 (channel-send channel selector args))))))
1022
1023 (defun current-socket-io ()
1024 (connection.socket-io *emacs-connection*))
1025
1026 (defun close-connection (c condition backtrace)
1027 (let ((*debugger-hook* nil))
1028 (log-event "close-connection: ~a ...~%" condition)
1029 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
1030 (let ((cleanup (connection.cleanup c)))
1031 (when cleanup
1032 (funcall cleanup c)))
1033 (close (connection.socket-io c))
1034 (when (connection.dedicated-output c)
1035 (close (connection.dedicated-output c)))
1036 (setf *connections* (remove c *connections*))
1037 (run-hook *connection-closed-hook* c)
1038 (when (and condition (not (typep condition 'end-of-file)))
1039 (finish-output *log-output*)
1040 (format *log-output* "~&;; Event history start:~%")
1041 (dump-event-history *log-output*)
1042 (format *log-output* ";; Event history end.~%~
1043 ;; Backtrace:~%~{~A~%~}~
1044 ;; Connection to Emacs lost. [~%~
1045 ;; condition: ~A~%~
1046 ;; type: ~S~%~
1047 ;; encoding: ~A style: ~S dedicated: ~S]~%"
1048 backtrace
1049 (escape-non-ascii (safe-condition-message condition) )
1050 (type-of condition)
1051 (ignore-errors (stream-external-format (connection.socket-io c)))
1052 (connection.communication-style c)
1053 *use-dedicated-output-stream*)
1054 (finish-output *log-output*))
1055 (log-event "close-connection ~a ... done.~%" condition)))
1056
1057 ;;;;;; Thread based communication
1058
1059 (defvar *active-threads* '())
1060
1061 (defun read-loop (connection)
1062 (let ((input-stream (connection.socket-io connection))
1063 (control-thread (connection.control-thread connection)))
1064 (with-swank-protocol-error-handler (connection)
1065 (loop (send control-thread (decode-message input-stream))))))
1066
1067 (defun dispatch-loop (connection)
1068 (let ((*emacs-connection* connection))
1069 ;; FIXME: Why do we use WITH-PANIC-HANDLER here, and why is it not
1070 ;; appropriate here to use WITH-SWANK-PROTOCOL-ERROR-HANDLER?
1071 ;; I think this should be documented.
1072 (with-panic-handler (connection)
1073 (loop (dispatch-event (receive))))))
1074
1075 (defvar *auto-flush-interval* 0.2)
1076
1077 (defun auto-flush-loop (stream)
1078 (loop
1079 (when (not (and (open-stream-p stream)
1080 (output-stream-p stream)))
1081 (return nil))
1082 (finish-output stream)
1083 (sleep *auto-flush-interval*)))
1084
1085 (defun find-repl-thread (connection)
1086 (cond ((not (use-threads-p))
1087 (current-thread))
1088 (t
1089 (let ((thread (connection.repl-thread connection)))
1090 (cond ((not thread) nil)
1091 ((thread-alive-p thread) thread)
1092 (t
1093 (setf (connection.repl-thread connection)
1094 (spawn-repl-thread connection "new-repl-thread"))))))))
1095
1096 (defun find-worker-thread (id)
1097 (etypecase id
1098 ((member t)
1099 (car *active-threads*))
1100 ((member :repl-thread)
1101 (find-repl-thread *emacs-connection*))
1102 (fixnum
1103 (find-thread id))))
1104
1105 (defun interrupt-worker-thread (id)
1106 (let ((thread (or (find-worker-thread id)
1107 (find-repl-thread *emacs-connection*)
1108 ;; FIXME: to something better here
1109 (spawn (lambda ()) :name "ephemeral"))))
1110 (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1111 (assert thread)
1112 (signal-interrupt thread
1113 (lambda ()
1114 (invoke-or-queue-interrupt #'simple-break)))))
1115
1116 (defun thread-for-evaluation (id)
1117 "Find or create a thread to evaluate the next request."
1118 (let ((c *emacs-connection*))
1119 (etypecase id
1120 ((member t)
1121 (cond ((use-threads-p) (spawn-worker-thread c))
1122 (t (current-thread))))
1123 ((member :repl-thread)
1124 (find-repl-thread c))
1125 (fixnum
1126 (find-thread id)))))
1127
1128 (defun spawn-worker-thread (connection)
1129 (spawn (lambda ()
1130 (with-bindings *default-worker-thread-bindings*
1131 (with-top-level-restart (connection nil)
1132 (apply #'eval-for-emacs
1133 (cdr (wait-for-event `(:emacs-rex . _)))))))
1134 :name "worker"))
1135
1136 (defun spawn-repl-thread (connection name)
1137 (spawn (lambda ()
1138 (with-bindings *default-worker-thread-bindings*
1139 (repl-loop connection)))
1140 :name name))
1141
1142 (defun dispatch-event (event)
1143 "Handle an event triggered either by Emacs or within Lisp."
1144 (log-event "dispatch-event: ~s~%" event)
1145 (destructure-case event
1146 ((:emacs-rex form package thread-id id)
1147 (let ((thread (thread-for-evaluation thread-id)))
1148 (cond (thread
1149 (push thread *active-threads*)
1150 (send-event thread `(:emacs-rex ,form ,package ,id)))
1151 (t
1152 (encode-message
1153 (list :invalid-rpc id
1154 (format nil "Thread not found: ~s" thread-id))
1155 (current-socket-io))))))
1156 ((:return thread &rest args)
1157 (let ((tail (member thread *active-threads*)))
1158 (setq *active-threads* (nconc (ldiff *active-threads* tail)
1159 (cdr tail))))
1160 (encode-message `(:return ,@args) (current-socket-io)))
1161 ((:emacs-interrupt thread-id)
1162 (interrupt-worker-thread thread-id))
1163 (((:write-string
1164 :debug :debug-condition :debug-activate :debug-return :channel-send
1165 :presentation-start :presentation-end
1166 :new-package :new-features :ed :%apply :indentation-update
1167 :eval :eval-no-wait :background-message :inspect :ping
1168 :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
1169 &rest _)
1170 (declare (ignore _))
1171 (encode-message event (current-socket-io)))
1172 (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1173 (send-event (find-thread thread-id) (cons (car event) args)))
1174 ((:emacs-channel-send channel-id msg)
1175 (let ((ch (find-channel channel-id)))
1176 (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1177 (((:end-of-stream))
1178 (close-connection *emacs-connection* nil (safe-backtrace)))
1179 ((:reader-error packet condition)
1180 (encode-message `(:reader-error ,packet
1181 ,(safe-condition-message condition))
1182 (current-socket-io)))))
1183
1184 (defvar *event-queue* '())
1185 (defvar *events-enqueued* 0)
1186
1187 (defun send-event (thread event)
1188 (log-event "send-event: ~s ~s~%" thread event)
1189 (cond ((use-threads-p) (send thread event))
1190 (t (setf *event-queue* (nconc *event-queue* (list event)))
1191 (setf *events-enqueued* (mod (1+ *events-enqueued*)
1192 most-positive-fixnum)))))
1193
1194 (defun send-to-emacs (event)
1195 "Send EVENT to Emacs."
1196 ;;(log-event "send-to-emacs: ~a" event)
1197 (cond ((use-threads-p)
1198 (send (connection.control-thread *emacs-connection*) event))
1199 (t (dispatch-event event))))
1200
1201 (defun signal-interrupt (thread interrupt)
1202 (log-event "signal-interrupt [~a]: ~a ~a~%" (use-threads-p) thread interrupt)
1203 (cond ((use-threads-p) (interrupt-thread thread interrupt))
1204 (t (funcall interrupt))))
1205
1206 (defun wait-for-event (pattern &optional timeout)
1207 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1208 (without-slime-interrupts
1209 (cond ((use-threads-p)
1210 (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1211 (t
1212 (wait-for-event/event-loop pattern timeout)))))
1213
1214 (defun wait-for-event/event-loop (pattern timeout)
1215 (assert (or (not timeout) (eq timeout t)))
1216 (loop
1217 (check-slime-interrupts)
1218 (let ((event (poll-for-event pattern)))
1219 (when event (return (car event))))
1220 (let ((events-enqueued *events-enqueued*)
1221 (ready (wait-for-input (list (current-socket-io)) timeout)))
1222 (cond ((and timeout (not ready))
1223 (return (values nil t)))
1224 ((or (/= events-enqueued *events-enqueued*)
1225 (eq ready :interrupt))
1226 ;; rescan event queue, interrupts may enqueue new events
1227 )
1228 (t
1229 (assert (equal ready (list (current-socket-io))))
1230 (dispatch-event (decode-message (current-socket-io))))))))
1231
1232 (defun poll-for-event (pattern)
1233 (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1234 *event-queue*)))
1235 (when tail
1236 (setq *event-queue* (nconc (ldiff *event-queue* tail)
1237 (cdr tail)))
1238 tail)))
1239
1240 ;;; FIXME: Make this use SWANK-MATCH.
1241 (defun event-match-p (event pattern)
1242 (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1243 (member pattern '(nil t)))
1244 (equal event pattern))
1245 ((symbolp pattern) t)
1246 ((consp pattern)
1247 (case (car pattern)
1248 ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1249 (t (and (consp event)
1250 (and (event-match-p (car event) (car pattern))
1251 (event-match-p (cdr event) (cdr pattern)))))))
1252 (t (error "Invalid pattern: ~S" pattern))))
1253
1254 (defun spawn-threads-for-connection (connection)
1255 (setf (connection.control-thread connection)
1256 (spawn (lambda () (control-thread connection))
1257 :name "control-thread"))
1258 connection)
1259
1260 (defun control-thread (connection)
1261 (with-struct* (connection. @ connection)
1262 (setf (@ control-thread) (current-thread))
1263 (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1264 :name "reader-thread"))
1265 (dispatch-loop connection)))
1266
1267 (defun cleanup-connection-threads (connection)
1268 (let ((threads (list (connection.repl-thread connection)
1269 (connection.reader-thread connection)
1270 (connection.control-thread connection)
1271 (connection.auto-flush-thread connection))))
1272 (dolist (thread threads)
1273 (when (and thread
1274 (thread-alive-p thread)
1275 (not (equal (current-thread) thread)))
1276 (kill-thread thread)))))
1277
1278 (defun repl-loop (connection)
1279 (handle-requests connection))
1280
1281 ;;;;;; Signal driven IO
1282
1283 (defun install-sigio-handler (connection)
1284 (add-sigio-handler (connection.socket-io connection)
1285 (lambda () (process-io-interrupt connection)))
1286 (handle-requests connection t))
1287
1288 (defvar *io-interupt-level* 0)
1289
1290 (defun process-io-interrupt (connection)
1291 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1292 (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1293 (invoke-or-queue-interrupt
1294 (lambda () (handle-requests connection t))))
1295 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1296
1297 (defun deinstall-sigio-handler (connection)
1298 (log-event "deinstall-sigio-handler...~%")
1299 (remove-sigio-handlers (connection.socket-io connection))
1300 (log-event "deinstall-sigio-handler...done~%"))
1301
1302 ;;;;;; SERVE-EVENT based IO
1303
1304 (defun install-fd-handler (connection)
1305 (add-fd-handler (connection.socket-io connection)
1306 (lambda () (handle-requests connection t)))
1307 (setf (connection.saved-sigint-handler connection)
1308 (install-sigint-handler
1309 (lambda ()
1310 (invoke-or-queue-interrupt
1311 (lambda ()
1312 (with-connection (connection)
1313 (dispatch-interrupt-event)))))))
1314 (handle-requests connection t))
1315
1316 (defun dispatch-interrupt-event ()
1317 (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
1318
1319 (defun deinstall-fd-handler (connection)
1320 (log-event "deinstall-fd-handler~%")
1321 (remove-fd-handlers (connection.socket-io connection))
1322 (install-sigint-handler (connection.saved-sigint-handler connection)))
1323
1324 ;;;;;; Simple sequential IO
1325
1326 (defun simple-serve-requests (connection)
1327 (unwind-protect
1328 (with-connection (connection)
1329 (call-with-user-break-handler
1330 (lambda ()
1331 (invoke-or-queue-interrupt #'dispatch-interrupt-event))
1332 (lambda ()
1333 (with-simple-restart (close-connection "Close SLIME connection")
1334 ;;(handle-requests connection)
1335 (let* ((stdin (real-input-stream *standard-input*))
1336 (*standard-input* (make-repl-input-stream connection
1337 stdin)))
1338 (with-swank-protocol-error-handler (connection)
1339 (simple-repl)))))))
1340 (close-connection connection nil (safe-backtrace))))
1341
1342 (defun simple-repl ()
1343 (loop
1344 (with-simple-restart (abort "Abort")
1345 (format t "~&~a> " (package-string-for-prompt *package*))
1346 (force-output)
1347 (let ((form (read)))
1348 (fresh-line)
1349 (let ((- form)
1350 (values (multiple-value-list (eval form))))
1351 (setq *** ** ** * * (car values)
1352 /// // // / / values
1353 +++ ++ ++ + + form)
1354 (cond ((null values) (format t "~&; No values"))
1355 (t (mapc (lambda (v) (format t "~&~s" v)) values))))))))
1356
1357 (defun make-repl-input-stream (connection stdin)
1358 (make-input-stream
1359 (lambda ()
1360 (log-event "pull-input: ~a ~a ~a~%"
1361 (connection.socket-io connection)
1362 (if (open-stream-p (connection.socket-io connection))
1363 :socket-open :socket-closed)
1364 (if (open-stream-p stdin)
1365 :stdin-open :stdin-closed))
1366 (loop
1367 (let* ((socket (connection.socket-io connection))
1368 (inputs (list socket stdin))
1369 (ready (wait-for-input inputs)))
1370 (cond ((eq ready :interrupt)
1371 (check-slime-interrupts))
1372 ((member socket ready)
1373 ;; A Slime request from Emacs is pending; make sure to
1374 ;; redirect IO to the REPL buffer.
1375 (with-io-redirection (connection)
1376 (handle-requests connection t)))
1377 ((member stdin ready)
1378 ;; User typed something into the *inferior-lisp* buffer,
1379 ;; so do not redirect.
1380 (return (read-non-blocking stdin)))
1381 (t (assert (null ready)))))))))
1382
1383 (defun read-non-blocking (stream)
1384 (with-output-to-string (str)
1385 (loop (let ((c (read-char-no-hang stream)))
1386 (unless c (return))
1387 (write-char c str)))))
1388
1389 (defun create-connection (socket-io style)
1390 (let ((success nil))
1391 (unwind-protect
1392 (let ((c (ecase style
1393 (:spawn
1394 (make-connection :socket-io socket-io
1395 :serve-requests #'spawn-threads-for-connection
1396 :cleanup #'cleanup-connection-threads))
1397 (:sigio
1398 (make-connection :socket-io socket-io
1399 :serve-requests #'install-sigio-handler
1400 :cleanup #'deinstall-sigio-handler))
1401 (:fd-handler
1402 (make-connection :socket-io socket-io
1403 :serve-requests #'install-fd-handler
1404 :cleanup #'deinstall-fd-handler))
1405 ((nil)
1406 (make-connection :socket-io socket-io
1407 :serve-requests #'simple-serve-requests))
1408 )))
1409 (setf (connection.communication-style c) style)
1410 (setf success t)
1411 c)
1412 (unless success
1413 (close socket-io :abort t)))))
1414
1415
1416 ;;;; IO to Emacs
1417 ;;;
1418 ;;; This code handles redirection of the standard I/O streams
1419 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1420 ;;; contains the appropriate streams, so all we have to do is make the
1421 ;;; right bindings.
1422
1423 ;;;;; Global I/O redirection framework
1424 ;;;
1425 ;;; Optionally, the top-level global bindings of the standard streams
1426 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1427 ;;; redirect the streams into the connection, and they keep going into
1428 ;;; that connection even if more are established. If the connection
1429 ;;; handling the streams closes then another is chosen, or if there
1430 ;;; are no connections then we revert to the original (real) streams.
1431 ;;;
1432 ;;; It is slightly tricky to assign the global values of standard
1433 ;;; streams because they are often shadowed by dynamic bindings. We
1434 ;;; solve this problem by introducing an extra indirection via synonym
1435 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1436 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1437 ;;; variables, so they can always be assigned to affect a global
1438 ;;; change.
1439
1440 (defvar *globally-redirect-io* nil
1441 "When non-nil globally redirect all standard streams to Emacs.")
1442
1443 ;;;;; Global redirection setup
1444
1445 (defvar *saved-global-streams* '()
1446 "A plist to save and restore redirected stream objects.
1447 E.g. the value for '*standard-output* holds the stream object
1448 for *standard-output* before we install our redirection.")
1449
1450 (defun setup-stream-indirection (stream-var &optional stream)
1451 "Setup redirection scaffolding for a global stream variable.
1452 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1453
1454 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1455
1456 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1457 *STANDARD-INPUT*.
1458
1459 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1460 *CURRENT-STANDARD-INPUT*.
1461
1462 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1463 effective global value for *STANDARD-INPUT*. This way we can assign
1464 the effective global value even when *STANDARD-INPUT* is shadowed by a
1465 dynamic binding."
1466 (let ((current-stream-var (prefixed-var '#:current stream-var))
1467 (stream (or stream (symbol-value stream-var))))
1468 ;; Save the real stream value for the future.
1469 (setf (getf *saved-global-streams* stream-var) stream)
1470 ;; Define a new variable for the effective stream.
1471 ;; This can be reassigned.
1472 (proclaim `(special ,current-stream-var))
1473 (set current-stream-var stream)
1474 ;; Assign the real binding as a synonym for the current one.
1475 (let ((stream (make-synonym-stream current-stream-var)))
1476 (set stream-var stream)
1477 (set-default-initial-binding stream-var `(quote ,stream)))))
1478
1479 (defun prefixed-var (prefix variable-symbol)
1480 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1481 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1482 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1483
1484 (defvar *standard-output-streams*
1485 '(*standard-output* *error-output* *trace-output*)
1486 "The symbols naming standard output streams.")
1487
1488 (defvar *standard-input-streams*
1489 '(*standard-input*)
1490 "The symbols naming standard input streams.")
1491
1492 (defvar *standard-io-streams*
1493 '(*debug-io* *query-io* *terminal-io*)
1494 "The symbols naming standard io streams.")
1495
1496 (defun init-global-stream-redirection ()
1497 (when *globally-redirect-io*
1498 (cond (*saved-global-streams*
1499 (warn "Streams already redirected."))
1500 (t
1501 (mapc #'setup-stream-indirection
1502 (append *standard-output-streams*
1503 *standard-input-streams*
1504 *standard-io-streams*))))))
1505
1506 (add-hook *after-init-hook* 'init-global-stream-redirection)
1507
1508 (defun globally-redirect-io-to-connection (connection)
1509 "Set the standard I/O streams to redirect to CONNECTION.
1510 Assigns *CURRENT-<STREAM>* for all standard streams."
1511 (dolist (o *standard-output-streams*)
1512 (set (prefixed-var '#:current o)
1513 (connection.user-output connection)))
1514 ;; FIXME: If we redirect standard input to Emacs then we get the
1515 ;; regular Lisp top-level trying to read from our REPL.
1516 ;;
1517 ;; Perhaps the ideal would be for the real top-level to run in a
1518 ;; thread with local bindings for all the standard streams. Failing
1519 ;; that we probably would like to inhibit it from reading while
1520 ;; Emacs is connected.
1521 ;;
1522 ;; Meanwhile we just leave *standard-input* alone.
1523 #+NIL
1524 (dolist (i *standard-input-streams*)
1525 (set (prefixed-var '#:current i)
1526 (connection.user-input connection)))
1527 (dolist (io *standard-io-streams*)
1528 (set (prefixed-var '#:current io)
1529 (connection.user-io connection))))
1530
1531 (defun revert-global-io-redirection ()
1532 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1533 (dolist (stream-var (append *standard-output-streams*
1534 *standard-input-streams*
1535 *standard-io-streams*))
1536 (set (prefixed-var '#:current stream-var)
1537 (getf *saved-global-streams* stream-var))))
1538
1539 ;;;;; Global redirection hooks
1540
1541 (defvar *global-stdio-connection* nil
1542 "The connection to which standard I/O streams are globally redirected.
1543 NIL if streams are not globally redirected.")
1544
1545 (defun maybe-redirect-global-io (connection)
1546 "Consider globally redirecting to CONNECTION."
1547 (when (and *globally-redirect-io* (null *global-stdio-connection*)
1548 (connection.user-io connection))
1549 (setq *global-stdio-connection* connection)
1550 (globally-redirect-io-to-connection connection)))
1551
1552 (defun update-redirection-after-close (closed-connection)
1553 "Update redirection after a connection closes."
1554 (check-type closed-connection connection)
1555 (when (eq *global-stdio-connection* closed-connection)
1556 (if (and (default-connection) *globally-redirect-io*)
1557 ;; Redirect to another connection.
1558 (globally-redirect-io-to-connection (default-connection))
1559 ;; No more connections, revert to the real streams.
1560 (progn (revert-global-io-redirection)
1561 (setq *global-stdio-connection* nil)))))
1562
1563 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1564
1565 ;;;;; Redirection during requests
1566 ;;;
1567 ;;; We always redirect the standard streams to Emacs while evaluating
1568 ;;; an RPC. This is done with simple dynamic bindings.
1569
1570 (defslimefun create-repl (target)
1571 (assert (eq target nil))
1572 (let ((conn *emacs-connection*))
1573 (initialize-streams-for-connection conn)
1574 (with-struct* (connection. @ conn)
1575 (setf (@ env)
1576 `((*standard-output* . ,(@ user-output))
1577 (*standard-input* . ,(@ user-input))
1578 (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1579 (*error-output* . ,(@ user-output))
1580 (*debug-io* . ,(@ user-io))
1581 (*query-io* . ,(@ user-io))
1582 (*terminal-io* . ,(@ user-io))))
1583 (maybe-redirect-global-io conn)
1584 (when (use-threads-p)
1585 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1586 (list (package-name *package*)
1587 (package-string-for-prompt *package*)))))
1588
1589 (defun initialize-streams-for-connection (connection)
1590 (multiple-value-bind (dedicated in out io repl-results)
1591 (open-streams connection)
1592 (setf (connection.dedicated-output connection) dedicated
1593 (connection.user-io connection) io
1594 (connection.user-output connection) out
1595 (connection.user-input connection) in
1596 (connection.repl-results connection) repl-results)
1597 connection))
1598
1599
1600 ;;; Channels
1601
1602 (defvar *channels* '())
1603 (defvar *channel-counter* 0)
1604
1605 (defclass channel ()
1606 ((id :reader channel-id)
1607 (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1608 (name :initarg :name :initform nil)))
1609
1610 (defmethod initialize-instance ((ch channel) &rest initargs)
1611 (declare (ignore initargs))
1612 (call-next-method)
1613 (with-slots (id) ch
1614 (setf id (incf *channel-counter*))
1615 (push (cons id ch) *channels*)))
1616
1617 (defmethod print-object ((c channel) stream)
1618 (print-unreadable-object (c stream :type t)
1619 (with-slots (id name) c
1620 (format stream "~d ~a" id name))))
1621
1622 (defun find-channel (id)
1623 (cdr (assoc id *channels*)))
1624
1625 (defgeneric channel-send (channel selector args))
1626
1627 (defmacro define-channel-method (selector (channel &rest args) &body body)
1628 `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1629 (destructuring-bind ,args args
1630 . ,body)))
1631
1632 (defun send-to-remote-channel (channel-id msg)
1633 (send-to-emacs `(:channel-send ,channel-id ,msg)))
1634
1635 (defclass listener-channel (channel)
1636 ((remote :initarg :remote)
1637 (env :initarg :env)))
1638
1639 (defslimefun create-listener (remote)
1640 (let* ((pkg *package*)
1641 (conn *emacs-connection*)
1642 (ch (make-instance 'listener-channel
1643 :remote remote
1644 :env (initial-listener-bindings remote))))
1645
1646 (with-slots (thread id) ch
1647 (when (use-threads-p)
1648 (setf thread (spawn-listener-thread ch conn)))
1649 (list id
1650 (thread-id thread)
1651 (package-name pkg)
1652 (package-string-for-prompt pkg)))))
1653
1654 (defun initial-listener-bindings (remote)
1655 `((*package* . ,*package*)
1656 (*standard-output*
1657 . ,(make-listener-output-stream remote))
1658 (*standard-input*
1659 . ,(make-listener-input-stream remote))))
1660
1661 (defun spawn-listener-thread (channel connection)
1662 (spawn (lambda ()
1663 (with-connection (connection)
1664 (loop
1665 (destructure-case (wait-for-event `(:emacs-channel-send . _))
1666 ((:emacs-channel-send c (selector &rest args))
1667 (assert (eq c channel))
1668 (channel-send channel selector args))))))
1669 :name "swank-listener-thread"))
1670
1671 (define-channel-method :eval ((c listener-channel) string)
1672 (with-slots (remote env) c
1673 (let ((aborted t))
1674 (with-bindings env
1675 (unwind-protect
1676 (let* ((form (read-from-string string))
1677 (value (eval form)))
1678 (send-to-remote-channel remote
1679 `(:write-result
1680 ,(prin1-to-string value)))
1681 (setq aborted nil))
1682 (force-output)
1683 (setf env (loop for (sym) in env
1684 collect (cons sym (symbol-value sym))))
1685 (let ((pkg (package-name *package*))
1686 (prompt (package-string-for-prompt *package*)))
1687 (send-to-remote-channel remote
1688 (if aborted
1689 `(:evaluation-aborted ,pkg ,prompt)
1690 `(:prompt ,pkg ,prompt)))))))))
1691
1692 (defun make-listener-output-stream (remote)
1693 (make-output-stream (lambda (string)
1694 (send-to-remote-channel remote
1695 `(:write-string ,string)))))
1696
1697 (defun make-listener-input-stream (remote)
1698 (make-input-stream
1699 (lambda ()
1700 (force-output)
1701 (let ((tag (make-tag)))
1702 (send-to-remote-channel remote
1703 `(:read-string ,(current-thread-id) ,tag))
1704 (let ((ok nil))
1705 (unwind-protect
1706 (prog1 (caddr (wait-for-event
1707 `(:emacs-return-string ,tag value)))
1708 (setq ok t))
1709 (unless ok
1710 (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1711
1712
1713
1714 (defun decode-message (stream)
1715 "Read an S-expression from STREAM using the SLIME protocol."
1716 ;;(log-event "decode-message~%")
1717 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1718 (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
1719 (let ((packet (read-packet stream)))
1720 (handler-case (values (read-form packet) nil)
1721 (reader-error (c)
1722 `(:reader-error ,packet ,c)))))))
1723
1724 ;; use peek-char to detect EOF, read-sequence may return 0 instead of
1725 ;; signaling a condition.
1726 (defun read-packet (stream)
1727 (peek-char nil stream)
1728 (let* ((header (read-chunk stream 6))
1729 (length (parse-integer header :radix #x10))
1730 (payload (read-chunk stream length)))
1731 (log-event "READ: ~S~%" payload)
1732 payload))
1733
1734 (defun read-chunk (stream length)
1735 (let* ((buffer (make-string length))
1736 (count (read-sequence buffer stream)))
1737 (assert (= count length) () "Short read: length=~D count=~D" length count)
1738 buffer))
1739
1740 (defun read-form (string)
1741 (with-standard-io-syntax
1742 (let ((*package* *swank-io-package*))
1743 (read-from-string string))))
1744
1745 (defun input-available-p (stream)
1746 ;; return true iff we can read from STREAM without waiting or if we
1747 ;; hit EOF
1748 (let ((c (read-char-no-hang stream nil :eof)))
1749 (cond ((not c) nil)
1750 ((eq c :eof) t)
1751 (t
1752 (unread-char c stream)
1753 t))))
1754
1755 (defvar *slime-features* nil
1756 "The feature list that has been sent to Emacs.")
1757
1758 (defun send-oob-to-emacs (object)
1759 (send-to-emacs object))
1760
1761 (defun encode-message (message stream)
1762 (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
1763 (let* ((string (prin1-to-string-for-emacs message))
1764 (length (length string)))
1765 (log-event "WRITE: ~A~%" string)
1766 (let ((*print-pretty* nil))
1767 (format stream "~6,'0x" length))
1768 (write-string string stream)
1769 (finish-output stream))))
1770
1771 (defun prin1-to-string-for-emacs (object)
1772 (with-standard-io-syntax
1773 (let ((*print-case* :downcase)
1774 (*print-readably* nil)
1775 (*print-pretty* nil)
1776 (*package* *swank-io-package*))
1777 (prin1-to-string object))))
1778
1779 (defun force-user-output ()
1780 (force-output (connection.user-io *emacs-connection*)))
1781
1782 (add-hook *pre-reply-hook* 'force-user-output)
1783
1784 (defun clear-user-input ()
1785 (clear-input (connection.user-input *emacs-connection*)))
1786
1787 (defvar *tag-counter* 0)
1788
1789 (defun make-tag ()
1790 (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1791
1792 (defun read-user-input-from-emacs ()
1793 (let ((tag (make-tag)))
1794 (force-output)
1795 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1796 (let ((ok nil))
1797 (unwind-protect
1798 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1799 (setq ok t))
1800 (unless ok
1801 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1802
1803 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1804 "Like y-or-n-p, but ask in the Emacs minibuffer."
1805 (let ((tag (make-tag))
1806 (question (apply #'format nil format-string arguments)))
1807 (force-output)
1808 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1809 (third (wait-for-event `(:emacs-return ,tag result)))))
1810
1811 (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1812 "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1813 entered nothing, returns NIL when user pressed C-g."
1814 (check-type prompt string) (check-type initial-value (or null string))
1815 (let ((tag (make-tag)))
1816 (force-output)
1817 (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1818 ,prompt ,initial-value))
1819 (third (wait-for-event `(:emacs-return ,tag result)))))
1820
1821
1822 (defun process-form-for-emacs (form)
1823 "Returns a string which emacs will read as equivalent to
1824 FORM. FORM can contain lists, strings, characters, symbols and
1825 numbers.
1826
1827 Characters are converted emacs' ?<char> notaion, strings are left
1828 as they are (except for espacing any nested \" chars, numbers are
1829 printed in base 10 and symbols are printed as their symbol-name
1830 converted to lower case."
1831 (etypecase form
1832 (string (format nil "~S" form))
1833 (cons (format nil "(~A . ~A)"
1834 (process-form-for-emacs (car form))
1835 (process-form-for-emacs (cdr form))))
1836 (character (format nil "?~C" form))
1837 (symbol (concatenate 'string (when (eq (symbol-package form)
1838 #.(find-package "KEYWORD"))
1839 ":")
1840 (string-downcase (symbol-name form))))
1841 (number (let ((*print-base* 10))
1842 (princ-to-string form)))))
1843
1844 (defun eval-in-emacs (form &optional nowait)
1845 "Eval FORM in Emacs."
1846 (cond (nowait
1847 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1848 (t
1849 (force-output)
1850 (let ((tag (make-tag)))
1851 (send-to-emacs `(:eval ,(current-thread-id) ,tag
1852 ,(process-form-for-emacs form)))
1853 (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1854 (destructure-case value
1855 ((:ok value) value)
1856 ((:abort) (abort))))))))
1857
1858 (defvar *swank-wire-protocol-version* nil
1859 "The version of the swank/slime communication protocol.")
1860
1861 (defslimefun connection-info ()
1862 "Return a key-value list of the form:
1863 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1864 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1865 STYLE: the communication style
1866 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1867 FEATURES: a list of keywords
1868 PACKAGE: a list (&key NAME PROMPT)
1869 VERSION: the protocol version"
1870 (setq *slime-features* *features*)
1871 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1872 :lisp-implementation (:type ,(lisp-implementation-type)
1873 :name ,(lisp-implementation-type-name)
1874 :version ,(lisp-implementation-version))
1875 :machine (:instance ,(machine-instance)
1876 :type ,(machine-type)
1877 :version ,(machine-version))
1878 :features ,(features-for-emacs)
1879 :modules ,*modules*
1880 :package (:name ,(package-name *package*)
1881 :prompt ,(package-string-for-prompt *package*))
1882 :version ,*swank-wire-protocol-version*))
1883
1884 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1885 (let* ((s *standard-output*)
1886 (*trace-output* (make-broadcast-stream s *log-output*)))
1887 (time (progn
1888 (dotimes (i n)
1889 (format s "~D abcdefghijklm~%" i)
1890 (when (zerop (mod n m))
1891 (finish-output s)))
1892 (finish-output s)
1893 (when *emacs-connection*
1894 (eval-in-emacs '(message "done.")))))
1895 (terpri *trace-output*)
1896 (finish-output *trace-output*)
1897 nil))
1898
1899 (defun debug-on-swank-error ()
1900 (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1901 *debug-on-swank-protocol-error*)
1902
1903 (defun (setf debug-on-swank-error) (new-value)
1904 (setf *debug-on-swank-protocol-error* new-value)
1905 (setf *debug-swank-backend* new-value))
1906
1907 (defslimefun toggle-debug-on-swank-error ()
1908 (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1909
1910
1911 ;;;; Reading and printing
1912
1913 (defmacro define-special (name doc)
1914 "Define a special variable NAME with doc string DOC.
1915 This is like defvar, but NAME will not be initialized."
1916 `(progn
1917 (defvar ,name)
1918 (setf (documentation ',name 'variable) ,doc)))
1919
1920 (define-special *buffer-package*
1921 "Package corresponding to slime-buffer-package.
1922
1923 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1924 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1925
1926 (define-special *buffer-readtable*
1927 "Readtable associated with the current buffer")
1928
1929 (defmacro with-buffer-syntax ((&optional package) &body body)
1930 "Execute BODY with appropriate *package* and *readtable* bindings.
1931
1932 This should be used for code that is conceptionally executed in an
1933 Emacs buffer."
1934 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1935
1936 (defun call-with-buffer-syntax (package fun)
1937 (let ((*package* (if package
1938 (guess-buffer-package package)
1939 *buffer-package*)))
1940 ;; Don't shadow *readtable* unnecessarily because that prevents
1941 ;; the user from assigning to it.
1942 (if (eq *readtable* *buffer-readtable*)
1943 (call-with-syntax-hooks fun)
1944 (let ((*readtable* *buffer-readtable*))
1945 (call-with-syntax-hooks fun)))))
1946
1947 (defmacro without-printing-errors ((&key object stream
1948 (msg "<<error printing object>>"))
1949 &body body)
1950 "Catches errors during evaluation of BODY and prints MSG instead."
1951 `(handler-case (progn ,@body)
1952 (serious-condition ()
1953 ,(cond ((and stream object)
1954 (let ((gstream (gensym "STREAM+")))
1955 `(let ((,gstream ,stream))
1956 (print-unreadable-object (,object ,gstream :type t :identity t)
1957 (write-string ,msg ,gstream)))))
1958 (stream
1959 `(write-string ,msg ,stream))
1960 (object
1961 `(with-output-to-string (s)
1962 (print-unreadable-object (,object s :type t :identity t)
1963 (write-string ,msg s))))
1964 (t msg)))))
1965
1966 (defun to-string (object)
1967 "Write OBJECT in the *BUFFER-PACKAGE*.
1968 The result may not be readable. Handles problems with PRINT-OBJECT methods
1969 gracefully."
1970 (with-buffer-syntax ()
1971 (let ((*print-readably* nil))
1972 (without-printing-errors (:object object :stream nil)
1973 (prin1-to-string object)))))
1974
1975 (defun to-line (object &optional (width 75))
1976 "Print OBJECT to a single line. Return the string."
1977 (without-printing-errors (:object object :stream nil)
1978 (call/truncated-output-to-string
1979 width
1980 (lambda (*standard-output*)
1981 (write object :right-margin width :lines 1))
1982 "..")))
1983
1984 (defun from-string (string)
1985 "Read string in the *BUFFER-PACKAGE*"
1986 (with-buffer-syntax ()
1987 (let ((*read-suppress* nil))
1988 (values (read-from-string string)))))
1989
1990 (defun parse-string (string package)
1991 "Read STRING in PACKAGE."
1992 (with-buffer-syntax (package)
1993 (let ((*read-suppress* nil))
1994 (read-from-string string))))
1995
1996 ;; FIXME: deal with #\| etc. hard to do portably.
1997 (defun tokenize-symbol (string)
1998 "STRING is interpreted as the string representation of a symbol
1999 and is tokenized accordingly. The result is returned in three
2000 values: The package identifier part, the actual symbol identifier
2001 part, and a flag if the STRING represents a symbol that is
2002 internal to the package identifier part. (Notice that the flag is
2003 also true with an empty package identifier part, as the STRING is
2004 considered to represent a symbol internal to some current package.)"
2005 (let ((package (let ((pos (position #\: string)))
2006 (if pos (subseq string 0 pos) nil)))
2007 (symbol (let ((pos (position #\: string :from-end t)))
2008 (if pos (subseq string (1+ pos)) string)))
2009 (internp (not (= (count #\: string) 1))))
2010 (values symbol package internp)))
2011
2012 (defun tokenize-symbol-thoroughly (string)
2013 "This version of TOKENIZE-SYMBOL handles escape characters."
2014 (let ((package nil)
2015 (token (make-array (length string) :element-type 'character
2016 :fill-pointer 0))
2017 (backslash nil)
2018 (vertical nil)
2019 (internp nil))
2020 (loop for char across string do
2021 (cond
2022 (backslash
2023 (vector-push-extend char token)
2024 (setq backslash nil))
2025 ((char= char #\\) ; Quotes next character, even within |...|
2026 (setq backslash t))
2027 ((char= char #\|)
2028 (setq vertical (not vertical)))
2029 (vertical
2030 (vector-push-extend char token))
2031 ((char= char #\:)
2032 (cond ((and package internp)
2033 (return-from tokenize-symbol-thoroughly))
2034 (package
2035 (setq internp t))
2036 (t
2037 (setq package token
2038 token (make-array (length string)
2039 :element-type 'character
2040 :fill-pointer 0)))))
2041 (t
2042 (vector-push-extend (casify-char char) token))))
2043 (unless vertical
2044 (values token package (or (not package) internp)))))
2045
2046 (defun untokenize-symbol (package-name internal-p symbol-name)
2047 "The inverse of TOKENIZE-SYMBOL.
2048
2049 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
2050 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
2051 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
2052 "
2053 (cond ((not package-name) symbol-name)
2054 (internal-p (cat package-name "::" symbol-name))
2055 (t (cat package-name ":" symbol-name))))
2056
2057 (defun casify-char (char)
2058 "Convert CHAR accoring to readtable-case."
2059 (ecase (readtable-case *readtable*)
2060 (:preserve char)
2061 (:upcase (char-upcase char))
2062 (:downcase (char-downcase char))
2063 (:invert (if (upper-case-p char)
2064 (char-downcase char)
2065 (char-upcase char)))))
2066
2067
2068 (defun find-symbol-with-status (symbol-name status &optional (package *package*))
2069 (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
2070 (if (and flag (eq flag status))
2071 (values symbol flag)
2072 (values nil nil))))
2073
2074 (defun parse-symbol (string &optional (package *package*))
2075 "Find the symbol named STRING.
2076 Return the symbol and a flag indicating whether the symbols was found."
2077 (multiple-value-bind (sname pname internalp)
2078 (tokenize-symbol-thoroughly string)
2079 (when sname
2080 (let ((package (cond ((string= pname "") keyword-package)
2081 (pname (find-package pname))
2082 (t package))))
2083 (if package
2084 (multiple-value-bind (symbol flag)
2085 (if internalp
2086 (find-symbol sname package)
2087 (find-symbol-with-status sname ':external package))
2088 (values symbol flag sname package))
2089 (values nil nil nil nil))))))
2090
2091 (defun parse-symbol-or-lose (string &optional (package *package*))
2092 (multiple-value-bind (symbol status) (parse-symbol string package)
2093 (if status
2094 (values symbol status)
2095 (error "Unknown symbol: ~A [in ~A]" string package))))
2096
2097 (defun parse-package (string)
2098 "Find the package named STRING.
2099 Return the package or nil."
2100 ;; STRING comes usually from a (in-package STRING) form.
2101 (ignore-errors
2102 (find-package (let ((*package* *swank-io-package*))
2103 (read-from-string string)))))
2104
2105 (defun unparse-name (string)
2106 "Print the name STRING according to the current printer settings."
2107 ;; this is intended for package or symbol names
2108 (subseq (prin1-to-string (make-symbol string)) 2))
2109
2110 (defun guess-package (string)
2111 "Guess which package corresponds to STRING.
2112 Return nil if no package matches."
2113 (when string
2114 (or (find-package string)
2115 (parse-package string)
2116 (if (find #\! string) ; for SBCL
2117 (guess-package (substitute #\- #\! string))))))
2118
2119 (defvar *readtable-alist* (default-readtable-alist)
2120 "An alist mapping package names to readtables.")
2121
2122 (defun guess-buffer-readtable (package-name)
2123 (let ((package (guess-package package-name)))
2124 (or (and package
2125 (cdr (assoc (package-name package) *readtable-alist*
2126 :test #'string=)))
2127 *readtable*)))
2128
2129
2130 ;;;; Evaluation
2131
2132 (defvar *pending-continuations* '()
2133 "List of continuations for Emacs. (thread local)")
2134
2135 (defun guess-buffer-package (string)
2136 "Return a package for STRING.
2137 Fall back to the the current if no such package exists."
2138 (or (and string (guess-package string))
2139 *package*))
2140
2141 (defun eval-for-emacs (form buffer-package id)
2142 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2143 Return the result to the continuation ID.
2144 Errors are trapped and invoke our debugger."
2145 (let (ok result)
2146 (unwind-protect
2147 (let ((*buffer-package* (guess-buffer-package buffer-package))
2148 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2149 (*pending-continuations* (cons id *pending-continuations*)))
2150 (check-type *buffer-package* package)
2151 (check-type *buffer-readtable* readtable)
2152 ;; APPLY would be cleaner than EVAL.
2153 ;;(setq result (apply (car form) (cdr form)))
2154 (setq result (with-slime-interrupts (eval form)))
2155 (run-hook *pre-reply-hook*)
2156 (setq ok t))
2157 (send-to-emacs `(:return ,(current-thread)
2158 ,(if ok
2159 `(:ok ,result)
2160 `(:abort))
2161 ,id)))))
2162
2163 (defvar *echo-area-prefix* "=> "
2164 "A prefix that `format-values-for-echo-area' should use.")
2165
2166 (defun format-values-for-echo-area (values)
2167 (with-buffer-syntax ()
2168 (let ((*print-readably* nil))
2169 (cond ((null values) "; No value")
2170 ((and (integerp (car values)) (null (cdr values)))
2171 (let ((i (car values)))
2172 (format nil "~A~D (#x~X, #o~O, #b~B)"
2173 *echo-area-prefix* i i i i)))
2174 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
2175
2176 (defslimefun interactive-eval (string)
2177 (with-buffer-syntax ()
2178 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2179 (let ((values (multiple-value-list (eval (from-string string)))))
2180 (fresh-line)
2181 (finish-output)
2182 (format-values-for-echo-area values)))))
2183
2184 (defslimefun eval-and-grab-output (string)
2185 (with-buffer-syntax ()
2186 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2187 (let* ((s (make-string-output-stream))
2188 (*standard-output* s)
2189 (values (multiple-value-list (eval (from-string string)))))
2190 (list (get-output-stream-string s)
2191 (format nil "~{~S~^~%~}" values))))))
2192
2193 (defun eval-region (string)
2194 "Evaluate STRING.
2195 Return the results of the last form as a list and as secondary value the
2196 last form."
2197 (with-input-from-string (stream string)
2198 (let (- values)
2199 (loop
2200 (let ((form (read stream nil stream)))
2201 (when (eq form stream)
2202 (fresh-line)
2203 (finish-output)
2204 (return (values values -)))
2205 (setq - form)
2206 (setq values (multiple-value-list (eval form)))
2207 (finish-output))))))
2208
2209 (defslimefun interactive-eval-region (string)
2210 (with-buffer-syntax ()
2211 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2212 (format-values-for-echo-area (eval-region string)))))
2213
2214 (defslimefun re-evaluate-defvar (form)
2215 (with-buffer-syntax ()
2216 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2217 (let ((form (read-from-string form)))
2218 (destructuring-bind (dv name &optional value doc) form
2219 (declare (ignore value doc))
2220 (assert (eq dv 'defvar))
2221 (makunbound name)
2222 (prin1-to-string (eval form)))))))
2223
2224 (defvar *swank-pprint-bindings*
2225 `((*print-pretty* . t)
2226 (*print-level* . nil)
2227 (*print-length* . nil)
2228 (*print-circle* . t)
2229 (*print-gensym* . t)
2230 (*print-readably* . nil))
2231 "A list of variables bindings during pretty printing.
2232 Used by pprint-eval.")
2233
2234 (defun swank-pprint (list)
2235 "Bind some printer variables and pretty print each object in LIST."
2236 (with-buffer-syntax ()
2237 (with-bindings *swank-pprint-bindings*
2238 (cond ((null list) "; No value")
2239 (t (with-output-to-string (*standard-output*)
2240 (dolist (o list)
2241 (pprint o)
2242 (terpri))))))))
2243
2244 (defslimefun pprint-eval (string)
2245 (with-buffer-syntax ()
2246 (let* ((s (make-string-output-stream))
2247 (values
2248 (let ((*standard-output* s)
2249 (*trace-output* s))
2250 (multiple-value-list (eval (read-from-string string))))))
2251 (cat (get-output-stream-string s)
2252 (swank-pprint values)))))
2253
2254 (defslimefun set-package (name)
2255 "Set *package* to the package named NAME.
2256 Return the full package-name and the string to use in the prompt."
2257 (let ((p (guess-package name)))
2258 (assert (packagep p) nil "Package ~a doesn't exist." name)
2259 (setq *package* p)
2260 (list (package-name p) (package-string-for-prompt p))))
2261
2262 ;;;;; Listener eval
2263
2264 (defvar *listener-eval-function* 'repl-eval)
2265
2266 (defslimefun listener-eval (string)
2267 (funcall *listener-eval-function* string))
2268
2269 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
2270
2271 (defun repl-eval (string)
2272 (clear-user-input)
2273 (with-buffer-syntax ()
2274 (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
2275 (track-package
2276 (lambda ()
2277 (multiple-value-bind (values last-form) (eval-region string)
2278 (setq *** ** ** * * (car values)
2279 /// // // / / values
2280 +++ ++ ++ + + last-form)
2281 (funcall *send-repl-results-function* values))))))
2282 nil)
2283
2284 (defun track-package (fun)
2285 (let ((p *package*))
2286 (unwind-protect (funcall fun)
2287 (unless (eq *package* p)
2288 (send-to-emacs (list :new-package (package-name *package*)
2289 (package-string-for-prompt *package*)))))))
2290
2291 (defun send-repl-results-to-emacs (values)
2292 (finish-output)
2293 (if (null values)
2294 (send-to-emacs `(:write-string "; No value" :repl-result))
2295 (dolist (v values)
2296 (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
2297 :repl-result)))))
2298
2299 (defun cat (&rest strings)
2300 "Concatenate all arguments and make the result a string."
2301 (with-output-to-string (out)
2302 (dolist (s strings)
2303 (etypecase s
2304 (string (write-string s out))
2305 (character (write-char s out))))))
2306
2307 (defun truncate-string (string width &optional ellipsis)
2308 (let ((len (length string)))
2309 (cond ((< len width) string)
2310 (ellipsis (cat (subseq string 0 width) ellipsis))
2311 (t (subseq string 0 width)))))
2312
2313 (defun call/truncated-output-to-string (length function
2314 &optional (ellipsis ".."))
2315 "Call FUNCTION with a new stream, return the output written to the stream.
2316 If FUNCTION tries to write more than LENGTH characters, it will be
2317 aborted and return immediately with the output written so far."
2318 (let ((buffer (make-string (+ length (length ellipsis))))
2319 (fill-pointer 0))
2320 (block buffer-full
2321 (flet ((write-output (string)
2322 (let* ((free (- length fill-pointer))
2323 (count (min free (length string))))
2324 (replace buffer string :start1 fill-pointer :end2 count)
2325 (incf fill-pointer count)
2326 (when (> (length string) free)
2327 (replace buffer ellipsis :start1 fill-pointer)
2328 (return-from buffer-full buffer)))))
2329 (let ((stream (make-output-stream #'write-output)))
2330
2331 (funcall function stream)
2332 (finish-output stream)
2333 (subseq buffer 0 fill-pointer))))))
2334
2335 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
2336 (#\\ . "\\\\"))))
2337 "Write STRING to STREAM surronded by double-quotes.
2338 LENGTH -- if non-nil truncate output after LENGTH chars.
2339 MAP -- rewrite the chars in STRING according to this alist."
2340 (let ((limit (or length array-dimension-limit)))
2341 (write-char #\" stream)
2342 (loop for c across string
2343 for i from 0 do
2344 (when (= i limit)
2345 (write-string "..." stream)
2346 (return))
2347 (let ((probe (assoc c map)))
2348 (cond (probe (write-string (cdr probe) stream))
2349 (t (write-char c stream)))))
2350 (write-char #\" stream)))
2351
2352 (defun package-string-for-prompt (package)
2353 "Return the shortest nickname (or canonical name) of PACKAGE."
2354 (unparse-name
2355 (or (canonical-package-nickname package)
2356 (auto-abbreviated-package-name package)
2357 (shortest-package-nickname package))))
2358
2359 (defun canonical-package-nickname (package)
2360 "Return the canonical package nickname, if any, of PACKAGE."
2361 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2362 :test #'string=))))
2363 (and name (string name))))
2364
2365 (defun auto-abbreviated-package-name (package)
2366 "Return an abbreviated 'name' for PACKAGE.
2367
2368 N.B. this is not an actual package name or nickname."
2369 (when *auto-abbreviate-dotted-packages*
2370 (loop with package-name = (package-name package)
2371 with offset = nil
2372 do (let ((last-dot-pos (position #\. package-name :end offset :from-end t)))
2373 (unless last-dot-pos
2374 (return nil))
2375 ;; If a dot chunk contains only numbers, that chunk most
2376 ;; likely represents a version number; so we collect the
2377 ;; next chunks, too, until we find one with meat.
2378 (let ((name (subseq package-name (1+ last-dot-pos) offset)))
2379 (if (notevery #'digit-char-p name)
2380 (return (subseq package-name (1+ last-dot-pos)))
2381 (setq offset last-dot-pos)))))))
2382
2383 (defun shortest-package-nickname (package)
2384 "Return the shortest nickname of PACKAGE."
2385 (loop for name in (cons (package-name package) (package-nicknames package))
2386 for shortest = name then (if (< (length name) (length shortest))
2387 name
2388 shortest)
2389 finally (return shortest)))
2390
2391 (defslimefun ed-in-emacs (&optional what)
2392 "Edit WHAT in Emacs.
2393
2394 WHAT can be:
2395 A pathname or a string,
2396 A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
2397 A function name (symbol or cons),
2398 NIL. "
2399 (flet ((canonicalize-filename (filename)
2400 (pathname-to-filename (or (probe-file filename) filename))))
2401 (let ((target
2402 (etypecase what
2403 (null nil)
2404 ((or string pathname)
2405 `(:filename ,(canonicalize-filename what)))
2406 ((cons (or string pathname) *)
2407 `(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
2408 ((or symbol cons)
2409 `(:function-name ,(prin1-to-string-for-emacs what))))))
2410 (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2411 ((default-connection)
2412 (with-connection ((default-connection))
2413 (send-oob-to-emacs `(:ed ,target))))
2414 (t (error "No connection"))))))
2415
2416 (defslimefun inspect-in-emacs (what &key wait)
2417 "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
2418 inspector has been closed in Emacs."
2419 (flet ((send-it ()
2420 (let ((tag (when wait (make-tag)))
2421 (thread (when wait (current-thread-id))))
2422 (with-buffer-syntax ()
2423 (reset-inspector)
2424 (send-oob-to-emacs `(:inspect ,(inspect-object what)
2425 ,thread
2426 ,tag)))
2427 (when wait
2428 (wait-for-event `(:emacs-return ,tag result))))))
2429 (cond
2430 (*emacs-connection*
2431 (send-it))
2432 ((default-connection)
2433 (with-connection ((default-connection))
2434 (send-it))))
2435 what))
2436
2437 (defslimefun value-for-editing (form)
2438 "Return a readable value of FORM for editing in Emacs.
2439 FORM is expected, but not required, to be SETF'able."
2440 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2441 (with-buffer-syntax ()
2442 (let* ((value (eval (read-from-string form)))
2443 (*print-length* nil))
2444 (prin1-to-string value))))
2445
2446 (defslimefun commit-edited-value (form value)
2447 "Set the value of a setf'able FORM to VALUE.
2448 FORM and VALUE are both strings from Emacs."
2449 (with-buffer-syntax ()
2450 (eval `(setf ,(read-from-string form)
2451 ,(read-from-string (concatenate 'string "`" value))))
2452 t))
2453
2454 (defun background-message (format-string &rest args)
2455 "Display a message in Emacs' echo area.
2456
2457 Use this function for informative messages only. The message may even
2458 be dropped, if we are too busy with other things."
2459 (when *emacs-connection*
2460 (send-to-emacs `(:background-message
2461 ,(apply #'format nil format-string args)))))
2462
2463 ;; This is only used by the test suite.
2464 (defun sleep-for (seconds)
2465 "Sleep for at least SECONDS seconds.
2466 This is just like cl:sleep but guarantees to sleep
2467 at least SECONDS."
2468 (let* ((start (get-internal-real-time))
2469 (end (+ start
2470 (* seconds internal-time-units-per-second))))
2471 (loop
2472 (let ((now (get-internal-real-time)))
2473 (cond ((< end now) (return))
2474 (t (sleep (/ (- end now)
2475 internal-time-units-per-second))))))))
2476
2477
2478 ;;;; Debugger
2479
2480 (defun invoke-slime-debugger (condition)
2481 "Sends a message to Emacs declaring that the debugger has been entered,
2482 then waits to handle further requests from Emacs. Eventually returns
2483 after Emacs causes a restart to be invoked."
2484 (without-slime-interrupts
2485 (cond (*emacs-connection*
2486 (debug-in-emacs condition))
2487 ((default-connection)
2488 (with-connection ((default-connection))
2489 (debug-in-emacs condition))))))
2490
2491 (define-condition invoke-default-debugger () ())
2492 (defun swank-debugger-hook (condition hook)
2493 "Debugger function for binding *DEBUGGER-HOOK*."
2494 (declare (ignore hook))
2495 (handler-case
2496 (call-with-debugger-hook #'swank-debugger-hook
2497 (lambda () (invoke-slime-debugger condition)))
2498 (invoke-default-debugger ()
2499 (invoke-default-debugger condition))))
2500
2501 (defun invoke-default-debugger (condition)
2502 (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
2503
2504 (defvar *global-debugger* t
2505 "Non-nil means the Swank debugger hook will be installed globally.")
2506
2507 (add-hook *new-connection-hook* 'install-debugger)
2508 (defun install-debugger (connection)
2509 (declare (ignore connection))
2510 (when *global-debugger*
2511 (install-debugger-globally #'swank-debugger-hook)))
2512
2513 ;;;;; Debugger loop
2514 ;;;
2515 ;;; These variables are dynamically bound during debugging.
2516 ;;;
2517 (defvar *swank-debugger-condition* nil
2518 "The condition being debugged.")
2519
2520 (defvar *sldb-level* 0
2521 "The current level of recursive debugging.")
2522
2523 (defvar *sldb-initial-frames* 20
2524 "The initial number of backtrace frames to send to Emacs.")
2525
2526 (defvar *sldb-restarts* nil
2527 "The list of currenlty active restarts.")
2528
2529 (defvar *sldb-stepping-p* nil
2530 "True during execution of a step command.")
2531
2532 (defun debug-in-emacs (condition)
2533 (let ((*swank-debugger-condition* condition)
2534 (*sldb-restarts* (compute-restarts condition))
2535 (*sldb-quit-restart* (if (boundp '*sldb-quit-restart*)
2536 *sldb-quit-restart*
2537 (find-restart 'abort)))
2538 (*package* (or (and (boundp '*buffer-package*)
2539 (symbol-value '*buffer-package*))
2540 *package*))
2541 (*sldb-level* (1+ *sldb-level*))
2542 (*sldb-stepping-p* nil)
2543 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2544 (force-user-output)
2545 (call-with-debugging-environment
2546 (lambda ()
2547 ;; We used to have (WITH-BINDING *SLDB-PRINTER-BINDINGS* ...)
2548 ;; here, but that truncated the result of an eval-in-frame.
2549 (sldb-loop *sldb-level*)))))
2550
2551 (defun sldb-loop (level)
2552 (unwind-protect
2553 (loop
2554 (with-simple-restart (abort "Return to sldb level ~D." level)
2555 (send-to-emacs
2556 (list* :debug (current-thread-id) level
2557 (with-bindings *sldb-printer-bindings*
2558 (debugger-info-for-emacs 0 *sldb-initial-frames*))))
2559 (send-to-emacs
2560 (list :debug-activate (current-thread-id) level nil))
2561 (loop
2562 (handler-case
2563 (destructure-case (wait-for-event
2564 `(or (:emacs-rex . _)
2565 (:sldb-return ,(1+ level))))
2566 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
2567 ((:sldb-return _) (declare (ignore _)) (return nil)))
2568 (sldb-condition (c)
2569 (handle-sldb-condition c))))))
2570 (send-to-emacs `(:debug-return
2571 ,(current-thread-id) ,level ,*sldb-stepping-p*))
2572 (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
2573 (when (> level 1)
2574 (send-event (current-thread) `(:sldb-return ,level)))))
2575
2576 (defun handle-sldb-condition (condition)
2577 "Handle an internal debugger condition.
2578 Rather than recursively debug the debugger (a dangerous idea!), these
2579 conditions are simply reported."
2580 (let ((real-condition (original-condition condition)))
2581 (send-to-emacs `(:debug-condition ,(current-thread-id)
2582 ,(princ-to-string real-condition)))))
2583
2584 (defvar *sldb-condition-printer* #'format-sldb-condition
2585 "Function called to print a condition to an SLDB buffer.")
2586
2587 (defun safe-condition-message (condition)
2588 "Safely print condition to a string, handling any errors during
2589 printing."
2590 (let ((*print-pretty* t) (*print-right-margin* 65))
2591 (handler-case
2592 (funcall *sldb-condition-printer* condition)
2593 (error (cond)
2594 ;; Beware of recursive errors in printing, so only use the condition
2595 ;; if it is printable itself:
2596 (format nil "Unable to display error condition~@[: ~A~]"
2597 (ignore-errors (princ-to-string cond)))))))
2598
2599 (defun debugger-condition-for-emacs ()
2600 (list (safe-condition-message *swank-debugger-condition*)
2601 (format nil " [Condition of type ~S]"
2602 (type-of *swank-debugger-condition*))
2603 (condition-extras *swank-debugger-condition*)))
2604
2605 (defun format-restarts-for-emacs ()
2606 "Return a list of restarts for *swank-debugger-condition* in a
2607 format suitable for Emacs."
2608 (let ((*print-right-margin* most-positive-fixnum))
2609 (loop for restart in *sldb-restarts*
2610 collect (list (princ-to-string (restart-name restart))
2611 (princ-to-string restart)))))
2612
2613
2614 ;;;;; SLDB entry points
2615
2616 (defslimefun sldb-break-with-default-debugger (dont-unwind)
2617 "Invoke the default debugger."
2618 (cond (dont-unwind
2619 (invoke-default-debugger *swank-debugger-condition*))
2620 (t
2621 (signal 'invoke-default-debugger))))
2622
2623 (defslimefun backtrace (start end)
2624 "Return a list ((I FRAME PLIST) ...) of frames from START to END.
2625
2626 I is an integer, and can be used to reference the corresponding frame
2627 from Emacs; FRAME is a string representation of an implementation's
2628 frame."
2629 (loop for frame in (compute-backtrace start end)
2630 for i from start collect
2631 (list* i (frame-to-string frame)
2632 (ecase (frame-restartable-p frame)
2633 ((nil) nil)
2634 ((t) `((:restartable t)))))))
2635
2636 (defun frame-to-string (frame)
2637 (with-bindings *backtrace-printer-bindings*
2638 (call/truncated-output-to-string
2639 (* (or *print-lines* 1) (or *print-right-margin* 100))
2640 (lambda (stream)
2641 (handler-case (print-frame frame stream)
2642 (serious-condition ()
2643 (format stream "[error printing frame]")))))))
2644
2645 (defslimefun debugger-info-for-emacs (start end)
2646 "Return debugger state, with stack frames from START to END.
2647 The result is a list:
2648 (condition ({restart}*) ({stack-frame}*) (cont*))
2649 where
2650 condition ::= (description type [extra])
2651 restart ::= (name description)
2652 stack-frame ::= (number description [plist])
2653 extra ::= (:references and other random things)
2654 cont ::= continutation
2655 plist ::= (:restartable {nil | t | :unknown})
2656
2657 condition---a pair of strings: message, and type. If show-source is
2658 not nil it is a frame number for which the source should be displayed.
2659
2660 restart---a pair of strings: restart name, and description.
2661
2662 stack-frame---a number from zero (the top), and a printed
2663 representation of the frame's call.
2664
2665 continutation---the id of a pending Emacs continuation.
2666
2667 Below is an example return value. In this case the condition was a
2668 division by zero (multi-line description), and only one frame is being
2669 fetched (start=0, end=1).
2670
2671 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2672 Operation was KERNEL::DIVISION, operands (1 0).\"
2673 \"[Condition of type DIVISION-BY-ZERO]\")
2674 ((\"ABORT\" \"Return to Slime toplevel.\")
2675 (\"ABORT\" \"Return to Top-Level.\"))
2676 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
2677 (4))"
2678 (list (debugger-condition-for-emacs)
2679 (format-restarts-for-emacs)
2680 (backtrace start end)
2681 *pending-continuations*))
2682
2683 (defun nth-restart (index)
2684 (nth index *sldb-restarts*))
2685
2686 (defslimefun invoke-nth-restart (index)
2687 (invoke-restart-interactively (nth-restart index)))
2688
2689 (defslimefun sldb-abort ()
2690 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2691
2692 (defslimefun sldb-continue ()
2693 (continue))
2694
2695 (defslimefun throw-to-toplevel ()
2696 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2697 If we are not evaluating an RPC then ABORT instead."
2698 (let ((restart (and (boundp '*sldb-quit-restart*)
2699 (typep *sldb-quit-restart* 'restart)
2700 (find-restart *sldb-quit-restart*))))
2701 (cond (restart (invoke-restart restart))
2702 (t "No toplevel restart active"))))
2703
2704 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2705 "Invoke the Nth available restart.
2706 SLDB-LEVEL is the debug level when the request was made. If this
2707 has changed, ignore the request."
2708 (when (= sldb-level *sldb-level*)
2709 (invoke-nth-restart n)))
2710
2711 (defun wrap-sldb-vars (form)
2712 `(let ((*sldb-level* ,*sldb-level*))
2713 ,form))
2714
2715 (defslimefun eval-string-in-frame (string index)
2716 (to-string
2717 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2718 (eval-in-frame (wrap-sldb-vars (from-string string))
2719 index))))
2720
2721 (defslimefun pprint-eval-string-in-frame (string index)
2722 (swank-pprint
2723 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2724 (multiple-value-list
2725