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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.572 - (show annotations)
Fri Aug 22 14:28:40 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.571: +14 -10 lines
	Compiling a file `let*.lisp' on SBCL via C-c C-k resulted in an
	error, because it parsed the asterisk to a wild pathname. Fix
	that.

	* swank-backend.lisp (definterface parse-emacs-filename): New.
	PARSE-NAMESTRING by default.

	* swank-sbcl.lisp (defimplementation parse-emacs-filename): Use
	SB-EXT:PARSE-NATIVE-NAMESTRING.

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