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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.598 - (show annotations)
Sat Oct 4 19:13:41 2008 UTC (5 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.597: +57 -87 lines
Some cleanups for compilation commands.

* slime.el ([defstruct] slime-compilation-result): Rename result
slot as successp.
(slime-make-compilation-finished-continuation): Deleted.
slime-eval-async preserves the current buffer and preserving the
window-configuration was always a questionable feature.
(slime-compilation-finished): Simplified.
(slime-show-note-counts): Also show the success/failure flag.
(slime-recompile-locations): Take a continuation as argument
rather than messing around with compilation-finished-hooks.
(slime-aggregate-compilation-results): New function.
(slime-xref-recompilation-cont): Renamed from
slime-make-xref-recompilation-cont.
(slime-compiler-results): Deleted.
(slime-goto-first-note-after-compilation): Replaced with hook
function slime-goto-first-note.
(slime-compilation-just-finished): Deleted.
(slime-to-lisp-filename-function): Use convert-standard-filename.
* swank.lisp ([defstruct] compilation-result): Renamed from
swank-compilation-result.
(measure-time-interval): Return seconds as float.
(collect-notes): Renamed from swank-compiler.  Return a single
compilation-result.
(compile-multiple-strings-for-emacs): Return a list of
compilation-results instead of a single result with merged notes.

* swank-backend.lisp (filename-to-pathname): Renamed from
parse-emacs-filename.  Updated callers.
(pathname-to-filename): New function.  Use it where appropriate.

* swank-scl.lisp (pathname-to-filename): Implement it in the
backend to get rid of the #+scl in swank.lisp.

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