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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.672 - (show annotations)
Tue Nov 3 14:33:31 2009 UTC (4 years, 5 months ago) by sboukarev
Branch: MAIN
Changes since 1.671: +1 -2 lines
* slime.el (sldb-backward-frame): If the point is at the end of the buffer,
there is no property, handle this case.

* swank.lisp (collect-notes): LOAD returns generalized boolean,
not just boolean, but make-compilation-result accepts only booleans
for its second argument.

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