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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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