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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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