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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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