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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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