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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.634 - (show annotations)
Sat Feb 14 12:33:28 2009 UTC (5 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.633: +6 -3 lines
Don't signal conditions in the interrupt handler to
avoid problems with naive code like
 (handler-case foo (condition bar))

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