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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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