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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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