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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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