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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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