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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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