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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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