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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.603 - (show annotations)
Thu Oct 16 21:15:48 2008 UTC (5 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.602: +1 -0 lines
* swank-lispworks.lisp (with-swank-compilation-unit): Return the
values of BODY.
(compile-from-temp-file): Return T on success.

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