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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.582 - (show annotations)
Mon Sep 8 22:35:58 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.581: +13 -3 lines
A package "Foo.Bar.1.0" was truncated to "0>" as REPL
prompt. It'll now be displayed as "Bar.1.0>".

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