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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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