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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.753 - (show annotations)
Wed Oct 5 11:58:00 2011 UTC (2 years, 6 months ago) by sboukarev
Branch: MAIN
Changes since 1.752: +5 -0 lines
* swank.lisp (clear-repl-variables): New functions, clears *, /,
and + variables.

* contrib/slime-repl.el (slime-clear-repl-variables): New function, clears *, /,
and + variables.
(slime-repl-clear-buffer-hook): Add `slime-clear-repl-variables'
to it, now C-c M-o clears variables, allowing bound objects to be GCed.
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 (defun accept-connections (socket style coding-system dont-close)
880 (let* ((ef (find-external-format-or-lose coding-system))
881 (client (unwind-protect
882 (accept-connection socket :external-format ef)
883 (unless dont-close
884 (close-socket socket)))))
885 (authenticate-client client)
886 (serve-requests (make-connection socket client style coding-system))))
887
888 (defun authenticate-client (stream)
889 (let ((secret (slime-secret)))
890 (when secret
891 (set-stream-timeout stream 20)
892 (let ((first-val (decode-message stream)))
893 (unless (and (stringp first-val) (string= first-val secret))
894 (error "Incoming connection doesn't know the password.")))
895 (set-stream-timeout stream nil))))
896
897 (defun slime-secret ()
898 "Finds the magic secret from the user's home directory. Returns nil
899 if the file doesn't exist; otherwise the first line of the file."
900 (with-open-file (in
901 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
902 :if-does-not-exist nil)
903 (and in (read-line in nil ""))))
904
905 (defun serve-requests (connection)
906 "Read and process all requests on connections."
907 (funcall (connection.serve-requests connection) connection))
908
909 (defun announce-server-port (file port)
910 (with-open-file (s file
911 :direction :output
912 :if-exists :error
913 :if-does-not-exist :create)
914 (format s "~S~%" port))
915 (simple-announce-function port))
916
917 (defun simple-announce-function (port)
918 (when *swank-debug-p*
919 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
920 (force-output *log-output*)))
921
922 (defun open-streams (connection)
923 "Return the 5 streams for IO redirection:
924 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
925 (let* ((input-fn
926 (lambda ()
927 (with-connection (connection)
928 (with-simple-restart (abort-read
929 "Abort reading input from Emacs.")
930 (read-user-input-from-emacs)))))
931 (dedicated-output (if *use-dedicated-output-stream*
932 (open-dedicated-output-stream
933 (connection.socket-io connection))))
934 (in (make-input-stream input-fn))
935 (out (or dedicated-output
936 (make-output-stream (make-output-function connection))))
937 (io (make-two-way-stream in out))
938 (repl-results (make-output-stream-for-target connection
939 :repl-result)))
940 (when (eq (connection.communication-style connection) :spawn)
941 (setf (connection.auto-flush-thread connection)
942 (spawn (lambda () (auto-flush-loop out))
943 :name "auto-flush-thread")))
944 (values dedicated-output in out io repl-results)))
945
946 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
947 (defun make-output-function (connection)
948 "Create function to send user output to Emacs."
949 (let ((i 0) (tag 0) (l 0))
950 (lambda (string)
951 (with-connection (connection)
952 (multiple-value-setq (i tag l)
953 (send-user-output string i tag l))))))
954
955 (defvar *maximum-pipelined-output-chunks* 50)
956 (defvar *maximum-pipelined-output-length* (* 80 20 5))
957 (defun send-user-output (string pcount tag plength)
958 ;; send output with flow control
959 (when (or (> pcount *maximum-pipelined-output-chunks*)
960 (> plength *maximum-pipelined-output-length*))
961 (setf tag (mod (1+ tag) 1000))
962 (send-to-emacs `(:ping ,(current-thread-id) ,tag))
963 (with-simple-restart (abort "Abort sending output to Emacs.")
964 (wait-for-event `(:emacs-pong ,tag)))
965 (setf pcount 0)
966 (setf plength 0))
967 (send-to-emacs `(:write-string ,string))
968 (values (1+ pcount) tag (+ plength (length string))))
969
970 (defun make-output-function-for-target (connection target)
971 "Create a function to send user output to a specific TARGET in Emacs."
972 (lambda (string)
973 (with-connection (connection)
974 (with-simple-restart
975 (abort "Abort sending output to Emacs.")
976 (send-to-emacs `(:write-string ,string ,target))))))
977
978 (defun make-output-stream-for-target (connection target)
979 "Create a stream that sends output to a specific TARGET in Emacs."
980 (make-output-stream (make-output-function-for-target connection target)))
981
982 (defun open-dedicated-output-stream (socket-io)
983 "Open a dedicated output connection to the Emacs on SOCKET-IO.
984 Return an output stream suitable for writing program output.
985
986 This is an optimized way for Lisp to deliver output to Emacs."
987 (let ((socket (create-socket *loopback-interface*
988 *dedicated-output-stream-port*)))
989 (unwind-protect
990 (let ((port (local-port socket)))
991 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
992 (let ((dedicated (accept-connection
993 socket
994 :external-format
995 (or (ignore-errors
996 (stream-external-format socket-io))
997 :default)
998 :buffering *dedicated-output-stream-buffering*
999 :timeout 30)))
1000 (authenticate-client dedicated)
1001 (close-socket socket)
1002 (setf socket nil)
1003 dedicated))
1004 (when socket
1005 (close-socket socket)))))
1006
1007
1008 ;;;;; Event Decoding/Encoding
1009
1010 (defun decode-message (stream)
1011 "Read an S-expression from STREAM using the SLIME protocol."
1012 (log-event "decode-message~%")
1013 (without-slime-interrupts
1014 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1015 (handler-case (read-message stream *swank-io-package*)
1016 (swank-reader-error (c)
1017 `(:reader-error ,(swank-reader-error.packet c)
1018 ,(swank-reader-error.cause c)))))))
1019
1020 (defun encode-message (message stream)
1021 "Write an S-expression to STREAM using the SLIME protocol."
1022 (log-event "encode-message~%")
1023 (without-slime-interrupts
1024 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1025 (write-message message *swank-io-package* stream))))
1026
1027
1028 ;;;;; Event Processing
1029
1030 (defvar *sldb-quit-restart* nil
1031 "The restart that will be invoked when the user calls sldb-quit.")
1032
1033 ;; Establish a top-level restart and execute BODY.
1034 ;; Execute K if the restart is invoked.
1035 (defmacro with-top-level-restart ((connection k) &body body)
1036 `(with-connection (,connection)
1037 (restart-case
1038 (let ((*sldb-quit-restart* (find-restart 'abort)))
1039 ,@body)
1040 (abort (&optional v)
1041 :report "Return to SLIME's top level."
1042 (declare (ignore v))
1043 (force-user-output)
1044 ,k))))
1045
1046 (defun handle-requests (connection &optional timeout)
1047 "Read and process :emacs-rex requests.
1048 The processing is done in the extent of the toplevel restart."
1049 (with-connection (connection)
1050 (cond (*sldb-quit-restart*
1051 (process-requests timeout))
1052 (t
1053 (tagbody
1054 start
1055 (with-top-level-restart (connection (go start))
1056 (process-requests timeout)))))))
1057
1058 (defun process-requests (timeout)
1059 "Read and process requests from Emacs."
1060 (loop
1061 (multiple-value-bind (event timeout?)
1062 (wait-for-event `(or (:emacs-rex . _)
1063 (:emacs-channel-send . _))
1064 timeout)
1065 (when timeout? (return))
1066 (destructure-case event
1067 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
1068 ((:emacs-channel-send channel (selector &rest args))
1069 (channel-send channel selector args))))))
1070
1071 (defun current-socket-io ()
1072 (connection.socket-io *emacs-connection*))
1073
1074 (defun close-connection (c condition backtrace)
1075 (let ((*debugger-hook* nil))
1076 (log-event "close-connection: ~a ...~%" condition)
1077 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
1078 (let ((cleanup (connection.cleanup c)))
1079 (when cleanup
1080 (funcall cleanup c)))
1081 (close (connection.socket-io c))
1082 (when (connection.dedicated-output c)
1083 (close (connection.dedicated-output c)))
1084 (setf *connections* (remove c *connections*))
1085 (run-hook *connection-closed-hook* c)
1086 (when (and condition (not (typep condition 'end-of-file)))
1087 (finish-output *log-output*)
1088 (format *log-output* "~&;; Event history start:~%")
1089 (dump-event-history *log-output*)
1090 (format *log-output* ";; Event history end.~%~
1091 ;; Backtrace:~%~{~A~%~}~
1092 ;; Connection to Emacs lost. [~%~
1093 ;; condition: ~A~%~
1094 ;; type: ~S~%~
1095 ;; encoding: ~A vs. ~A~%~
1096 ;; style: ~S dedicated: ~S]~%"
1097 backtrace
1098 (escape-non-ascii (safe-condition-message condition) )
1099 (type-of condition)
1100 (connection.coding-system c)
1101 (connection.external-format c)
1102 (connection.communication-style c)
1103 *use-dedicated-output-stream*)
1104 (finish-output *log-output*))
1105 (log-event "close-connection ~a ... done.~%" condition)))
1106
1107 ;;;;;; Thread based communication
1108
1109 (defvar *active-threads* '())
1110
1111 (defun read-loop (connection)
1112 (let ((input-stream (connection.socket-io connection))
1113 (control-thread (connection.control-thread connection)))
1114 (with-swank-error-handler (connection)
1115 (loop (send control-thread (decode-message input-stream))))))
1116
1117 (defun dispatch-loop (connection)
1118 (let ((*emacs-connection* connection))
1119 (with-panic-handler (connection)
1120 (loop (dispatch-event (receive))))))
1121
1122 (defvar *auto-flush-interval* 0.2)
1123
1124 (defun auto-flush-loop (stream)
1125 (loop
1126 (when (not (and (open-stream-p stream)
1127 (output-stream-p stream)))
1128 (return nil))
1129 ;; Use an IO timeout to avoid deadlocks
1130 ;; on the stream we're flushing.
1131 (call-with-io-timeout
1132 (lambda () (finish-output stream))
1133 :seconds 0.1)
1134 (sleep *auto-flush-interval*)))
1135
1136 (defun find-repl-thread (connection)
1137 (cond ((not (use-threads-p))
1138 (current-thread))
1139 (t
1140 (let ((thread (connection.repl-thread connection)))
1141 (cond ((not thread) nil)
1142 ((thread-alive-p thread) thread)
1143 (t
1144 (setf (connection.repl-thread connection)
1145 (spawn-repl-thread connection "new-repl-thread"))))))))
1146
1147 (defun find-worker-thread (id)
1148 (etypecase id
1149 ((member t)
1150 (car *active-threads*))
1151 ((member :repl-thread)
1152 (find-repl-thread *emacs-connection*))
1153 (fixnum
1154 (find-thread id))))
1155
1156 (defun interrupt-worker-thread (id)
1157 (let ((thread (or (find-worker-thread id)
1158 (find-repl-thread *emacs-connection*)
1159 ;; FIXME: to something better here
1160 (spawn (lambda ()) :name "ephemeral"))))
1161 (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1162 (assert thread)
1163 (cond ((use-threads-p)
1164 (interrupt-thread thread
1165 (lambda ()
1166 ;; safely interrupt THREAD
1167 (invoke-or-queue-interrupt #'simple-break))))
1168 (t (simple-break)))))
1169
1170 (defun thread-for-evaluation (id)
1171 "Find or create a thread to evaluate the next request."
1172 (let ((c *emacs-connection*))
1173 (etypecase id
1174 ((member t)
1175 (cond ((use-threads-p) (spawn-worker-thread c))
1176 (t (current-thread))))
1177 ((member :repl-thread)
1178 (find-repl-thread c))
1179 (fixnum
1180 (find-thread id)))))
1181
1182 (defun spawn-worker-thread (connection)
1183 (spawn (lambda ()
1184 (with-bindings *default-worker-thread-bindings*
1185 (with-top-level-restart (connection nil)
1186 (apply #'eval-for-emacs
1187 (cdr (wait-for-event `(:emacs-rex . _)))))))
1188 :name "worker"))
1189
1190 (defun spawn-repl-thread (connection name)
1191 (spawn (lambda ()
1192 (with-bindings *default-worker-thread-bindings*
1193 (repl-loop connection)))
1194 :name name))
1195
1196 (defun dispatch-event (event)
1197 "Handle an event triggered either by Emacs or within Lisp."
1198 (log-event "dispatch-event: ~s~%" event)
1199 (destructure-case event
1200 ((:emacs-rex form package thread-id id)
1201 (let ((thread (thread-for-evaluation thread-id)))
1202 (cond (thread
1203 (push thread *active-threads*)
1204 (send-event thread `(:emacs-rex ,form ,package ,id)))
1205 (t
1206 (encode-message
1207 (list :invalid-rpc id
1208 (format nil "Thread not found: ~s" thread-id))
1209 (current-socket-io))))))
1210 ((:return thread &rest args)
1211 (let ((tail (member thread *active-threads*)))
1212 (setq *active-threads* (nconc (ldiff *active-threads* tail)
1213 (cdr tail))))
1214 (encode-message `(:return ,@args) (current-socket-io)))
1215 ((:emacs-interrupt thread-id)
1216 (interrupt-worker-thread thread-id))
1217 (((:write-string
1218 :debug :debug-condition :debug-activate :debug-return :channel-send
1219 :presentation-start :presentation-end
1220 :new-package :new-features :ed :indentation-update
1221 :eval :eval-no-wait :background-message :inspect :ping
1222 :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
1223 &rest _)
1224 (declare (ignore _))
1225 (encode-message event (current-socket-io)))
1226 (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1227 (send-event (find-thread thread-id) (cons (car event) args)))
1228 ((:emacs-channel-send channel-id msg)
1229 (let ((ch (find-channel channel-id)))
1230 (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1231 ((:reader-error packet condition)
1232 (encode-message `(:reader-error ,packet
1233 ,(safe-condition-message condition))
1234 (current-socket-io)))))
1235
1236 (defvar *event-queue* '())
1237 (defvar *events-enqueued* 0)
1238
1239 (defun send-event (thread event)
1240 (log-event "send-event: ~s ~s~%" thread event)
1241 (cond ((use-threads-p) (send thread event))
1242 (t (setf *event-queue* (nconc *event-queue* (list event)))
1243 (setf *events-enqueued* (mod (1+ *events-enqueued*)
1244 most-positive-fixnum)))))
1245
1246 (defun send-to-emacs (event)
1247 "Send EVENT to Emacs."
1248 ;;(log-event "send-to-emacs: ~a" event)
1249 (cond ((use-threads-p)
1250 (send (connection.control-thread *emacs-connection*) event))
1251 (t (dispatch-event event))))
1252
1253 (defun wait-for-event (pattern &optional timeout)
1254 "Scan the event queue for PATTERN and return the event.
1255 If TIMEOUT is 'nil wait until a matching event is enqued.
1256 If TIMEOUT is 't only scan the queue without waiting.
1257 The second return value is t if the timeout expired before a matching
1258 event was found."
1259 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1260 (without-slime-interrupts
1261 (cond ((use-threads-p)
1262 (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1263 (t
1264 (wait-for-event/event-loop pattern timeout)))))
1265
1266 (defun wait-for-event/event-loop (pattern timeout)
1267 (assert (or (not timeout) (eq timeout t)))
1268 (loop
1269 (check-slime-interrupts)
1270 (let ((event (poll-for-event pattern)))
1271 (when event (return (car event))))
1272 (let ((events-enqueued *events-enqueued*)
1273 (ready (wait-for-input (list (current-socket-io)) timeout)))
1274 (cond ((and timeout (not ready))
1275 (return (values nil t)))
1276 ((or (/= events-enqueued *events-enqueued*)
1277 (eq ready :interrupt))
1278 ;; rescan event queue, interrupts may enqueue new events
1279 )
1280 (t
1281 (assert (equal ready (list (current-socket-io))))
1282 (dispatch-event (decode-message (current-socket-io))))))))
1283
1284 (defun poll-for-event (pattern)
1285 (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1286 *event-queue*)))
1287 (when tail
1288 (setq *event-queue* (nconc (ldiff *event-queue* tail)
1289 (cdr tail)))
1290 tail)))
1291
1292 ;;; FIXME: Make this use SWANK-MATCH.
1293 (defun event-match-p (event pattern)
1294 (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1295 (member pattern '(nil t)))
1296 (equal event pattern))
1297 ((symbolp pattern) t)
1298 ((consp pattern)
1299 (case (car pattern)
1300 ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1301 (t (and (consp event)
1302 (and (event-match-p (car event) (car pattern))
1303 (event-match-p (cdr event) (cdr pattern)))))))
1304 (t (error "Invalid pattern: ~S" pattern))))
1305
1306 (defun spawn-threads-for-connection (connection)
1307 (setf (connection.control-thread connection)
1308 (spawn (lambda () (control-thread connection))
1309 :name "control-thread"))
1310 connection)
1311
1312 (defun control-thread (connection)
1313 (with-struct* (connection. @ connection)
1314 (setf (@ control-thread) (current-thread))
1315 (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1316 :name "reader-thread"))
1317 (dispatch-loop connection)))
1318
1319 (defun cleanup-connection-threads (connection)
1320 (let ((threads (list (connection.repl-thread connection)
1321 (connection.reader-thread connection)
1322 (connection.control-thread connection)
1323 (connection.auto-flush-thread connection))))
1324 (dolist (thread threads)
1325 (when (and thread
1326 (thread-alive-p thread)
1327 (not (equal (current-thread) thread)))
1328 (kill-thread thread)))))
1329
1330 (defun repl-loop (connection)
1331 (handle-requests connection))
1332
1333 ;;;;;; Signal driven IO
1334
1335 (defun install-sigio-handler (connection)
1336 (add-sigio-handler (connection.socket-io connection)
1337 (lambda () (process-io-interrupt connection)))
1338 (handle-requests connection t))
1339
1340 (defvar *io-interupt-level* 0)
1341
1342 (defun process-io-interrupt (connection)
1343 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1344 (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1345 (invoke-or-queue-interrupt
1346 (lambda () (handle-requests connection t))))
1347 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1348
1349 (defun deinstall-sigio-handler (connection)
1350 (log-event "deinstall-sigio-handler...~%")
1351 (remove-sigio-handlers (connection.socket-io connection))
1352 (log-event "deinstall-sigio-handler...done~%"))
1353
1354 ;;;;;; SERVE-EVENT based IO
1355
1356 (defun install-fd-handler (connection)
1357 (add-fd-handler (connection.socket-io connection)
1358 (lambda () (handle-requests connection t)))
1359 (setf (connection.saved-sigint-handler connection)
1360 (install-sigint-handler
1361 (lambda ()
1362 (invoke-or-queue-interrupt
1363 (lambda () (dispatch-interrupt-event connection))))))
1364 (handle-requests connection t))
1365
1366 (defun dispatch-interrupt-event (connection)
1367 ;; This boils down to INTERRUPT-WORKER-THREAD which uses
1368 ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
1369 (with-connection (connection)
1370 (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
1371
1372 (defun deinstall-fd-handler (connection)
1373 (log-event "deinstall-fd-handler~%")
1374 (remove-fd-handlers (connection.socket-io connection))
1375 (install-sigint-handler (connection.saved-sigint-handler connection)))
1376
1377 ;;;;;; Simple sequential IO
1378
1379 (defun simple-serve-requests (connection)
1380 (unwind-protect
1381 (with-connection (connection)
1382 (call-with-user-break-handler
1383 (lambda ()
1384 (invoke-or-queue-interrupt
1385 (lambda () (dispatch-interrupt-event connection))))
1386 (lambda ()
1387 (with-simple-restart (close-connection "Close SLIME connection.")
1388 (let* ((stdin (real-input-stream *standard-input*))
1389 (*standard-input* (make-repl-input-stream connection
1390 stdin)))
1391 (tagbody toplevel
1392 (with-top-level-restart (connection (go toplevel))
1393 (simple-repl))))))))
1394 (close-connection connection nil (safe-backtrace))))
1395
1396 ;; this is signalled when our custom stream thinks the end-of-file is reached.
1397 ;; (not when the end-of-file on the socket is reached)
1398 (define-condition end-of-repl-input (end-of-file) ())
1399
1400 (defun simple-repl ()
1401 (loop
1402 (format t "~a> " (package-string-for-prompt *package*))
1403 (force-output)
1404 (let ((form (handler-case (read)
1405 (end-of-repl-input () (return)))))
1406 (let ((- form)
1407 (values (multiple-value-list (eval form))))
1408 (setq *** ** ** * * (car values)
1409 /// // // / / values
1410 +++ ++ ++ + + form)
1411 (cond ((null values) (format t "; No values~&"))
1412 (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
1413
1414 (defun make-repl-input-stream (connection stdin)
1415 (make-input-stream
1416 (lambda () (repl-input-stream-read connection stdin))))
1417
1418 (defun repl-input-stream-read (connection stdin)
1419 (loop
1420 (let* ((socket (connection.socket-io connection))
1421 (inputs (list socket stdin))
1422 (ready (wait-for-input inputs)))
1423 (cond ((eq ready :interrupt)
1424 (check-slime-interrupts))
1425 ((member socket ready)
1426 ;; A Slime request from Emacs is pending; make sure to
1427 ;; redirect IO to the REPL buffer.
1428 (with-simple-restart (process-input "Continue reading input.")
1429 (let ((*sldb-quit-restart* (find-restart 'process-input)))
1430 (with-io-redirection (connection)
1431 (handle-requests connection t)))))
1432 ((member stdin ready)
1433 ;; User typed something into the *inferior-lisp* buffer,
1434 ;; so do not redirect.
1435 (return (read-non-blocking stdin)))
1436 (t (assert (null ready)))))))
1437
1438 (defun read-non-blocking (stream)
1439 (with-output-to-string (str)
1440 (handler-case
1441 (loop (let ((c (read-char-no-hang stream)))
1442 (unless c (return))
1443 (write-char c str)))
1444 (end-of-file () (error 'end-of-repl-input :stream stream)))))
1445
1446
1447 ;;;; IO to Emacs
1448 ;;;
1449 ;;; This code handles redirection of the standard I/O streams
1450 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1451 ;;; contains the appropriate streams, so all we have to do is make the
1452 ;;; right bindings.
1453
1454 ;;;;; Global I/O redirection framework
1455 ;;;
1456 ;;; Optionally, the top-level global bindings of the standard streams
1457 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1458 ;;; redirect the streams into the connection, and they keep going into
1459 ;;; that connection even if more are established. If the connection
1460 ;;; handling the streams closes then another is chosen, or if there
1461 ;;; are no connections then we revert to the original (real) streams.
1462 ;;;
1463 ;;; It is slightly tricky to assign the global values of standard
1464 ;;; streams because they are often shadowed by dynamic bindings. We
1465 ;;; solve this problem by introducing an extra indirection via synonym
1466 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1467 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1468 ;;; variables, so they can always be assigned to affect a global
1469 ;;; change.
1470
1471 (defvar *globally-redirect-io* nil
1472 "When non-nil globally redirect all standard streams to Emacs.")
1473
1474 ;;;;; Global redirection setup
1475
1476 (defvar *saved-global-streams* '()
1477 "A plist to save and restore redirected stream objects.
1478 E.g. the value for '*standard-output* holds the stream object
1479 for *standard-output* before we install our redirection.")
1480
1481 (defun setup-stream-indirection (stream-var &optional stream)
1482 "Setup redirection scaffolding for a global stream variable.
1483 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1484
1485 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1486
1487 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1488 *STANDARD-INPUT*.
1489
1490 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1491 *CURRENT-STANDARD-INPUT*.
1492
1493 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1494 effective global value for *STANDARD-INPUT*. This way we can assign
1495 the effective global value even when *STANDARD-INPUT* is shadowed by a
1496 dynamic binding."
1497 (let ((current-stream-var (prefixed-var '#:current stream-var))
1498 (stream (or stream (symbol-value stream-var))))
1499 ;; Save the real stream value for the future.
1500 (setf (getf *saved-global-streams* stream-var) stream)
1501 ;; Define a new variable for the effective stream.
1502 ;; This can be reassigned.
1503 (proclaim `(special ,current-stream-var))
1504 (set current-stream-var stream)
1505 ;; Assign the real binding as a synonym for the current one.
1506 (let ((stream (make-synonym-stream current-stream-var)))
1507 (set stream-var stream)
1508 (set-default-initial-binding stream-var `(quote ,stream)))))
1509
1510 (defun prefixed-var (prefix variable-symbol)
1511 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1512 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1513 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1514
1515 (defvar *standard-output-streams*
1516 '(*standard-output* *error-output* *trace-output*)
1517 "The symbols naming standard output streams.")
1518
1519 (defvar *standard-input-streams*
1520 '(*standard-input*)
1521 "The symbols naming standard input streams.")
1522
1523 (defvar *standard-io-streams*
1524 '(*debug-io* *query-io* *terminal-io*)
1525 "The symbols naming standard io streams.")
1526
1527 (defun init-global-stream-redirection ()
1528 (when *globally-redirect-io*
1529 (cond (*saved-global-streams*
1530 (warn "Streams already redirected."))
1531 (t
1532 (mapc #'setup-stream-indirection
1533 (append *standard-output-streams*
1534 *standard-input-streams*
1535 *standard-io-streams*))))))
1536
1537 (add-hook *after-init-hook* 'init-global-stream-redirection)
1538
1539 (defun globally-redirect-io-to-connection (connection)
1540 "Set the standard I/O streams to redirect to CONNECTION.
1541 Assigns *CURRENT-<STREAM>* for all standard streams."
1542 (dolist (o *standard-output-streams*)
1543 (set (prefixed-var '#:current o)
1544 (connection.user-output connection)))
1545 ;; FIXME: If we redirect standard input to Emacs then we get the
1546 ;; regular Lisp top-level trying to read from our REPL.
1547 ;;
1548 ;; Perhaps the ideal would be for the real top-level to run in a
1549 ;; thread with local bindings for all the standard streams. Failing
1550 ;; that we probably would like to inhibit it from reading while
1551 ;; Emacs is connected.
1552 ;;
1553 ;; Meanwhile we just leave *standard-input* alone.
1554 #+NIL
1555 (dolist (i *standard-input-streams*)
1556 (set (prefixed-var '#:current i)
1557 (connection.user-input connection)))
1558 (dolist (io *standard-io-streams*)
1559 (set (prefixed-var '#:current io)
1560 (connection.user-io connection))))
1561
1562 (defun revert-global-io-redirection ()
1563 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1564 (dolist (stream-var (append *standard-output-streams*
1565 *standard-input-streams*
1566 *standard-io-streams*))
1567 (set (prefixed-var '#:current stream-var)
1568 (getf *saved-global-streams* stream-var))))
1569
1570 ;;;;; Global redirection hooks
1571
1572 (defvar *global-stdio-connection* nil
1573 "The connection to which standard I/O streams are globally redirected.
1574 NIL if streams are not globally redirected.")
1575
1576 (defun maybe-redirect-global-io (connection)
1577 "Consider globally redirecting to CONNECTION."
1578 (when (and *globally-redirect-io* (null *global-stdio-connection*)
1579 (connection.user-io connection))
1580 (setq *global-stdio-connection* connection)
1581 (globally-redirect-io-to-connection connection)))
1582
1583 (defun update-redirection-after-close (closed-connection)
1584 "Update redirection after a connection closes."
1585 (check-type closed-connection connection)
1586 (when (eq *global-stdio-connection* closed-connection)
1587 (if (and (default-connection) *globally-redirect-io*)
1588 ;; Redirect to another connection.
1589 (globally-redirect-io-to-connection (default-connection))
1590 ;; No more connections, revert to the real streams.
1591 (progn (revert-global-io-redirection)
1592 (setq *global-stdio-connection* nil)))))
1593
1594 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1595
1596 ;;;;; Redirection during requests
1597 ;;;
1598 ;;; We always redirect the standard streams to Emacs while evaluating
1599 ;;; an RPC. This is done with simple dynamic bindings.
1600
1601 (defslimefun create-repl (target)
1602 (assert (eq target nil))
1603 (let ((conn *emacs-connection*))
1604 (initialize-streams-for-connection conn)
1605 (with-struct* (connection. @ conn)
1606 (setf (@ env)
1607 `((*standard-output* . ,(@ user-output))
1608 (*standard-input* . ,(@ user-input))
1609 (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1610 (*error-output* . ,(@ user-output))
1611 (*debug-io* . ,(@ user-io))
1612 (*query-io* . ,(@ user-io))
1613 (*terminal-io* . ,(@ user-io))))
1614 (maybe-redirect-global-io conn)
1615 (when (use-threads-p)
1616 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1617 (list (package-name *package*)
1618 (package-string-for-prompt *package*)))))
1619
1620 (defun initialize-streams-for-connection (connection)
1621 (multiple-value-bind (dedicated in out io repl-results)
1622 (open-streams connection)
1623 (setf (connection.dedicated-output connection) dedicated
1624 (connection.user-io connection) io
1625 (connection.user-output connection) out
1626 (connection.user-input connection) in
1627 (connection.repl-results connection) repl-results)
1628 connection))
1629
1630
1631 ;;; Channels
1632
1633 (defvar *channels* '())
1634 (defvar *channel-counter* 0)
1635
1636 (defclass channel ()
1637 ((id :reader channel-id)
1638 (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1639 (name :initarg :name :initform nil)))
1640
1641 (defmethod initialize-instance ((ch channel) &rest initargs)
1642 (declare (ignore initargs))
1643 (call-next-method)
1644 (with-slots (id) ch
1645 (setf id (incf *channel-counter*))
1646 (push (cons id ch) *channels*)))
1647
1648 (defmethod print-object ((c channel) stream)
1649 (print-unreadable-object (c stream :type t)
1650 (with-slots (id name) c
1651 (format stream "~d ~a" id name))))
1652
1653 (defun find-channel (id)
1654 (cdr (assoc id *channels*)))
1655
1656 (defgeneric channel-send (channel selector args))
1657
1658 (defmacro define-channel-method (selector (channel &rest args) &body body)
1659 `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1660 (destructuring-bind ,args args
1661 . ,body)))
1662
1663 (defun send-to-remote-channel (channel-id msg)
1664 (send-to-emacs `(:channel-send ,channel-id ,msg)))
1665
1666 (defclass listener-channel (channel)
1667 ((remote :initarg :remote)
1668 (env :initarg :env)))
1669
1670 (defslimefun create-listener (remote)
1671 (let* ((pkg *package*)
1672 (conn *emacs-connection*)
1673 (ch (make-instance 'listener-channel
1674 :remote remote
1675 :env (initial-listener-bindings remote))))
1676
1677 (with-slots (thread id) ch
1678 (when (use-threads-p)
1679 (setf thread (spawn-listener-thread ch conn)))
1680 (list id
1681 (thread-id thread)
1682 (package-name pkg)
1683 (package-string-for-prompt pkg)))))
1684
1685 (defun initial-listener-bindings (remote)
1686 `((*package* . ,*package*)
1687 (*standard-output*
1688 . ,(make-listener-output-stream remote))
1689 (*standard-input*
1690 . ,(make-listener-input-stream remote))))
1691
1692 (defun spawn-listener-thread (channel connection)
1693 (spawn (lambda ()
1694 (with-connection (connection)
1695 (loop
1696 (destructure-case (wait-for-event `(:emacs-channel-send . _))
1697 ((:emacs-channel-send c (selector &rest args))
1698 (assert (eq c channel))
1699 (channel-send channel selector args))))))
1700 :name "swank-listener-thread"))
1701
1702 (define-channel-method :eval ((c listener-channel) string)
1703 (with-slots (remote env) c
1704 (let ((aborted t))
1705 (with-bindings env
1706 (unwind-protect
1707 (let* ((form (read-from-string string))
1708 (value (eval form)))
1709 (send-to-remote-channel remote
1710 `(:write-result
1711 ,(prin1-to-string value)))
1712 (setq aborted nil))
1713 (force-output)
1714 (setf env (loop for (sym) in env
1715 collect (cons sym (symbol-value sym))))
1716 (let ((pkg (package-name *package*))
1717 (prompt (package-string-for-prompt *package*)))
1718 (send-to-remote-channel remote
1719 (if aborted
1720 `(:evaluation-aborted ,pkg ,prompt)
1721 `(:prompt ,pkg ,prompt)))))))))
1722
1723 (defun make-listener-output-stream (remote)
1724 (make-output-stream (lambda (string)
1725 (send-to-remote-channel remote
1726 `(:write-string ,string)))))
1727
1728 (defun make-listener-input-stream (remote)
1729 (make-input-stream
1730 (lambda ()
1731 (force-output)
1732 (let ((tag (make-tag)))
1733 (send-to-remote-channel remote
1734 `(:read-string ,(current-thread-id) ,tag))
1735 (let ((ok nil))
1736 (unwind-protect
1737 (prog1 (caddr (wait-for-event
1738 `(:emacs-return-string ,tag value)))
1739 (setq ok t))
1740 (unless ok
1741 (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1742
1743
1744
1745 (defun input-available-p (stream)
1746 ;; return true iff we can read from STREAM without waiting or if we
1747 ;; hit EOF
1748 (let ((c (read-char-no-hang stream nil :eof)))
1749 (cond ((not c) nil)
1750 ((eq c :eof) t)
1751 (t
1752 (unread-char c stream)
1753 t))))
1754
1755 (defvar *slime-features* nil
1756 "The feature list that has been sent to Emacs.")
1757
1758 (defun send-oob-to-emacs (object)
1759 (send-to-emacs object))
1760
1761 (defun force-user-output ()
1762 (force-output (connection.user-io *emacs-connection*)))
1763
1764 (add-hook *pre-reply-hook* 'force-user-output)
1765
1766 (defun clear-user-input ()
1767 (clear-input (connection.user-input *emacs-connection*)))
1768
1769 (defvar *tag-counter* 0)
1770
1771 (defun make-tag ()
1772 (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1773
1774 (defun read-user-input-from-emacs ()
1775 (let ((tag (make-tag)))
1776 (force-output)
1777 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1778 (let ((ok nil))
1779 (unwind-protect
1780 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1781 (setq ok t))
1782 (unless ok
1783 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1784
1785 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1786 "Like y-or-n-p, but ask in the Emacs minibuffer."
1787 (let ((tag (make-tag))
1788 (question (apply #'format nil format-string arguments)))
1789 (force-output)
1790 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1791 (third (wait-for-event `(:emacs-return ,tag result)))))
1792
1793 (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1794 "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1795 entered nothing, returns NIL when user pressed C-g."
1796 (check-type prompt string) (check-type initial-value (or null string))
1797 (let ((tag (make-tag)))
1798 (force-output)
1799 (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1800 ,prompt ,initial-value))
1801 (third (wait-for-event `(:emacs-return ,tag result)))))
1802
1803
1804 (defun process-form-for-emacs (form)
1805 "Returns a string which emacs will read as equivalent to
1806 FORM. FORM can contain lists, strings, characters, symbols and
1807 numbers.
1808
1809 Characters are converted emacs' ?<char> notaion, strings are left
1810 as they are (except for espacing any nested \" chars, numbers are
1811 printed in base 10 and symbols are printed as their symbol-name
1812 converted to lower case."
1813 (etypecase form
1814 (string (format nil "~S" form))
1815 (cons (format nil "(~A . ~A)"
1816 (process-form-for-emacs (car form))
1817 (process-form-for-emacs (cdr form))))
1818 (character (format nil "?~C" form))
1819 (symbol (concatenate 'string (when (eq (symbol-package form)
1820 #.(find-package "KEYWORD"))
1821 ":")
1822 (string-downcase (symbol-name form))))
1823 (number (let ((*print-base* 10))
1824 (princ-to-string form)))))
1825
1826 (defun eval-in-emacs (form &optional nowait)
1827 "Eval FORM in Emacs.
1828 `slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
1829 (cond (nowait
1830 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1831 (t
1832 (force-output)
1833 (let ((tag (make-tag)))
1834 (send-to-emacs `(:eval ,(current-thread-id) ,tag
1835 ,(process-form-for-emacs form)))
1836 (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1837 (destructure-case value
1838 ((:ok value) value)
1839 ((:error kind . data) (error "~a: ~{~a~}" kind data))
1840 ((:abort) (abort))))))))
1841
1842 (defvar *swank-wire-protocol-version* nil
1843 "The version of the swank/slime communication protocol.")
1844
1845 (defslimefun connection-info ()
1846 "Return a key-value list of the form:
1847 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1848 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1849 STYLE: the communication style
1850 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1851 FEATURES: a list of keywords
1852 PACKAGE: a list (&key NAME PROMPT)
1853 VERSION: the protocol version"
1854 (let ((c *emacs-connection*))
1855 (setq *slime-features* *features*)
1856 `(:pid ,(getpid) :style ,(connection.communication-style c)
1857 :encoding (:coding-system ,(connection.coding-system c)
1858 ;; external-formats are totally implementation-dependent,
1859 ;; so better play safe.
1860 :external-format ,(princ-to-string
1861 (connection.external-format c)))
1862 :lisp-implementation (:type ,(lisp-implementation-type)
1863 :name ,(lisp-implementation-type-name)
1864 :version ,(lisp-implementation-version)
1865 :program ,(lisp-implementation-program))
1866 :machine (:instance ,(machine-instance)
1867 :type ,(machine-type)
1868 :version ,(machine-version))
1869 :features ,(features-for-emacs)
1870 :modules ,*modules*
1871 :package (:name ,(package-name *package*)
1872 :prompt ,(package-string-for-prompt *package*))
1873 :version ,*swank-wire-protocol-version*)))
1874
1875 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1876 (let* ((s *standard-output*)
1877 (*trace-output* (make-broadcast-stream s *log-output*)))
1878 (time (progn
1879 (dotimes (i n)
1880 (format s "~D abcdefghijklm~%" i)
1881 (when (zerop (mod n m))
1882 (finish-output s)))
1883 (finish-output s)
1884 (when *emacs-connection*
1885 (eval-in-emacs '(message "done.")))))
1886 (terpri *trace-output*)
1887 (finish-output *trace-output*)
1888 nil))
1889
1890 (defun debug-on-swank-error ()
1891 (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1892 *debug-on-swank-protocol-error*)
1893
1894 (defun (setf debug-on-swank-error) (new-value)
1895 (setf *debug-on-swank-protocol-error* new-value)
1896 (setf *debug-swank-backend* new-value))
1897
1898 (defslimefun toggle-debug-on-swank-error ()
1899 (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1900
1901
1902 ;;;; Reading and printing
1903
1904 (define-special *buffer-package*
1905 "Package corresponding to slime-buffer-package.
1906
1907 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1908 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1909
1910 (define-special *buffer-readtable*
1911 "Readtable associated with the current buffer")
1912
1913 (defmacro with-buffer-syntax ((&optional package) &body body)
1914 "Execute BODY with appropriate *package* and *readtable* bindings.
1915
1916 This should be used for code that is conceptionally executed in an
1917 Emacs buffer."
1918 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1919
1920 (defun call-with-buffer-syntax (package fun)
1921 (let ((*package* (if package
1922 (guess-buffer-package package)
1923 *buffer-package*)))
1924 ;; Don't shadow *readtable* unnecessarily because that prevents
1925 ;; the user from assigning to it.
1926 (if (eq *readtable* *buffer-readtable*)
1927 (call-with-syntax-hooks fun)
1928 (let ((*readtable* *buffer-readtable*))
1929 (call-with-syntax-hooks fun)))))
1930
1931 (defmacro without-printing-errors ((&key object stream
1932 (msg "<<error printing object>>"))
1933 &body body)
1934 "Catches errors during evaluation of BODY and prints MSG instead."
1935 `(handler-case (progn ,@body)
1936 (serious-condition ()
1937 ,(cond ((and stream object)
1938 (let ((gstream (gensym "STREAM+")))
1939 `(let ((,gstream ,stream))
1940 (print-unreadable-object (,object ,gstream :type t :identity t)
1941 (write-string ,msg ,gstream)))))
1942 (stream
1943 `(write-string ,msg ,stream))
1944 (object
1945 `(with-output-to-string (s)
1946 (print-unreadable-object (,object s :type t :identity t)
1947 (write-string ,msg s))))
1948 (t msg)))))
1949
1950 (defun to-string (object)
1951 "Write OBJECT in the *BUFFER-PACKAGE*.
1952 The result may not be readable. Handles problems with PRINT-OBJECT methods
1953 gracefully."
1954 (with-buffer-syntax ()
1955 (let ((*print-readably* nil))
1956 (without-printing-errors (:object object :stream nil)
1957 (prin1-to-string object)))))
1958
1959 (defun from-string (string)
1960 "Read string in the *BUFFER-PACKAGE*"
1961 (with-buffer-syntax ()
1962 (let ((*read-suppress* nil))
1963 (values (read-from-string string)))))
1964
1965 (defun parse-string (string package)
1966 "Read STRING in PACKAGE."
1967 (with-buffer-syntax (package)
1968 (let ((*read-suppress* nil))
1969 (read-from-string string))))
1970
1971 ;; FIXME: deal with #\| etc. hard to do portably.
1972 (defun tokenize-symbol (string)
1973 "STRING is interpreted as the string representation of a symbol
1974 and is tokenized accordingly. The result is returned in three
1975 values: The package identifier part, the actual symbol identifier
1976 part, and a flag if the STRING represents a symbol that is
1977 internal to the package identifier part. (Notice that the flag is
1978 also true with an empty package identifier part, as the STRING is
1979 considered to represent a symbol internal to some current package.)"
1980 (let ((package (let ((pos (position #\: string)))
1981 (if pos (subseq string 0 pos) nil)))
1982 (symbol (let ((pos (position #\: string :from-end t)))
1983 (if pos (subseq string (1+ pos)) string)))
1984 (internp (not (= (count #\: string) 1))))
1985 (values symbol package internp)))
1986
1987 (defun tokenize-symbol-thoroughly (string)
1988 "This version of TOKENIZE-SYMBOL handles escape characters."
1989 (let ((package nil)
1990 (token (make-array (length string) :element-type 'character
1991 :fill-pointer 0))
1992 (backslash nil)
1993 (vertical nil)
1994 (internp nil))
1995 (loop for char across string do
1996 (cond
1997 (backslash
1998 (vector-push-extend char token)
1999 (setq backslash nil))
2000 ((char= char #\\) ; Quotes next character, even within |...|
2001 (setq backslash t))
2002 ((char= char #\|)
2003 (setq vertical (not vertical)))
2004 (vertical
2005 (vector-push-extend char token))
2006 ((char= char #\:)
2007 (cond ((and package internp)
2008 (return-from tokenize-symbol-thoroughly))
2009 (package
2010 (setq internp t))
2011 (t
2012 (setq package token
2013 token (make-array (length string)
2014 :element-type 'character
2015 :fill-pointer 0)))))
2016 (t
2017 (vector-push-extend (casify-char char) token))))
2018 (unless vertical
2019 (values token package (or (not package) internp)))))
2020
2021 (defun untokenize-symbol (package-name internal-p symbol-name)
2022 "The inverse of TOKENIZE-SYMBOL.
2023
2024 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
2025 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
2026 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
2027 "
2028 (cond ((not package-name) symbol-name)
2029 (internal-p (cat package-name "::" symbol-name))
2030 (t (cat package-name ":" symbol-name))))
2031
2032 (defun casify-char (char)
2033 "Convert CHAR accoring to readtable-case."
2034 (ecase (readtable-case *readtable*)
2035 (:preserve char)
2036 (:upcase (char-upcase char))
2037 (:downcase (char-downcase char))
2038 (:invert (if (upper-case-p char)
2039 (char-downcase char)
2040 (char-upcase char)))))
2041
2042
2043 (defun find-symbol-with-status (symbol-name status
2044 &optional (package *package*))
2045 (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
2046 (if (and flag (eq flag status))
2047 (values symbol flag)
2048 (values nil nil))))
2049
2050 (defun parse-symbol (string &optional (package *package*))
2051 "Find the symbol named STRING.
2052 Return the symbol and a flag indicating whether the symbols was found."
2053 (multiple-value-bind (sname pname internalp)
2054 (tokenize-symbol-thoroughly string)
2055 (when sname
2056 (let ((package (cond ((string= pname "") keyword-package)
2057 (pname (find-package pname))
2058 (t package))))
2059 (if package
2060 (multiple-value-bind (symbol flag)
2061 (if internalp
2062 (find-symbol sname package)
2063 (find-symbol-with-status sname ':external package))
2064 (values symbol flag sname package))
2065 (values nil nil nil nil))))))
2066
2067 (defun parse-symbol-or-lose (string &optional (package *package*))
2068 (multiple-value-bind (symbol status) (parse-symbol string package)
2069 (if status
2070 (values symbol status)
2071 (error "Unknown symbol: ~A [in ~A]" string package))))
2072
2073 (defun parse-package (string)
2074 "Find the package named STRING.
2075 Return the package or nil."
2076 ;; STRING comes usually from a (in-package STRING) form.
2077 (ignore-errors
2078 (find-package (let ((*package* *swank-io-package*))
2079 (read-from-string string)))))
2080
2081 (defun unparse-name (string)
2082 "Print the name STRING according to the current printer settings."
2083 ;; this is intended for package or symbol names
2084 (subseq (prin1-to-string (make-symbol string)) 2))
2085
2086 (defun guess-package (string)
2087 "Guess which package corresponds to STRING.
2088 Return nil if no package matches."
2089 (when string
2090 (or (find-package string)
2091 (parse-package string)
2092 (if (find #\! string) ; for SBCL
2093 (guess-package (substitute #\- #\! string))))))
2094
2095 (defvar *readtable-alist* (default-readtable-alist)
2096 "An alist mapping package names to readtables.")
2097
2098 (defun guess-buffer-readtable (package-name)
2099 (let ((package (guess-package package-name)))
2100 (or (and package
2101 (cdr (assoc (package-name package) *readtable-alist*
2102 :test #'string=)))
2103 *readtable*)))
2104
2105
2106 ;;;; Evaluation
2107
2108 (defvar *pending-continuations* '()
2109 "List of continuations for Emacs. (thread local)")
2110
2111 (defun guess-buffer-package (string)
2112 "Return a package for STRING.
2113 Fall back to the the current if no such package exists."
2114 (or (and string (guess-package string))
2115 *package*))
2116
2117 (defun eval-for-emacs (form buffer-package id)
2118 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2119 Return the result to the continuation ID.
2120 Errors are trapped and invoke our debugger."
2121 (let (ok result condition)
2122 (unwind-protect
2123 (let ((*buffer-package* (guess-buffer-package buffer-package))
2124 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2125 (*pending-continuations* (cons id *pending-continuations*)))
2126 (check-type *buffer-package* package)
2127 (check-type *buffer-readtable* readtable)
2128 ;; APPLY would be cleaner than EVAL.
2129 ;; (setq result (apply (car form) (cdr form)))
2130 (handler-bind ((t (lambda (c) (setf condition c))))
2131 (setq result (with-slime-interrupts (eval form))))
2132 (run-hook *pre-reply-hook*)
2133 (setq ok t))
2134 (send-to-emacs `(:return ,(current-thread)
2135 ,(if ok
2136 `(:ok ,result)
2137 `(:abort ,(prin1-to-string condition)))
2138 ,id)))))
2139
2140 (defvar *echo-area-prefix* "=> "
2141 "A prefix that `format-values-for-echo-area' should use.")
2142
2143 (defun format-values-for-echo-area (values)
2144 (with-buffer-syntax ()
2145 (let ((*print-readably* nil))
2146 (cond ((null values) "; No value")
2147 ((and (integerp (car values)) (null (cdr values)))
2148 (let ((i (car values)))
2149 (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)"
2150 *echo-area-prefix*
2151 i (integer-length i) i i i)))
2152 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
2153
2154 (defmacro values-to-string (values)
2155 `(format-values-for-echo-area (multiple-value-list ,values)))
2156
2157 (defslimefun interactive-eval (string)
2158 (with-buffer-syntax ()
2159 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2160 (let ((values (multiple-value-list (eval (from-string string)))))
2161 (finish-output)
2162 (format-values-for-echo-area values)))))
2163
2164 (defslimefun eval-and-grab-output (string)
2165 (with-buffer-syntax ()
2166 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2167 (let* ((s (make-string-output-stream))
2168 (*standard-output* s)
2169 (values (multiple-value-list (eval (from-string string)))))
2170 (list (get-output-stream-string s)
2171 (format nil "~{~S~^~%~}" values))))))
2172
2173 (defun eval-region (string)
2174 "Evaluate STRING.
2175 Return the results of the last form as a list and as secondary value the
2176 last form."
2177 (with-input-from-string (stream string)
2178 (let (- values)
2179 (loop
2180 (let ((form (read stream nil stream)))
2181 (when (eq form stream)
2182 (finish-output)
2183 (return (values values -)))
2184 (setq - form)
2185 (setq values (multiple-value-list (eval form)))
2186 (finish-output))))))
2187
2188 (defslimefun interactive-eval-region (string)
2189 (with-buffer-syntax ()
2190 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2191 (format-values-for-echo-area (eval-region string)))))
2192
2193 (defslimefun re-evaluate-defvar (form)
2194 (with-buffer-syntax ()
2195 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2196 (let ((form (read-from-string form)))
2197 (destructuring-bind (dv name &optional value doc) form
2198 (declare (ignore value doc))
2199 (assert (eq dv 'defvar))
2200 (makunbound name)
2201 (prin1-to-string (eval form)))))))
2202
2203 (defvar *swank-pprint-bindings*
2204 `((*print-pretty* . t)
2205 (*print-level* . nil)
2206 (*print-length* . nil)
2207 (*print-circle* . t)
2208 (*print-gensym* . t)
2209 (*print-readably* . nil))
2210 "A list of variables bindings during pretty printing.
2211 Used by pprint-eval.")
2212
2213 (defun swank-pprint (values)
2214 "Bind some printer variables and pretty print each object in VALUES."
2215 (with-buffer-syntax ()
2216 (with-bindings *swank-pprint-bindings*
2217 (cond ((null values) "; No value")
2218 (t (with-output-to-string (*standard-output*)
2219 (dolist (o values)
2220 (pprint o)
2221 (terpri))))))))
2222
2223 (defslimefun pprint-eval (string)
2224 (with-buffer-syntax ()
2225 (let* ((s (make-string-output-stream))
2226 (values
2227 (let ((*standard-output* s)
2228 (*trace-output* s))
2229 (multiple-value-list (eval (read-from-string string))))))
2230 (cat (get-output-stream-string s)
2231 (swank-pprint values)))))
2232
2233 (defslimefun set-package (name)
2234 "Set *package* to the package named NAME.
2235 Return the full package-name and the string to use in the prompt."
2236 (let ((p (guess-package name)))
2237 (assert (packagep p) nil "Package ~a doesn't exist." name)
2238 (setq *package* p)
2239 (list (package-name p) (package-string-for-prompt p))))
2240
2241 ;;;;; Listener eval
2242
2243 (defvar *listener-eval-function* 'repl-eval)
2244
2245 (defslimefun listener-eval (string)
2246 (funcall *listener-eval-function* string))
2247
2248 (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
2249
2250 (defun repl-eval (string)
2251 (clear-user-input)
2252 (with-buffer-syntax ()
2253 (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
2254 (track-package
2255 (lambda ()
2256 (multiple-value-bind (values last-form) (eval-region string)
2257 (setq *** ** ** * * (car values)
2258 /// // // / / values
2259 +++ ++ ++ + + last-form)
2260 (funcall *send-repl-results-function* values))))))
2261 nil)
2262
2263 (defslimefun clear-repl-variables ()
2264 (let ((variables '(*** ** * /// // / +++ ++ +)))
2265 (loop for variable in variables
2266 do (setf (symbol-value variable) nil))))
2267
2268 (defun track-package (fun)
2269 (let ((p *package*))
2270 (unwind-protect (funcall fun)
2271 (unless (eq *package* p)
2272 (send-to-emacs (list :new-package (package-name *package*)
2273 (package-string-for-prompt *package*)))))))
2274
2275 (defun send-repl-results-to-emacs (values)
2276 (finish-output)
2277 (if (null values)
2278 (send-to-emacs `(:write-string "; No value" :repl-result))
2279 (dolist (v values)
2280 (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
2281 :repl-result)))))
2282
2283 (defun cat (&rest strings)
2284 "Concatenate all arguments and make the result a string."
2285 (with-output-to-string (out)
2286 (dolist (s strings)
2287 (etypecase s
2288 (string (write-string s out))
2289 (character (write-char s out))))))
2290
2291 (defun truncate-string (string width &optional ellipsis)
2292 (let ((len (length string)))
2293 (cond ((< len width) string)
2294 (ellipsis (cat (subseq string 0 width) ellipsis))
2295 (t (subseq string 0 width)))))
2296
2297 (defun call/truncated-output-to-string (length function
2298 &optional (ellipsis ".."))
2299 "Call FUNCTION with a new stream, return the output written to the stream.
2300 If FUNCTION tries to write more than LENGTH characters, it will be
2301 aborted and return immediately with the output written so far."
2302 (let ((buffer (make-string (+ length (length ellipsis))))
2303 (fill-pointer 0))
2304 (block buffer-full
2305 (flet ((write-output (string)
2306 (let* ((free (- length fill-pointer))
2307 (count (min free (length string))))
2308 (replace buffer string :start1 fill-pointer :end2 count)
2309 (incf fill-pointer count)
2310 (when (> (length string) free)
2311 (replace buffer ellipsis :start1 fill-pointer)
2312 (return-from buffer-full buffer)))))
2313 (let ((stream (make-output-stream #'write-output)))
2314 (funcall function stream)
2315 (finish-output stream)
2316 (subseq buffer 0 fill-pointer))))))
2317
2318 (defmacro with-string-stream ((var &key length bindings)
2319 &body body)
2320 (cond ((and (not bindings) (not length))
2321 `(with-output-to-string (,var) . ,body))
2322 ((not bindings)
2323 `(call/truncated-output-to-string
2324 ,length (lambda (,var) . ,body)))
2325 (t
2326 `(with-bindings ,bindings
2327 (with-string-stream (,var :length ,length)
2328 . ,body)))))
2329
2330 (defun to-line (object &optional (width 75))
2331 "Print OBJECT to a single line. Return the string."
2332 (without-printing-errors (:object object :stream nil)
2333 (with-string-stream (stream :length width)
2334 (write object :stream stream :right-margin width :lines 1))))
2335
2336 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
2337 (#\\ . "\\\\"))))
2338 "Write STRING to STREAM surronded by double-quotes.
2339 LENGTH -- if non-nil truncate output after LENGTH chars.
2340 MAP -- rewrite the chars in STRING according to this alist."
2341 (let ((limit (or length array-dimension-limit)))
2342 (write-char #\" stream)
2343 (loop for c across string
2344 for i from 0 do
2345 (when (= i limit)
2346 (write-string "..." stream)
2347 (return))
2348 (let ((probe (assoc c map)))
2349 (cond (probe (write-string (cdr probe) stream))
2350 (t (write-char c stream)))))
2351 (write-char #\" stream)))
2352
2353 (defun package-string-for-prompt (package)
2354 "Return the shortest nickname (or canonical name) of PACKAGE."
2355 (unparse-name
2356 (or (canonical-package-nickname package)
2357 (auto-abbreviated-package-name package)
2358 (shortest-package-nickname package))))
2359
2360 (defun canonical-package-nickname (package)
2361 "Return the canonical package nickname, if any, of PACKAGE."
2362 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2363 :test #'string=))))
2364 (and name (string name))))
2365
2366 (defun auto-abbreviated-package-name (package)
2367 "Return an abbreviated 'name' for PACKAGE.
2368
2369 N.B. this is not an actual package name or nickname."
2370 (when *auto-abbreviate-dotted-packages*
2371 (loop with package-name = (package-name package)
2372 with offset = nil
2373 do (let ((last-dot-pos (position #\. package-name :end offset :from-end t)))
2374 (unless last-dot-pos
2375 (return nil))
2376 ;; If a dot chunk contains only numbers, that chunk most
2377 ;; likely represents a version number; so we collect the
2378 ;; next chunks, too, until we find one with meat.
2379 (let ((name (subseq package-name (1+ last-dot-pos) offset)))
2380 (if (notevery #'digit-char-p name)
2381 (return (subseq package-name (1+ last-dot-pos)))
2382 (setq offset last-dot-pos)))))))
2383
2384 (defun shortest-package-nickname (package)
2385 "Return the shortest nickname of PACKAGE."
2386 (loop for name in (cons (package-name package) (package-nicknames package))
2387 for shortest = name then (if (< (length name) (length shortest))
2388 name
2389 shortest)
2390 finally (return shortest)))
2391
2392 (defslimefun ed-in-emacs (&optional what)
2393 "Edit WHAT in Emacs.
2394
2395 WHAT can be:
2396 A pathname or a string,
2397 A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
2398 A function name (symbol or cons),
2399 NIL. "
2400 (flet ((canonicalize-filename (filename)
2401 (pathname-to-filename (or (probe-file filename) filename))))
2402 (let ((target
2403 (etypecase what
2404 (null nil)
2405 ((or string pathname)
2406 `(:filename ,(canonicalize-filename what)))
2407 ((cons (or string pathname) *)
2408 `(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
2409 ((or symbol cons)
2410 `(:function-name ,(prin1-to-string what))))))
2411 (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2412 ((default-connection)
2413 (with-connection ((default-connection))
2414 (send-oob-to-emacs `(:ed ,target))))
2415 (t (error "No connection"))))))
2416
2417 (defslimefun inspect-in-emacs (what &key wait)
2418 "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
2419 inspector has been closed in Emacs."
2420 (flet ((send-it ()
2421 (let ((tag (when wait (make-tag)))
2422 (thread (when wait (current-thread-id))))
2423 (with-buffer-syntax ()
2424 (reset-inspector)
2425 (send-oob-to-emacs `(:inspect ,(inspect-object what)
2426 ,thread
2427 ,tag)))
2428 (when wait
2429 (wait-for-event `(:emacs-return ,tag result))))))
2430 (cond
2431 (*emacs-connection*
2432 (send-it))
2433 ((default-connection)
2434 (with-connection ((default-connection))
2435 (send-it))))
2436 what))
2437
2438 (defslimefun value-for-editing (form)
2439 "Return a readable value of FORM for editing in Emacs.
2440 FORM is expected, but not required, to be SETF'able."
2441 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2442 (with-buffer-syntax ()
2443 (let* ((value (eval (read-from-string form)))
2444 (*print-length* nil))
2445 (prin1-to-string value))))
2446
2447 (defslimefun commit-edited-value (form value)
2448 "Set the value of a setf'able FORM to VALUE.
2449 FORM and VALUE are both strings from Emacs."
2450 (with-buffer-syntax ()
2451 (eval `(setf ,(read-from-string form)
2452 ,(read-from-string (concatenate 'string "`" value))))
2453 t))
2454
2455 (defun background-message (format-string &rest args)
2456 "Display a message in Emacs' echo area.
2457
2458 Use this function for informative messages only. The message may even
2459 be dropped, if we are too busy with other things."
2460 (when *emacs-connection*
2461 (send-to-emacs `(:background-message
2462 ,(apply #'format nil format-string args)))))
2463
2464 ;; This is only used by the test suite.
2465 (defun sleep-for (seconds)
2466 "Sleep for at least SECONDS seconds.
2467 This is just like cl:sleep but guarantees to sleep
2468 at least SECONDS."
2469 (let* ((start (get-internal-real-time))
2470 (end (+ start
2471 (* seconds internal-time-units-per-second))))
2472 (loop
2473 (let ((now (get-internal-real-time)))
2474 (cond ((< end now) (return))
2475 (t (sleep (/ (- end now)
2476 internal-time-units-per-second))))))))
2477
2478
2479 ;;;; Debugger
2480
2481 (defun invoke-slime-debugger (condition)
2482 "Sends a message to Emacs declaring that the debugger has been entered,
2483 then waits to handle further requests from Emacs. Eventually returns
2484 after Emacs causes a restart to be invoked."
2485 (without-slime-interrupts
2486 (cond (*emacs-connection*
2487 (debug-in-emacs condition))
2488 ((default-connection)
2489 (with-connection ((default-connection))
2490 (debug-in-emacs condition))))))
2491
2492 (define-condition invoke-default-debugger () ())
2493
2494 (defun swank-debugger-hook (condition hook)
2495 "Debugger function for binding *DEBUGGER-HOOK*."
2496 (declare (ignore hook))
2497 (handler-case
2498 (call-with-debugger-hook #'swank-debugger-hook
2499 (lambda () (invoke-slime-debugger condition)))
2500 (invoke-default-debugger ()
2501 (invoke-default-debugger condition))))
2502
2503 (defun invoke-default-debugger (condition)
2504 (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
2505
2506 (defvar *global-debugger* t
2507 "Non-nil means the Swank debugger hook will be installed globally.")
2508
2509 (add-hook *new-connection-hook* 'install-debugger)
2510 (defun install-debugger (connection)
2511 (declare (ignore connection))
2512 (when *global-debugger*
2513 (install-debugger-globally #'swank-debugger-hook)))
2514
2515 ;;;;; Debugger loop
2516 ;;;
2517 ;;; These variables are dynamically bound during debugging.
2518 ;;;
2519 (defvar *swank-debugger-condition* nil
2520 "The condition being debugged.")
2521
2522 (defvar *sldb-level* 0
2523 "The current level of recursive debugging.")
2524
2525 (defvar *sldb-initial-frames* 20
2526 "The initial number of backtrace frames to send to Emacs.")
2527
2528 (defvar *sldb-restarts* nil
2529 "The list of currenlty active restarts.")
2530
2531 (defvar *sldb-stepping-p* nil
2532 "True during execution of a step command.")
2533
2534 (defun debug-in-emacs (condition)
2535 (let ((*swank-debugger-condition* condition)
2536 (*sldb-restarts* (compute-restarts condition))
2537 (*sldb-quit-restart* (and *sldb-quit-restart*
2538 (find-restart *sldb-quit-restart*)))
2539 (*package* (or (and (boundp '*buffer-package*)
2540 (symbol-value '*buffer-package*))
2541 *package*))
2542 (*sldb-level* (1+ *sldb-level*))
2543 (*sldb-stepping-p* nil))
2544 (force-user-output)
2545 (call-with-debugging-environment
2546 (lambda ()
2547 ;; We used to have (WITH-BINDING *SLDB-PRINTER-BINDINGS* ...)
2548 ;; here, but that truncated the result of an eval-in-frame.
2549 (sldb-loop *sldb-level*)))))
2550
2551 (defun sldb-loop (level)
2552 (unwind-protect
2553 (loop
2554 (with-simple-restart (abort "Return to sldb level ~D." level)
2555 (send-to-emacs
2556 (list* :debug (current-thread-id) level
2557 (with-bindings *sldb-printer-bindings*
2558 (debugger-info-for-emacs 0 *sldb-initial-frames*))))
2559 (send-to-emacs
2560 (list :debug-activate (current-thread-id) level nil))
2561 (loop
2562 (handler-case
2563 (destructure-case (wait-for-event
2564 `(or (:emacs-rex . _)
2565 (:sldb-return ,(1+ level))))
2566 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
2567 ((:sldb-return _) (declare (ignore _)) (return nil)))
2568 (sldb-condition (c)
2569 (handle-sldb-condition c))))))
2570 (send-to-emacs `(:debug-return
2571 ,(current-thread-id) ,level ,*sldb-stepping-p*))
2572 (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
2573 (when (> level 1)
2574 (send-event (current-thread) `(:sldb-return ,level)))))
2575
2576 (defun handle-sldb-condition (condition)
2577 "Handle an internal debugger condition.
2578 Rather than recursively debug the debugger (a dangerous idea!), these
2579 conditions are simply reported."
2580 (let ((real-condition (original-condition condition)))
2581 (send-to-emacs `(:debug-condition ,(current-thread-id)
2582 ,(princ-to-string real-condition)))))
2583
2584 (defvar *sldb-condition-printer* #'format-sldb-condition
2585 "Function called to print a condition to an SLDB buffer.")
2586
2587 (defun safe-condition-message (condition)
2588 "Safely print condition to a string, handling any errors during
2589 printing."
2590 (let ((*print-pretty* t) (*print-right-margin* 65))
2591 (handler-case
2592 (funcall *sldb-condition-printer* condition)
2593 (error (cond)
2594 ;; Beware of recursive errors in printing, so only use the condition
2595 ;; if it is printable itself:
2596 (format nil "Unable to display error condition~@[: ~A~]"
2597 (ignore-errors (princ-to-string cond)))))))
2598
2599 (defun debugger-condition-for-emacs ()
2600 (list (safe-condition-message *swank-debugger-condition*)
2601 (format nil " [Condition of type ~S]"
2602 (type-of *swank-debugger-condition*))
2603 (condition-extras *swank-debugger-condition*)))
2604
2605 (defun format-restarts-for-emacs ()
2606 "Return a list of restarts for *swank-debugger-condition* in a
2607 format suitable for Emacs."
2608 (let ((*print-right-margin* most-positive-fixnum))
2609 (loop for restart in *sldb-restarts* collect
2610 (list (format nil "~:[~;*~]~a"
2611 (eq restart *sldb-quit-restart*)
2612 (restart-name restart))
2613 (with-output-to-string (stream)
2614 (without-printing-errors (:object restart
2615 :stream stream
2616 :msg "<<error printing restart>>")
2617 (princ restart stream)))))))
2618
2619 ;;;;; SLDB entry points
2620
2621 (defslimefun sldb-break-with-default-debugger (dont-unwind)
2622 "Invoke the default debugger."
2623 (cond (dont-unwind
2624 (invoke-default-debugger *swank-debugger-condition*))
2625 (t
2626 (signal 'invoke-default-debugger))))
2627
2628 (defslimefun backtrace (start end)
2629 "Return a list ((I FRAME PLIST) ...) of frames from START to END.
2630
2631 I is an integer, and can be used to reference the corresponding frame
2632 from Emacs; FRAME is a string representation of an implementation's
2633 frame."
2634 (loop for frame in (compute-backtrace start end)
2635 for i from start collect
2636 (list* i (frame-to-string frame)
2637 (ecase (frame-restartable-p frame)
2638 ((nil) nil)
2639 ((t) `((:restartable t)))))))
2640
2641 (defun frame-to-string (frame)
2642 (with-string-stream (stream :length (* (or *print-lines* 1)
2643 (or *print-right-margin* 100))
2644 :bindings *backtrace-printer-bindings*)
2645 (handler-case (print-frame frame stream)
2646 (serious-condition ()
2647 (format stream "[error printing frame]")))))
2648
2649 (defslimefun debugger-info-for-emacs (start end)
2650 "Return debugger state, with stack frames from START to END.
2651 The result is a list:
2652 (condition ({restart}*) ({stack-frame}*) (cont*))
2653 where
2654 condition ::= (description type [extra])
2655 restart ::= (name description)
2656 stack-frame ::= (number description [plist])
2657 extra ::= (:references and other random things)
2658 cont ::= continutation
2659 plist ::= (:restartable {nil | t | :unknown})
2660
2661 condition---a pair of strings: message, and type. If show-source is
2662 not nil it is a frame number for which the source should be displayed.
2663
2664 restart---a pair of strings: restart name, and description.
2665
2666 stack-frame---a number from zero (the top), and a printed
2667 representation of the frame's call.
2668
2669 continutation---the id of a pending Emacs continuation.
2670
2671 Below is an example return value. In this case the condition was a
2672 division by zero (multi-line description), and only one frame is being
2673 fetched (start=0, end=1).
2674
2675 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2676 Operation was KERNEL::DIVISION, operands (1 0).\"
2677 \"[Condition of type DIVISION-BY-ZERO]\")
2678 ((\"ABORT\" \"Return to Slime toplevel.\")
2679 (\"ABORT\" \"Return to Top-Level.\"))
2680 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
2681 (4))"
2682 (list (debugger-condition-for-emacs)
2683 (format-restarts-for-emacs)
2684 (backtrace start end)
2685 *pending-continuations*))
2686
2687 (defun nth-restart (index)
2688 (nth index *sldb-restarts*))
2689
2690 (defslimefun invoke-nth-restart (index)
2691 (let ((restart (nth-restart index)))
2692 (when restart
2693 (invoke-restart-interactively restart))))
2694
2695 (defslimefun sldb-abort ()
2696 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2697
2698 (defslimefun sldb-continue ()
2699 (continue))
2700
2701 (defun coerce-to-condition (datum args)
2702 (etypecase datum
2703 (string (make-condition 'simple-error :format-control datum
2704 :format-arguments args))
2705 (symbol (apply #'make-condition datum args))))
2706
2707 (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
2708 (with-simple-restart (continue "Continue from break.")
2709 (invoke-slime-debugger (coerce-to-condition datum args))))
2710
2711 (defslimefun throw-to-toplevel ()
2712 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2713 If we are not evaluating an RPC then ABORT instead."
2714 (let ((restart (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))))
2715 (cond (restart (invoke-restart restart))
2716 (t (format nil "Restart not active [~s]" *sldb-quit-restart*)))))
2717
2718 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2719 "Invoke the Nth available restart.
2720 SLDB-LEVEL is the debug level when the request was made. If this
2721 has changed, ignore the request."
2722 (