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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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