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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.715 - (show annotations)
Tue May 18 09:12:47 2010 UTC (3 years, 11 months ago) by sboukarev
Branch: MAIN
Changes since 1.714: +3 -3 lines
* slime.el (sldb-insert-condition): Don't create a mouse tooltip
for long error message, tooltip shows the same text and doesn't
add any value.
(slime-definition-at-point): factor out of `slime-inspect-definition'.
(slime-disassemble-definition): New, similar to `slime-inspect-definition'.

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