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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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