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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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