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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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