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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.586 - (show annotations)
Fri Sep 12 12:27:37 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.585: +24 -15 lines
	New faces: `sldb-restartable-frame-line-face',
	           `sldb-non-restartable-frame-line-face'.

	The former is the face for frames that are surely restartable, the
	latter for frames that are surely not restartable. If
	restartability of a frame cannot be reliably determined, the face
	`sldb-frame-line-face' is used.

	At the moment, determination of frame restartability is supported
	by the SBCL backend only.

	* slime.el (sldb-frame.string): New.
	(sldb-frame.number): New.
	(sldb-frame.plist): New.
	(sldb-prune-initial-frames): Use them.
	(sldb-insert-frames): Ditto.
	(sldb-compute-frame-face): New.
	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
	frames with one of the faces described above.

	* swank.lisp (defslimefun backtrace): Changed return value; each
	frame is now accompanied with a PLIST which at the moment can
	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
	is restartable, or not.

	* swank-backend.lisp (defstruct swank-frame): New structure.
	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
	(print-frame): Renamed to PRINT-SWANK-FRAME.

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