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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.763 - (show annotations)
Sun Nov 27 19:24:33 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.762: +33 -53 lines
* swank.lisp (create-server): Remove coding-system argument.
([defstruct] connection): Remove coding-system slot.
(connection.external-format, *coding-system*): Deleted.
(make-connection, start-server, create-server, setup-server)
(accept-connections): Drop coding-system arg.

(connection-info): Return supported coding systems.
(create-repl, open-dedicated-output-stream)
(open-streams, initialize-streams-for-connection): Add
coding-system arg.

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