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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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