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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.491.2.1 - (show annotations)
Sun Aug 19 11:19:32 2007 UTC (6 years, 8 months ago) by heller
Branch: contrib
Changes since 1.491: +41 -556 lines
Add a contrib directory and move fuzzy completion code to that directory.

* contrib: New directory.

* swank.lisp (swank-require): New function to load contrib code.
(*find-module*, module-filename, *load-path*, merged-directory)
(find-module, module-canditates): New. Pathname acrobatics for
swank-require.

* swank-loader.lisp: Compile (but don't load) contribs.
(*contribs*, contrib-source-files): New.

* contrib/slime-fuzzy.el: New file.
(slime-fuzzy-init): New function.  Load CL code on startup.

* contrib/swank-fuzzy.lisp: New file. Common Lisp code for fuzzy
completion.
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 :common-lisp :swank-backend)
17 (:export #:startup-multiprocessing
18 #:start-server
19 #:create-server
20 #:ed-in-emacs
21 #:inspect-in-emacs
22 #:print-indentation-lossage
23 #:swank-debugger-hook
24 #:run-after-init-hook
25 #:inspect-for-emacs
26 #:inspect-slot-for-emacs
27 ;; These are user-configurable variables:
28 #:*communication-style*
29 #:*dont-close*
30 #:*log-events*
31 #:*log-output*
32 #:*use-dedicated-output-stream*
33 #:*dedicated-output-stream-port*
34 #:*configure-emacs-indentation*
35 #:*readtable-alist*
36 #:*globally-redirect-io*
37 #:*global-debugger*
38 #:*sldb-printer-bindings*
39 #:*swank-pprint-bindings*
40 #:*default-worker-thread-bindings*
41 #:*macroexpand-printer-bindings*
42 #:*record-repl-results*
43 #:*inspector-dwim-lookup-hooks*
44 #:*debug-on-swank-error*
45 ;; These are re-exported directly from the backend:
46 #:buffer-first-change
47 #:frame-source-location-for-emacs
48 #:restart-frame
49 #:sldb-step
50 #:sldb-break
51 #:sldb-break-on-return
52 #:profiled-functions
53 #:profile-report
54 #:profile-reset
55 #:unprofile-all
56 #:profile-package
57 #:default-directory
58 #:set-default-directory
59 #:quit-lisp))
60
61 (in-package :swank)
62
63
64 ;;;; Top-level variables, constants, macros
65
66 (defconstant cl-package (find-package :cl)
67 "The COMMON-LISP package.")
68
69 (defconstant keyword-package (find-package :keyword)
70 "The KEYWORD package.")
71
72 (defvar *canonical-package-nicknames*
73 `((:common-lisp-user . :cl-user))
74 "Canonical package names to use instead of shortest name/nickname.")
75
76 (defvar *auto-abbreviate-dotted-packages* t
77 "Abbreviate dotted package names to their last component if T.")
78
79 (defvar *swank-io-package*
80 (let ((package (make-package :swank-io-package :use '())))
81 (import '(nil t quote) package)
82 package))
83
84 (defconstant default-server-port 4005
85 "The default TCP port for the server (when started manually).")
86
87 (defvar *swank-debug-p* t
88 "When true, print extra debugging information.")
89
90 (defvar *redirect-io* t
91 "When non-nil redirect Lisp standard I/O to Emacs.
92 Redirection is done while Lisp is processing a request for Emacs.")
93
94 (defvar *sldb-printer-bindings*
95 `((*print-pretty* . t)
96 (*print-level* . 4)
97 (*print-length* . 10)
98 (*print-circle* . t)
99 (*print-readably* . nil)
100 (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
101 (*print-gensym* . t)
102 (*print-base* . 10)
103 (*print-radix* . nil)
104 (*print-array* . t)
105 (*print-lines* . 10)
106 (*print-escape* . t)
107 (*print-right-margin* . 70))
108 "A set of printer variables used in the debugger.")
109
110 (defvar *default-worker-thread-bindings* '()
111 "An alist to initialize dynamic variables in worker threads.
112 The list has the form ((VAR . VALUE) ...). Each variable VAR will be
113 bound to the corresponding VALUE.")
114
115 (defun call-with-bindings (alist fun)
116 "Call FUN with variables bound according to ALIST.
117 ALIST is a list of the form ((VAR . VAL) ...)."
118 (let* ((rlist (reverse alist))
119 (vars (mapcar #'car rlist))
120 (vals (mapcar #'cdr rlist)))
121 (progv vars vals
122 (funcall fun))))
123
124 (defmacro with-bindings (alist &body body)
125 "See `call-with-bindings'."
126 `(call-with-bindings ,alist (lambda () ,@body)))
127
128 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
129 ;;; RPC.
130
131 (defmacro defslimefun (name arglist &body rest)
132 "A DEFUN for functions that Emacs can call by RPC."
133 `(progn
134 (defun ,name ,arglist ,@rest)
135 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
136 (eval-when (:compile-toplevel :load-toplevel :execute)
137 (export ',name :swank))))
138
139 (defun missing-arg ()
140 "A function that the compiler knows will never to return a value.
141 You can use (MISSING-ARG) as the initform for defstruct slots that
142 must always be supplied. This way the :TYPE slot option need not
143 include some arbitrary initial value like NIL."
144 (error "A required &KEY or &OPTIONAL argument was not supplied."))
145
146
147 ;;;; Hooks
148 ;;;
149 ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
150 ;;; simple indirection. The interface is more CLish than the Emacs
151 ;;; Lisp one.
152
153 (defmacro add-hook (place function)
154 "Add FUNCTION to the list of values on PLACE."
155 `(pushnew ,function ,place))
156
157 (defun run-hook (functions &rest arguments)
158 "Call each of FUNCTIONS with ARGUMENTS."
159 (dolist (function functions)
160 (apply function arguments)))
161
162 (defvar *new-connection-hook* '()
163 "This hook is run each time a connection is established.
164 The connection structure is given as the argument.
165 Backend code should treat the connection structure as opaque.")
166
167 (defvar *connection-closed-hook* '()
168 "This hook is run when a connection is closed.
169 The connection as passed as an argument.
170 Backend code should treat the connection structure as opaque.")
171
172 (defvar *pre-reply-hook* '()
173 "Hook run (without arguments) immediately before replying to an RPC.")
174
175 (defvar *after-init-hook* '()
176 "Hook run after user init files are loaded.")
177
178 (defun run-after-init-hook ()
179 (run-hook *after-init-hook*))
180
181
182 ;;;; Connections
183 ;;;
184 ;;; Connection structures represent the network connections between
185 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
186 ;;; streams that redirect to Emacs, and optionally a second socket
187 ;;; used solely to pipe user-output to Emacs (an optimization).
188 ;;;
189
190 (defstruct (connection
191 (:conc-name connection.)
192 (:print-function print-connection))
193 ;; Raw I/O stream of socket connection.
194 (socket-io (missing-arg) :type stream :read-only t)
195 ;; Optional dedicated output socket (backending `user-output' slot).
196 ;; Has a slot so that it can be closed with the connection.
197 (dedicated-output nil :type (or stream null))
198 ;; Streams that can be used for user interaction, with requests
199 ;; redirected to Emacs.
200 (user-input nil :type (or stream null))
201 (user-output nil :type (or stream null))
202 (user-io nil :type (or stream null))
203 ;; A stream where we send REPL results.
204 (repl-results nil :type (or stream null))
205 ;; In multithreaded systems we delegate certain tasks to specific
206 ;; threads. The `reader-thread' is responsible for reading network
207 ;; requests from Emacs and sending them to the `control-thread'; the
208 ;; `control-thread' is responsible for dispatching requests to the
209 ;; threads that should handle them; the `repl-thread' is the one
210 ;; that evaluates REPL expressions. The control thread dispatches
211 ;; all REPL evaluations to the REPL thread and for other requests it
212 ;; spawns new threads.
213 reader-thread
214 control-thread
215 repl-thread
216 ;; Callback functions:
217 ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
218 ;; from Emacs.
219 (serve-requests (missing-arg) :type function)
220 ;; (READ) is called to read and return one message from Emacs.
221 (read (missing-arg) :type function)
222 ;; (SEND OBJECT) is called to send one message to Emacs.
223 (send (missing-arg) :type function)
224 ;; (CLEANUP <this-connection>) is called when the connection is
225 ;; closed.
226 (cleanup nil :type (or null function))
227 ;; Cache of macro-indentation information that has been sent to Emacs.
228 ;; This is used for preparing deltas to update Emacs's knowledge.
229 ;; Maps: symbol -> indentation-specification
230 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
231 ;; The list of packages represented in the cache:
232 (indentation-cache-packages '())
233 ;; The communication style used.
234 (communication-style nil :type (member nil :spawn :sigio :fd-handler))
235 ;; The coding system for network streams.
236 (coding-system ))
237
238 (defun print-connection (conn stream depth)
239 (declare (ignore depth))
240 (print-unreadable-object (conn stream :type t :identity t)))
241
242 (defvar *connections* '()
243 "List of all active connections, with the most recent at the front.")
244
245 (defvar *emacs-connection* nil
246 "The connection to Emacs currently in use.")
247
248 (defvar *swank-state-stack* '()
249 "A list of symbols describing the current state. Used for debugging
250 and to detect situations where interrupts can be ignored.")
251
252 (defun default-connection ()
253 "Return the 'default' Emacs connection.
254 This connection can be used to talk with Emacs when no specific
255 connection is in use, i.e. *EMACS-CONNECTION* is NIL.
256
257 The default connection is defined (quite arbitrarily) as the most
258 recently established one."
259 (first *connections*))
260
261 (defslimefun state-stack ()
262 "Return the value of *SWANK-STATE-STACK*."
263 *swank-state-stack*)
264
265 ;; A conditions to include backtrace information
266 (define-condition swank-error (error)
267 ((condition :initarg :condition :reader swank-error.condition)
268 (backtrace :initarg :backtrace :reader swank-error.backtrace))
269 (:report (lambda (condition stream)
270 (princ (swank-error.condition condition) stream))))
271
272 (defun make-swank-error (condition)
273 (let ((bt (ignore-errors
274 (call-with-debugging-environment
275 (lambda () (backtrace 0 nil))))))
276 (make-condition 'swank-error :condition condition :backtrace bt)))
277
278 (add-hook *new-connection-hook* 'notify-backend-of-connection)
279 (defun notify-backend-of-connection (connection)
280 (declare (ignore connection))
281 (emacs-connected))
282
283
284 ;;;; Helper macros
285
286 (defmacro with-io-redirection ((connection) &body body)
287 "Execute BODY I/O redirection to CONNECTION.
288 If *REDIRECT-IO* is true then all standard I/O streams are redirected."
289 `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
290
291 (defun maybe-call-with-io-redirection (connection fun)
292 (if *redirect-io*
293 (call-with-redirected-io connection fun)
294 (funcall fun)))
295
296 (defmacro with-connection ((connection) &body body)
297 "Execute BODY in the context of CONNECTION."
298 `(call-with-connection ,connection (lambda () ,@body)))
299
300 (defun call-with-connection (connection fun)
301 (let ((*emacs-connection* connection))
302 (with-io-redirection (*emacs-connection*)
303 (call-with-debugger-hook #'swank-debugger-hook fun))))
304
305 (defmacro without-interrupts (&body body)
306 `(call-without-interrupts (lambda () ,@body)))
307
308 (defmacro destructure-case (value &rest patterns)
309 "Dispatch VALUE to one of PATTERNS.
310 A cross between `case' and `destructuring-bind'.
311 The pattern syntax is:
312 ((HEAD . ARGS) . BODY)
313 The list of patterns is searched for a HEAD `eq' to the car of
314 VALUE. If one is found, the BODY is executed with ARGS bound to the
315 corresponding values in the CDR of VALUE."
316 (let ((operator (gensym "op-"))
317 (operands (gensym "rand-"))
318 (tmp (gensym "tmp-")))
319 `(let* ((,tmp ,value)
320 (,operator (car ,tmp))
321 (,operands (cdr ,tmp)))
322 (case ,operator
323 ,@(loop for (pattern . body) in patterns collect
324 (if (eq pattern t)
325 `(t ,@body)
326 (destructuring-bind (op &rest rands) pattern
327 `(,op (destructuring-bind ,rands ,operands
328 ,@body)))))
329 ,@(if (eq (caar (last patterns)) t)
330 '()
331 `((t (error "destructure-case failed: ~S" ,tmp))))))))
332
333 (defmacro with-temp-package (var &body body)
334 "Execute BODY with VAR bound to a temporary package.
335 The package is deleted before returning."
336 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
337 (unwind-protect (progn ,@body)
338 (delete-package ,var))))
339
340 (defvar *log-events* nil)
341 (defvar *log-output* *error-output*)
342 (defvar *event-history* (make-array 40 :initial-element nil)
343 "A ring buffer to record events for better error messages.")
344 (defvar *event-history-index* 0)
345 (defvar *enable-event-history* t)
346
347 (defun log-event (format-string &rest args)
348 "Write a message to *terminal-io* when *log-events* is non-nil.
349 Useful for low level debugging."
350 (with-standard-io-syntax
351 (let ((*print-readably* nil)
352 (*print-pretty* nil)
353 (*package* *swank-io-package*))
354 (when *enable-event-history*
355 (setf (aref *event-history* *event-history-index*)
356 (format nil "~?" format-string args))
357 (setf *event-history-index*
358 (mod (1+ *event-history-index*) (length *event-history*))))
359 (when *log-events*
360 (apply #'format *log-output* format-string args)
361 (force-output *log-output*)))))
362
363 (defun event-history-to-list ()
364 "Return the list of events (older events first)."
365 (let ((arr *event-history*)
366 (idx *event-history-index*))
367 (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
368
369 (defun dump-event-history (stream)
370 (dolist (e (event-history-to-list))
371 (dump-event e stream)))
372
373 (defun dump-event (event stream)
374 (cond ((stringp event)
375 (write-string (escape-non-ascii event) stream))
376 ((null event))
377 (t (format stream "Unexpected event: ~A~%" event))))
378
379 (defun escape-non-ascii (string)
380 "Return a string like STRING but with non-ascii chars escaped."
381 (cond ((ascii-string-p string) string)
382 (t (with-output-to-string (out)
383 (loop for c across string do
384 (cond ((ascii-char-p c) (write-char c out))
385 (t (format out "\\x~4,'0X" (char-code c)))))))))
386
387 (defun ascii-string-p (o)
388 (and (stringp o)
389 (every #'ascii-char-p o)))
390
391 (defun ascii-char-p (c)
392 (<= (char-code c) 127))
393
394 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
395 "Just like do-symbols, but makes sure a symbol is visited only once."
396 (let ((seen-ht (gensym "SEEN-HT")))
397 `(let ((,seen-ht (make-hash-table :test #'eq)))
398 (do-symbols (,var ,package ,result-form)
399 (unless (gethash ,var ,seen-ht)
400 (setf (gethash ,var ,seen-ht) t)
401 ,@body)))))
402
403
404 ;;;; TCP Server
405
406 (defvar *use-dedicated-output-stream* nil
407 "When T swank will attempt to create a second connection to
408 Emacs which is used just to send output.")
409
410 (defvar *dedicated-output-stream-port* 0
411 "Which port we should use for the dedicated output stream.")
412
413 (defvar *communication-style* (preferred-communication-style))
414
415 (defvar *dont-close* nil
416 "Default value of :dont-close argument to start-server and
417 create-server.")
418
419 (defvar *dedicated-output-stream-buffering*
420 (if (eq *communication-style* :spawn) :full :none)
421 "The buffering scheme that should be used for the output stream.
422 Valid values are :none, :line, and :full.")
423
424 (defvar *coding-system* "iso-latin-1-unix")
425
426 (defun start-server (port-file &key (style *communication-style*)
427 (dont-close *dont-close*)
428 (coding-system *coding-system*))
429 "Start the server and write the listen port number to PORT-FILE.
430 This is the entry point for Emacs."
431 (flet ((start-server-aux ()
432 (setup-server 0 (lambda (port)
433 (announce-server-port port-file port))
434 style dont-close
435 (find-external-format-or-lose coding-system))))
436 (if (eq style :spawn)
437 (initialize-multiprocessing #'start-server-aux)
438 (start-server-aux))))
439
440 (defun create-server (&key (port default-server-port)
441 (style *communication-style*)
442 (dont-close *dont-close*)
443 (coding-system *coding-system*))
444 "Start a SWANK server on PORT running in STYLE.
445 If DONT-CLOSE is true then the listen socket will accept multiple
446 connections, otherwise it will be closed after the first."
447 (setup-server port #'simple-announce-function style dont-close
448 (find-external-format-or-lose coding-system)))
449
450 (defun find-external-format-or-lose (coding-system)
451 (or (find-external-format coding-system)
452 (error "Unsupported coding system: ~s" coding-system)))
453
454 (defparameter *loopback-interface* "127.0.0.1")
455
456 (defun setup-server (port announce-fn style dont-close external-format)
457 (declare (type function announce-fn))
458 (let* ((socket (create-socket *loopback-interface* port))
459 (port (local-port socket)))
460 (funcall announce-fn port)
461 (flet ((serve ()
462 (serve-connection socket style dont-close external-format)))
463 (ecase style
464 (:spawn
465 (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
466 :name "Swank"))
467 ((:fd-handler :sigio)
468 (add-fd-handler socket (lambda () (serve))))
469 ((nil) (loop do (serve) while dont-close)))
470 port)))
471
472 (defun serve-connection (socket style dont-close external-format)
473 (let ((closed-socket-p nil))
474 (unwind-protect
475 (let ((client (accept-authenticated-connection
476 socket :external-format external-format)))
477 (unless dont-close
478 (close-socket socket)
479 (setf closed-socket-p t))
480 (let ((connection (create-connection client style)))
481 (run-hook *new-connection-hook* connection)
482 (push connection *connections*)
483 (serve-requests connection)))
484 (unless (or dont-close closed-socket-p)
485 (close-socket socket)))))
486
487 (defun accept-authenticated-connection (&rest args)
488 (let ((new (apply #'accept-connection args))
489 (success nil))
490 (unwind-protect
491 (let ((secret (slime-secret)))
492 (when secret
493 (set-stream-timeout new 20)
494 (let ((first-val (decode-message new)))
495 (unless (and (stringp first-val) (string= first-val secret))
496 (error "Incoming connection doesn't know the password."))))
497 (set-stream-timeout new nil)
498 (setf success t))
499 (unless success
500 (close new :abort t)))
501 new))
502
503 (defun slime-secret ()
504 "Finds the magic secret from the user's home directory. Returns nil
505 if the file doesn't exist; otherwise the first line of the file."
506 (with-open-file (in
507 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
508 :if-does-not-exist nil)
509 (and in (read-line in nil ""))))
510
511 (defun serve-requests (connection)
512 "Read and process all requests on connections."
513 (funcall (connection.serve-requests connection) connection))
514
515 (defun announce-server-port (file port)
516 (with-open-file (s file
517 :direction :output
518 :if-exists :error
519 :if-does-not-exist :create)
520 (format s "~S~%" port))
521 (simple-announce-function port))
522
523 (defun simple-announce-function (port)
524 (when *swank-debug-p*
525 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)
526 (force-output *debug-io*)))
527
528 (defun open-streams (connection)
529 "Return the 5 streams for IO redirection:
530 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
531 (multiple-value-bind (output-fn dedicated-output)
532 (make-output-function connection)
533 (let ((input-fn
534 (lambda ()
535 (with-connection (connection)
536 (with-simple-restart (abort-read
537 "Abort reading input from Emacs.")
538 (read-user-input-from-emacs))))))
539 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
540 (let ((out (or dedicated-output out)))
541 (let ((io (make-two-way-stream in out)))
542 (mapc #'make-stream-interactive (list in out io))
543 (let* ((repl-results-fn
544 (make-output-function-for-target connection :repl-result))
545 (repl-results
546 (nth-value 1 (make-fn-streams
547 (lambda ()
548 (error "Should never be called"))
549 repl-results-fn))))
550 (values dedicated-output in out io repl-results))))))))
551
552 (defun make-output-function (connection)
553 "Create function to send user output to Emacs.
554 This function may open a dedicated socket to send output. It
555 returns two values: the output function, and the dedicated
556 stream (or NIL if none was created)."
557 (if *use-dedicated-output-stream*
558 (let ((stream (open-dedicated-output-stream
559 (connection.socket-io connection))))
560 (values (lambda (string)
561 (write-string string stream)
562 (force-output stream))
563 stream))
564 (values (lambda (string)
565 (with-connection (connection)
566 (with-simple-restart
567 (abort "Abort sending output to Emacs.")
568 (send-to-emacs `(:write-string ,string)))))
569 nil)))
570
571 (defun make-output-function-for-target (connection target)
572 "Create a function to send user output to a specific TARGET in Emacs."
573 (lambda (string)
574 (with-connection (connection)
575 (with-simple-restart
576 (abort "Abort sending output to Emacs.")
577 (send-to-emacs `(:write-string ,string nil ,target))))))
578
579 (defun open-dedicated-output-stream (socket-io)
580 "Open a dedicated output connection to the Emacs on SOCKET-IO.
581 Return an output stream suitable for writing program output.
582
583 This is an optimized way for Lisp to deliver output to Emacs."
584 (let ((socket (create-socket *loopback-interface*
585 *dedicated-output-stream-port*)))
586 (unwind-protect
587 (let ((port (local-port socket)))
588 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
589 (let ((dedicated (accept-authenticated-connection
590 socket
591 :external-format
592 (or (ignore-errors
593 (stream-external-format socket-io))
594 :default)
595 :buffering *dedicated-output-stream-buffering*
596 :timeout 30)))
597 (close-socket socket)
598 (setf socket nil)
599 dedicated))
600 (when socket
601 (close-socket socket)))))
602
603 (defvar *sldb-quit-restart* 'abort
604 "What restart should swank attempt to invoke when the user sldb-quits.")
605
606 (defun handle-request (connection)
607 "Read and process one request. The processing is done in the extent
608 of the toplevel restart."
609 (assert (null *swank-state-stack*))
610 (let ((*swank-state-stack* '(:handle-request)))
611 (with-connection (connection)
612 (with-simple-restart (abort "Return to SLIME's top level.")
613 (let ((*sldb-quit-restart* (find-restart 'abort)))
614 (read-from-emacs))))))
615
616 (defun current-socket-io ()
617 (connection.socket-io *emacs-connection*))
618
619 (defun close-connection (c &optional condition backtrace)
620 (format *debug-io* "~&;; swank:close-connection: ~A~%" condition)
621 (let ((cleanup (connection.cleanup c)))
622 (when cleanup
623 (funcall cleanup c)))
624 (close (connection.socket-io c))
625 (when (connection.dedicated-output c)
626 (close (connection.dedicated-output c)))
627 (setf *connections* (remove c *connections*))
628 (run-hook *connection-closed-hook* c)
629 (when (and condition (not (typep condition 'end-of-file)))
630 (finish-output *debug-io*)
631 (format *debug-io* "~&;; Event history start:~%")
632 (dump-event-history *debug-io*)
633 (format *debug-io* ";; Event history end.~%~
634 ;; Backtrace:~%~{~A~%~}~
635 ;; Connection to Emacs lost. [~%~
636 ;; condition: ~A~%~
637 ;; type: ~S~%~
638 ;; encoding: ~A style: ~S dedicated: ~S]~%"
639 backtrace
640 (escape-non-ascii (safe-condition-message condition) )
641 (type-of condition)
642 (ignore-errors (stream-external-format (connection.socket-io c)))
643 (connection.communication-style c)
644 *use-dedicated-output-stream*)
645 (finish-output *debug-io*)))
646
647 (defvar *debug-on-swank-error* nil
648 "When non-nil internal swank errors will drop to a
649 debugger (not an sldb buffer). Do not set this to T unless you
650 want to debug swank internals.")
651
652 (defmacro with-reader-error-handler ((connection) &body body)
653 (let ((con (gensym))
654 (block (gensym)))
655 `(let ((,con ,connection))
656 (block ,block
657 (handler-bind ((swank-error
658 (lambda (e)
659 (if *debug-on-swank-error*
660 (invoke-debugger e)
661 (return-from ,block
662 (close-connection ,con
663 (swank-error.condition e)
664 (swank-error.backtrace e)))))))
665 (progn ,@body))))))
666
667 (defslimefun simple-break ()
668 (with-simple-restart (continue "Continue from interrupt.")
669 (call-with-debugger-hook
670 #'swank-debugger-hook
671 (lambda ()
672 (invoke-debugger
673 (make-condition 'simple-error
674 :format-control "Interrupt from Emacs")))))
675 nil)
676
677 ;;;;;; Thread based communication
678
679 (defvar *active-threads* '())
680
681 (defun read-loop (control-thread input-stream connection)
682 (with-reader-error-handler (connection)
683 (loop (send control-thread (decode-message input-stream)))))
684
685 (defun dispatch-loop (socket-io connection)
686 (let ((*emacs-connection* connection))
687 (handler-bind ((error (lambda (e)
688 (if *debug-on-swank-error*
689 (invoke-debugger e)
690 (return-from dispatch-loop
691 (close-connection connection e))))))
692 (loop (dispatch-event (receive) socket-io)))))
693
694 (defun repl-thread (connection)
695 (let ((thread (connection.repl-thread connection)))
696 (when (not thread)
697 (log-event "ERROR: repl-thread is nil"))
698 (assert thread)
699 (cond ((thread-alive-p thread)
700 thread)
701 (t
702 (setf (connection.repl-thread connection)
703 (spawn-repl-thread connection "new-repl-thread"))))))
704
705 (defun find-worker-thread (id)
706 (etypecase id
707 ((member t)
708 (car *active-threads*))
709 ((member :repl-thread)
710 (repl-thread *emacs-connection*))
711 (fixnum
712 (find-thread id))))
713
714 (defun interrupt-worker-thread (id)
715 (let ((thread (or (find-worker-thread id)
716 (repl-thread *emacs-connection*))))
717 (interrupt-thread thread #'simple-break)))
718
719 (defun thread-for-evaluation (id)
720 "Find or create a thread to evaluate the next request."
721 (let ((c *emacs-connection*))
722 (etypecase id
723 ((member t)
724 (spawn-worker-thread c))
725 ((member :repl-thread)
726 (repl-thread c))
727 (fixnum
728 (find-thread id)))))
729
730 (defun spawn-worker-thread (connection)
731 (spawn (lambda ()
732 (with-bindings *default-worker-thread-bindings*
733 (handle-request connection)))
734 :name "worker"))
735
736 (defun spawn-repl-thread (connection name)
737 (spawn (lambda ()
738 (with-bindings *default-worker-thread-bindings*
739 (repl-loop connection)))
740 :name name))
741
742 (defun dispatch-event (event socket-io)
743 "Handle an event triggered either by Emacs or within Lisp."
744 (log-event "DISPATCHING: ~S~%" event)
745 (destructure-case event
746 ((:emacs-rex form package thread-id id)
747 (let ((thread (thread-for-evaluation thread-id)))
748 (push thread *active-threads*)
749 (send thread `(eval-for-emacs ,form ,package ,id))))
750 ((:return thread &rest args)
751 (let ((tail (member thread *active-threads*)))
752 (setq *active-threads* (nconc (ldiff *active-threads* tail)
753 (cdr tail))))
754 (encode-message `(:return ,@args) socket-io))
755 ((:emacs-interrupt thread-id)
756 (interrupt-worker-thread thread-id))
757 (((:debug :debug-condition :debug-activate :debug-return)
758 thread &rest args)
759 (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
760 ((:read-string thread &rest args)
761 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
762 ((:y-or-n-p thread &rest args)
763 (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
764 ((:read-aborted thread &rest args)
765 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
766 ((:emacs-return-string thread-id tag string)
767 (send (find-thread thread-id) `(take-input ,tag ,string)))
768 ((:eval thread &rest args)
769 (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
770 ((:emacs-return thread-id tag value)
771 (send (find-thread thread-id) `(take-input ,tag ,value)))
772 (((:write-string :presentation-start :presentation-end
773 :new-package :new-features :ed :%apply :indentation-update
774 :eval-no-wait :background-message :inspect)
775 &rest _)
776 (declare (ignore _))
777 (encode-message event socket-io))))
778
779 (defun spawn-threads-for-connection (connection)
780 (macrolet ((without-debugger-hook (&body body)
781 `(call-with-debugger-hook nil (lambda () ,@body))))
782 (let* ((socket-io (connection.socket-io connection))
783 (control-thread (spawn (lambda ()
784 (without-debugger-hook
785 (dispatch-loop socket-io connection)))
786 :name "control-thread")))
787 (setf (connection.control-thread connection) control-thread)
788 (let ((reader-thread (spawn (lambda ()
789 (let ((go (receive)))
790 (assert (eq go 'accept-input)))
791 (without-debugger-hook
792 (read-loop control-thread socket-io
793 connection)))
794 :name "reader-thread"))
795 (repl-thread (spawn-repl-thread connection "repl-thread")))
796 (setf (connection.repl-thread connection) repl-thread)
797 (setf (connection.reader-thread connection) reader-thread)
798 (send reader-thread 'accept-input)
799 connection))))
800
801 (defun cleanup-connection-threads (connection)
802 (let ((threads (list (connection.repl-thread connection)
803 (connection.reader-thread connection)
804 (connection.control-thread connection))))
805 (dolist (thread threads)
806 (when (and thread
807 (thread-alive-p thread)
808 (not (equal (current-thread) thread)))
809 (kill-thread thread)))))
810
811 (defun repl-loop (connection)
812 (loop (handle-request connection)))
813
814 (defun process-available-input (stream fn)
815 (loop while (input-available-p stream)
816 do (funcall fn)))
817
818 (defun input-available-p (stream)
819 ;; return true iff we can read from STREAM without waiting or if we
820 ;; hit EOF
821 (let ((c (read-char-no-hang stream nil :eof)))
822 (cond ((not c) nil)
823 ((eq c :eof) t)
824 (t
825 (unread-char c stream)
826 t))))
827
828 ;;;;;; Signal driven IO
829
830 (defun install-sigio-handler (connection)
831 (let ((client (connection.socket-io connection)))
832 (flet ((handler ()
833 (cond ((null *swank-state-stack*)
834 (with-reader-error-handler (connection)
835 (process-available-input
836 client (lambda () (handle-request connection)))))
837 ((eq (car *swank-state-stack*) :read-next-form))
838 (t (process-available-input client #'read-from-emacs)))))
839 (add-sigio-handler client #'handler)
840 (handler))))
841
842 (defun deinstall-sigio-handler (connection)
843 (remove-sigio-handlers (connection.socket-io connection)))
844
845 ;;;;;; SERVE-EVENT based IO
846
847 (defun install-fd-handler (connection)
848 (let ((client (connection.socket-io connection)))
849 (flet ((handler ()
850 (cond ((null *swank-state-stack*)
851 (with-reader-error-handler (connection)
852 (process-available-input
853 client (lambda () (handle-request connection)))))
854 ((eq (car *swank-state-stack*) :read-next-form))
855 (t
856 (process-available-input client #'read-from-emacs)))))
857 ;;;; handle sigint
858 ;;(install-debugger-globally
859 ;; (lambda (c h)
860 ;; (with-reader-error-handler (connection)
861 ;; (block debugger
862 ;; (with-connection (connection)
863 ;; (swank-debugger-hook c h)
864 ;; (return-from debugger))
865 ;; (abort)))))
866 (add-fd-handler client #'handler)
867 (handler))))
868
869 (defun deinstall-fd-handler (connection)
870 (remove-fd-handlers (connection.socket-io connection)))
871
872 ;;;;;; Simple sequential IO
873
874 (defun simple-serve-requests (connection)
875 (unwind-protect
876 (with-simple-restart (close-connection "Close SLIME connection")
877 (with-reader-error-handler (connection)
878 (loop
879 (handle-request connection))))
880 (close-connection connection)))
881
882 (defun read-from-socket-io ()
883 (let ((event (decode-message (current-socket-io))))
884 (log-event "DISPATCHING: ~S~%" event)
885 (destructure-case event
886 ((:emacs-rex form package thread id)
887 (declare (ignore thread))
888 `(eval-for-emacs ,form ,package ,id))
889 ((:emacs-interrupt thread)
890 (declare (ignore thread))
891 '(simple-break))
892 ((:emacs-return-string thread tag string)
893 (declare (ignore thread))
894 `(take-input ,tag ,string))
895 ((:emacs-return thread tag value)
896 (declare (ignore thread))
897 `(take-input ,tag ,value)))))
898
899 (defun send-to-socket-io (event)
900 (log-event "DISPATCHING: ~S~%" event)
901 (flet ((send (o)
902 (without-interrupts
903 (encode-message o (current-socket-io)))))
904 (destructure-case event
905 (((:debug-activate :debug :debug-return :read-string :read-aborted
906 :y-or-n-p :eval)
907 thread &rest args)
908 (declare (ignore thread))
909 (send `(,(car event) 0 ,@args)))
910 ((:return thread &rest args)
911 (declare (ignore thread))
912 (send `(:return ,@args)))
913 (((:write-string :new-package :new-features :debug-condition
914 :presentation-start :presentation-end
915 :indentation-update :ed :%apply :eval-no-wait
916 :background-message :inspect)
917 &rest _)
918 (declare (ignore _))
919 (send event)))))
920
921 (defun initialize-streams-for-connection (connection)
922 (multiple-value-bind (dedicated in out io repl-results)
923 (open-streams connection)
924 (setf (connection.dedicated-output connection) dedicated
925 (connection.user-io connection) io
926 (connection.user-output connection) out
927 (connection.user-input connection) in
928 (connection.repl-results connection) repl-results)
929 connection))
930
931 (defun create-connection (socket-io style)
932 (let ((success nil))
933 (unwind-protect
934 (let ((c (ecase style
935 (:spawn
936 (make-connection :socket-io socket-io
937 :read #'read-from-control-thread
938 :send #'send-to-control-thread
939 :serve-requests #'spawn-threads-for-connection
940 :cleanup #'cleanup-connection-threads))
941 (:sigio
942 (make-connection :socket-io socket-io
943 :read #'read-from-socket-io
944 :send #'send-to-socket-io
945 :serve-requests #'install-sigio-handler
946 :cleanup #'deinstall-sigio-handler))
947 (:fd-handler
948 (make-connection :socket-io socket-io
949 :read #'read-from-socket-io
950 :send #'send-to-socket-io
951 :serve-requests #'install-fd-handler
952 :cleanup #'deinstall-fd-handler))
953 ((nil)
954 (make-connection :socket-io socket-io
955 :read #'read-from-socket-io
956 :send #'send-to-socket-io
957 :serve-requests #'simple-serve-requests)))))
958 (setf (connection.communication-style c) style)
959 (initialize-streams-for-connection c)
960 (setf success t)
961 c)
962 (unless success
963 (close socket-io :abort t)))))
964
965
966 ;;;; IO to Emacs
967 ;;;
968 ;;; This code handles redirection of the standard I/O streams
969 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
970 ;;; contains the appropriate streams, so all we have to do is make the
971 ;;; right bindings.
972
973 ;;;;; Global I/O redirection framework
974 ;;;
975 ;;; Optionally, the top-level global bindings of the standard streams
976 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
977 ;;; redirect the streams into the connection, and they keep going into
978 ;;; that connection even if more are established. If the connection
979 ;;; handling the streams closes then another is chosen, or if there
980 ;;; are no connections then we revert to the original (real) streams.
981 ;;;
982 ;;; It is slightly tricky to assign the global values of standard
983 ;;; streams because they are often shadowed by dynamic bindings. We
984 ;;; solve this problem by introducing an extra indirection via synonym
985 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
986 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
987 ;;; variables, so they can always be assigned to affect a global
988 ;;; change.
989
990 (defvar *globally-redirect-io* nil
991 "When non-nil globally redirect all standard streams to Emacs.")
992
993 ;;;;; Global redirection setup
994
995 (defvar *saved-global-streams* '()
996 "A plist to save and restore redirected stream objects.
997 E.g. the value for '*standard-output* holds the stream object
998 for *standard-output* before we install our redirection.")
999
1000 (defun setup-stream-indirection (stream-var &optional stream)
1001 "Setup redirection scaffolding for a global stream variable.
1002 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1003
1004 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1005
1006 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1007 *STANDARD-INPUT*.
1008
1009 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1010 *CURRENT-STANDARD-INPUT*.
1011
1012 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1013 effective global value for *STANDARD-INPUT*. This way we can assign
1014 the effective global value even when *STANDARD-INPUT* is shadowed by a
1015 dynamic binding."
1016 (let ((current-stream-var (prefixed-var '#:current stream-var))
1017 (stream (or stream (symbol-value stream-var))))
1018 ;; Save the real stream value for the future.
1019 (setf (getf *saved-global-streams* stream-var) stream)
1020 ;; Define a new variable for the effective stream.
1021 ;; This can be reassigned.
1022 (proclaim `(special ,current-stream-var))
1023 (set current-stream-var stream)
1024 ;; Assign the real binding as a synonym for the current one.
1025 (set stream-var (make-synonym-stream current-stream-var))))
1026
1027 (defun prefixed-var (prefix variable-symbol)
1028 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1029 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1030 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1031
1032 (defvar *standard-output-streams*
1033 '(*standard-output* *error-output* *trace-output*)
1034 "The symbols naming standard output streams.")
1035
1036 (defvar *standard-input-streams*
1037 '(*standard-input*)
1038 "The symbols naming standard input streams.")
1039
1040 (defvar *standard-io-streams*
1041 '(*debug-io* *query-io* *terminal-io*)
1042 "The symbols naming standard io streams.")
1043
1044 (defun init-global-stream-redirection ()
1045 (when *globally-redirect-io*
1046 (mapc #'setup-stream-indirection
1047 (append *standard-output-streams*
1048 *standard-input-streams*
1049 *standard-io-streams*))))
1050
1051 (add-hook *after-init-hook* 'init-global-stream-redirection)
1052
1053 (defun globally-redirect-io-to-connection (connection)
1054 "Set the standard I/O streams to redirect to CONNECTION.
1055 Assigns *CURRENT-<STREAM>* for all standard streams."
1056 (dolist (o *standard-output-streams*)
1057 (set (prefixed-var '#:current o)
1058 (connection.user-output connection)))
1059 ;; FIXME: If we redirect standard input to Emacs then we get the
1060 ;; regular Lisp top-level trying to read from our REPL.
1061 ;;
1062 ;; Perhaps the ideal would be for the real top-level to run in a
1063 ;; thread with local bindings for all the standard streams. Failing
1064 ;; that we probably would like to inhibit it from reading while
1065 ;; Emacs is connected.
1066 ;;
1067 ;; Meanwhile we just leave *standard-input* alone.
1068 #+NIL
1069 (dolist (i *standard-input-streams*)
1070 (set (prefixed-var '#:current i)
1071 (connection.user-input connection)))
1072 (dolist (io *standard-io-streams*)
1073 (set (prefixed-var '#:current io)
1074 (connection.user-io connection))))
1075
1076 (defun revert-global-io-redirection ()
1077 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1078 (dolist (stream-var (append *standard-output-streams*
1079 *standard-input-streams*
1080 *standard-io-streams*))
1081 (set (prefixed-var '#:current stream-var)
1082 (getf *saved-global-streams* stream-var))))
1083
1084 ;;;;; Global redirection hooks
1085
1086 (defvar *global-stdio-connection* nil
1087 "The connection to which standard I/O streams are globally redirected.
1088 NIL if streams are not globally redirected.")
1089
1090 (defun maybe-redirect-global-io (connection)
1091 "Consider globally redirecting to a newly-established CONNECTION."
1092 (when (and *globally-redirect-io* (null *global-stdio-connection*))
1093 (setq *global-stdio-connection* connection)
1094 (globally-redirect-io-to-connection connection)))
1095
1096 (defun update-redirection-after-close (closed-connection)
1097 "Update redirection after a connection closes."
1098 (when (eq *global-stdio-connection* closed-connection)
1099 (if (and (default-connection) *globally-redirect-io*)
1100 ;; Redirect to another connection.
1101 (globally-redirect-io-to-connection (default-connection))
1102 ;; No more connections, revert to the real streams.
1103 (progn (revert-global-io-redirection)
1104 (setq *global-stdio-connection* nil)))))
1105
1106 (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1107 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1108
1109 ;;;;; Redirection during requests
1110 ;;;
1111 ;;; We always redirect the standard streams to Emacs while evaluating
1112 ;;; an RPC. This is done with simple dynamic bindings.
1113
1114 (defun call-with-redirected-io (connection function)
1115 "Call FUNCTION with I/O streams redirected via CONNECTION."
1116 (declare (type function function))
1117 (let* ((io (connection.user-io connection))
1118 (in (connection.user-input connection))
1119 (out (connection.user-output connection))
1120 (*standard-output* out)
1121 (*error-output* out)
1122 (*trace-output* out)
1123 (*debug-io* io)
1124 (*query-io* io)
1125 (*standard-input* in)
1126 (*terminal-io* io))
1127 (funcall function)))
1128
1129 (defun read-from-emacs ()
1130 "Read and process a request from Emacs."
1131 (apply #'funcall (funcall (connection.read *emacs-connection*))))
1132
1133 (defun read-from-control-thread ()
1134 (receive))
1135
1136 (defun decode-message (stream)
1137 "Read an S-expression from STREAM using the SLIME protocol."
1138 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1139 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1140 (let* ((length (decode-message-length stream))
1141 (string (make-string length))
1142 (pos (read-sequence string stream)))
1143 (assert (= pos length) ()
1144 "Short read: length=~D pos=~D" length pos)
1145 (log-event "READ: ~S~%" string)
1146 (read-form string)))))
1147
1148 (defun decode-message-length (stream)
1149 (let ((buffer (make-string 6)))
1150 (dotimes (i 6)
1151 (setf (aref buffer i) (read-char stream)))
1152 (parse-integer buffer :radix #x10)))
1153
1154 (defun read-form (string)
1155 (with-standard-io-syntax
1156 (let ((*package* *swank-io-package*))
1157 (read-from-string string))))
1158
1159 (defvar *slime-features* nil
1160 "The feature list that has been sent to Emacs.")
1161
1162 (defun send-to-emacs (object)
1163 "Send OBJECT to Emacs."
1164 (funcall (connection.send *emacs-connection*) object))
1165
1166 (defun send-oob-to-emacs (object)
1167 (send-to-emacs object))
1168
1169 (defun send-to-control-thread (object)
1170 (send (connection.control-thread *emacs-connection*) object))
1171
1172 (defun encode-message (message stream)
1173 (let* ((string (prin1-to-string-for-emacs message))
1174 (length (length string)))
1175 (log-event "WRITE: ~A~%" string)
1176 (let ((*print-pretty* nil))
1177 (format stream "~6,'0x" length))
1178 (write-string string stream)
1179 ;;(terpri stream)
1180 (finish-output stream)))
1181
1182 (defun prin1-to-string-for-emacs (object)
1183 (with-standard-io-syntax
1184 (let ((*print-case* :downcase)
1185 (*print-readably* nil)
1186 (*print-pretty* nil)
1187 (*package* *swank-io-package*))
1188 (prin1-to-string object))))
1189
1190 (defun force-user-output ()
1191 (force-output (connection.user-io *emacs-connection*))
1192 (finish-output (connection.user-output *emacs-connection*)))
1193
1194 (defun clear-user-input ()
1195 (clear-input (connection.user-input *emacs-connection*)))
1196
1197 (defvar *read-input-catch-tag* 0)
1198
1199 (defun intern-catch-tag (tag)
1200 ;; fixnums aren't eq in ABCL, so we use intern to create tags
1201 (intern (format nil "~D" tag) :swank))
1202
1203 (defun read-user-input-from-emacs ()
1204 (let ((tag (incf *read-input-catch-tag*)))
1205 (force-output)
1206 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1207 (let ((ok nil))
1208 (unwind-protect
1209 (prog1 (catch (intern-catch-tag tag)
1210 (loop (read-from-emacs)))
1211 (setq ok t))
1212 (unless ok
1213 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1214
1215 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1216 "Like y-or-n-p, but ask in the Emacs minibuffer."
1217 (let ((tag (incf *read-input-catch-tag*))
1218 (question (apply #'format nil format-string arguments)))
1219 (force-output)
1220 (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1221 (catch (intern-catch-tag tag)
1222 (loop (read-from-emacs)))))
1223
1224 (defslimefun take-input (tag input)
1225 "Return the string INPUT to the continuation TAG."
1226 (throw (intern-catch-tag tag) input))
1227
1228 (defun process-form-for-emacs (form)
1229 "Returns a string which emacs will read as equivalent to
1230 FORM. FORM can contain lists, strings, characters, symbols and
1231 numbers.
1232
1233 Characters are converted emacs' ?<char> notaion, strings are left
1234 as they are (except for espacing any nested \" chars, numbers are
1235 printed in base 10 and symbols are printed as their symbol-name
1236 converted to lower case."
1237 (etypecase form
1238 (string (format nil "~S" form))
1239 (cons (format nil "(~A . ~A)"
1240 (process-form-for-emacs (car form))
1241 (process-form-for-emacs (cdr form))))
1242 (character (format nil "?~C" form))
1243 (symbol (concatenate 'string (when (eq (symbol-package form)
1244 #.(find-package "KEYWORD"))
1245 ":")
1246 (string-downcase (symbol-name form))))
1247 (number (let ((*print-base* 10))
1248 (princ-to-string form)))))
1249
1250 (defun eval-in-emacs (form &optional nowait)
1251 "Eval FORM in Emacs."
1252 (cond (nowait
1253 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1254 (t
1255 (force-output)
1256 (let* ((tag (incf *read-input-catch-tag*))
1257 (value (catch (intern-catch-tag tag)
1258 (send-to-emacs
1259 `(:eval ,(current-thread) ,tag
1260 ,(process-form-for-emacs form)))
1261 (loop (read-from-emacs)))))
1262 (destructure-case value
1263 ((:ok value) value)
1264 ((:abort) (abort)))))))
1265
1266 (defun present-in-emacs (value-or-values &key (separated-by " "))
1267 "Present VALUE in the Emacs repl buffer of the current thread."
1268 (unless (consp value-or-values)
1269 (setf value-or-values (list value-or-values)))
1270 (flet ((present (value)
1271 (if (stringp value)
1272 (send-to-emacs `(:write-string ,value))
1273 (let ((id (save-presented-object value)))
1274 (send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
1275 (map nil (let ((first-time-p t))
1276 (lambda (value)
1277 (when (and (not first-time-p)
1278 separated-by)
1279 (present separated-by))
1280 (present value)
1281 (setf first-time-p nil)))
1282 value-or-values))
1283 (values))
1284
1285 (defvar *swank-wire-protocol-version* nil
1286 "The version of the swank/slime communication protocol.")
1287
1288 (defslimefun connection-info ()
1289 "Return a key-value list of the form:
1290 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1291 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1292 STYLE: the communication style
1293 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1294 FEATURES: a list of keywords
1295 PACKAGE: a list (&key NAME PROMPT)
1296 VERSION: the protocol version"
1297 (setq *slime-features* *features*)
1298 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1299 :lisp-implementation (:type ,(lisp-implementation-type)
1300 :name ,(lisp-implementation-type-name)
1301 :version ,(lisp-implementation-version))
1302 :machine (:instance ,(machine-instance)
1303 :type ,(machine-type)
1304 :version ,(machine-version))
1305 :features ,(features-for-emacs)
1306 :package (:name ,(package-name *package*)
1307 :prompt ,(package-string-for-prompt *package*))
1308 :version ,*swank-wire-protocol-version*))
1309
1310 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1311 (let* ((s *standard-output*)
1312 (*trace-output* (make-broadcast-stream s *log-output*)))
1313 (time (progn
1314 (dotimes (i n)
1315 (format s "~D abcdefghijklm~%" i)
1316 (when (zerop (mod n m))
1317 (force-output s)))
1318 (finish-output s)
1319 (when *emacs-connection*
1320 (eval-in-emacs '(message "done.")))))
1321 (terpri *trace-output*)
1322 (finish-output *trace-output*)
1323 nil))
1324
1325
1326 ;;;; Reading and printing
1327
1328 (defmacro define-special (name doc)
1329 "Define a special variable NAME with doc string DOC.
1330 This is like defvar, but NAME will not be initialized."
1331 `(progn
1332 (defvar ,name)
1333 (setf (documentation ',name 'variable) ,doc)))
1334
1335 (define-special *buffer-package*
1336 "Package corresponding to slime-buffer-package.
1337
1338 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1339 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1340
1341 (define-special *buffer-readtable*
1342 "Readtable associated with the current buffer")
1343
1344 (defmacro with-buffer-syntax ((&rest _) &body body)
1345 "Execute BODY with appropriate *package* and *readtable* bindings.
1346
1347 This should be used for code that is conceptionally executed in an
1348 Emacs buffer."
1349 (destructuring-bind () _
1350 `(call-with-buffer-syntax (lambda () ,@body))))
1351
1352 (defun call-with-buffer-syntax (fun)
1353 (let ((*package* *buffer-package*))
1354 ;; Don't shadow *readtable* unnecessarily because that prevents
1355 ;; the user from assigning to it.
1356 (if (eq *readtable* *buffer-readtable*)
1357 (call-with-syntax-hooks fun)
1358 (let ((*readtable* *buffer-readtable*))
1359 (call-with-syntax-hooks fun)))))
1360
1361 (defun to-string (object)
1362 "Write OBJECT in the *BUFFER-PACKAGE*.
1363 The result may not be readable. Handles problems with PRINT-OBJECT methods
1364 gracefully."
1365 (with-buffer-syntax ()
1366 (let ((*print-readably* nil))
1367 (handler-case
1368 (prin1-to-string object)
1369 (error ()
1370 (with-output-to-string (s)
1371 (print-unreadable-object (object s :type t :identity t)
1372 (princ "<<error printing object>>" s))))))))
1373
1374 (defun from-string (string)
1375 "Read string in the *BUFFER-PACKAGE*"
1376 (with-buffer-syntax ()
1377 (let ((*read-suppress* nil))
1378 (read-from-string string))))
1379
1380 ;; FIXME: deal with #\| etc. hard to do portably.
1381 (defun tokenize-symbol (string)
1382 "STRING is interpreted as the string representation of a symbol
1383 and is tokenized accordingly. The result is returned in three
1384 values: The package identifier part, the actual symbol identifier
1385 part, and a flag if the STRING represents a symbol that is
1386 internal to the package identifier part. (Notice that the flag is
1387 also true with an empty package identifier part, as the STRING is
1388 considered to represent a symbol internal to some current package.)"
1389 (let ((package (let ((pos (position #\: string)))
1390 (if pos (subseq string 0 pos) nil)))
1391 (symbol (let ((pos (position #\: string :from-end t)))
1392 (if pos (subseq string (1+ pos)) string)))
1393 (internp (not (= (count #\: string) 1))))
1394 (values symbol package internp)))
1395
1396 (defun tokenize-symbol-thoroughly (string)
1397 "This version of TOKENIZE-SYMBOL handles escape characters."
1398 (let ((package nil)
1399 (token (make-array (length string) :element-type 'character
1400 :fill-pointer 0))
1401 (backslash nil)
1402 (vertical nil)
1403 (internp nil))
1404 (loop for char across string
1405 do (cond
1406 (backslash
1407 (vector-push-extend char token)
1408 (setq backslash nil))
1409 ((char= char #\\) ; Quotes next character, even within |...|
1410 (setq backslash t))
1411 ((char= char #\|)
1412 (setq vertical t))
1413 (vertical
1414 (vector-push-extend char token))
1415 ((char= char #\:)
1416 (if package
1417 (setq internp t)
1418 (setq package token
1419 token (make-array (length string)
1420 :element-type 'character
1421 :fill-pointer 0))))
1422 (t
1423 (vector-push-extend (casify-char char) token))))
1424 (values token package (or (not package) internp))))
1425
1426 (defun untokenize-symbol (package-name internal-p symbol-name)
1427 "The inverse of TOKENIZE-SYMBOL.
1428
1429 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1430 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1431 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1432 "
1433 (let ((prefix (cond ((not package-name) "")
1434 (internal-p (format nil "~A::" package-name))
1435 (t (format nil "~A:" package-name)))))
1436 (concatenate 'string prefix symbol-name)))
1437
1438 (defun casify-char (char)
1439 "Convert CHAR accoring to readtable-case."
1440 (ecase (readtable-case *readtable*)
1441 (:preserve char)
1442 (:upcase (char-upcase char))
1443 (:downcase (char-downcase char))
1444 (:invert (if (upper-case-p char)
1445 (char-downcase char)
1446 (char-upcase char)))))
1447
1448 (defun parse-symbol (string &optional (package *package*))
1449 "Find the symbol named STRING.
1450 Return the symbol and a flag indicating whether the symbols was found."
1451 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1452 (let ((package (cond ((string= pname "") keyword-package)
1453 (pname (find-package pname))
1454 (t package))))
1455 (if package
1456 (find-symbol sname package)
1457 (values nil nil)))))
1458
1459 (defun parse-symbol-or-lose (string &optional (package *package*))
1460 (multiple-value-bind (symbol status) (parse-symbol string package)
1461 (if status
1462 (values symbol status)
1463 (error "Unknown symbol: ~A [in ~A]" string package))))
1464
1465 ;; FIXME: interns the name
1466 (defun parse-package (string)
1467 "Find the package named STRING.
1468 Return the package or nil."
1469 (multiple-value-bind (name pos)
1470 (if (zerop (length string))
1471 (values :|| 0)
1472 (let ((*package* *swank-io-package*))
1473 (ignore-errors (read-from-string string))))
1474 (and name
1475 (or (symbolp name)
1476 (stringp name))
1477 (= (length string) pos)
1478 (find-package name))))
1479
1480 (defun unparse-name (string)
1481 "Print the name STRING according to the current printer settings."
1482 ;; this is intended for package or symbol names
1483 (subseq (prin1-to-string (make-symbol string)) 2))
1484
1485 (defun guess-package (string)
1486 "Guess which package corresponds to STRING.
1487 Return nil if no package matches."
1488 (or (find-package string)
1489 (parse-package string)
1490 (if (find #\! string) ; for SBCL
1491 (guess-package (substitute #\- #\! string)))))
1492
1493 (defvar *readtable-alist* (default-readtable-alist)
1494 "An alist mapping package names to readtables.")
1495
1496 (defun guess-buffer-readtable (package-name)
1497 (let ((package (guess-package package-name)))
1498 (or (and package
1499 (cdr (assoc (package-name package) *readtable-alist*
1500 :test #'string=)))
1501 *readtable*)))
1502
1503 (defun valid-operator-symbol-p (symbol)
1504 "Is SYMBOL the name of a function, a macro, or a special-operator?"
1505 (or (fboundp symbol)
1506 (macro-function symbol)
1507 (special-operator-p symbol)))
1508
1509 (defun valid-operator-name-p (string)
1510 "Is STRING the name of a function, macro, or special-operator?"
1511 (let ((symbol (parse-symbol string)))
1512 (valid-operator-symbol-p symbol)))
1513
1514
1515 ;;;; Arglists
1516
1517 (defun find-valid-operator-name (names)
1518 "As a secondary result, returns its index."
1519 (let ((index
1520 (position-if (lambda (name)
1521 (or (consp name)
1522 (valid-operator-name-p name)))
1523 names)))
1524 (if index
1525 (values (elt names index) index)
1526 (values nil nil))))
1527
1528 (defslimefun arglist-for-echo-area (names &key print-right-margin
1529 print-lines arg-indices)
1530 "Return the arglist for the first function, macro, or special-op in NAMES."
1531 (handler-case
1532 (with-buffer-syntax ()
1533 (multiple-value-bind (name which)
1534 (find-valid-operator-name names)
1535 (when which
1536 (let ((arg-index (and arg-indices (elt arg-indices which))))
1537 (multiple-value-bind (form operator-name)
1538 (operator-designator-to-form name)
1539 (let ((*print-right-margin* print-right-margin))
1540 (format-arglist-for-echo-area
1541 form operator-name
1542 :print-right-margin print-right-margin
1543 :print-lines print-lines
1544 :highlight (and arg-index
1545 (not (zerop arg-index))
1546 ;; don't highlight the operator
1547 arg-index))))))))
1548 (error (cond)
1549 (format nil "ARGLIST: ~A" cond))))
1550
1551 (defun operator-designator-to-form (name)
1552 (etypecase name
1553 (cons
1554 (destructure-case name
1555 ((:make-instance class-name operator-name &rest args)
1556 (let ((parsed-operator-name (parse-symbol operator-name)))
1557 (values `(,parsed-operator-name ,@args ',(parse-symbol class-name))
1558 operator-name)))
1559 ((:defmethod generic-name)
1560 (values `(defmethod ,(parse-symbol generic-name))
1561 'defmethod))))
1562 (string
1563 (values `(,(parse-symbol name))
1564 name))))
1565
1566 (defun clean-arglist (arglist)
1567 "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1568 (cond ((null arglist) '())
1569 ((member (car arglist) '(&whole &environment))
1570 (clean-arglist (cddr arglist)))
1571 ((eq (car arglist) '&aux)
1572 '())
1573 (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1574
1575 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1576 provided-args ; list of the provided actual arguments
1577 required-args ; list of the required arguments
1578 optional-args ; list of the optional arguments
1579 key-p ; whether &key appeared
1580 keyword-args ; list of the keywords
1581 rest ; name of the &rest or &body argument (if any)
1582 body-p ; whether the rest argument is a &body
1583 allow-other-keys-p ; whether &allow-other-keys appeared
1584 aux-args ; list of &aux variables
1585 known-junk ; &whole, &environment
1586 unknown-junk) ; unparsed stuff
1587
1588 (defun print-arglist (arglist &key operator highlight)
1589 (let ((index 0)
1590 (need-space nil))
1591 (labels ((print-arg (arg)
1592 (typecase arg
1593 (arglist ; destructuring pattern
1594 (print-arglist arg))
1595 (optional-arg
1596 (princ (encode-optional-arg arg)))
1597 (keyword-arg
1598 (let ((enc-arg (encode-keyword-arg arg)))
1599 (etypecase enc-arg
1600 (symbol (princ enc-arg))
1601 ((cons symbol)
1602 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1603 (princ (car enc-arg))
1604 (write-char #\space)
1605 (pprint-fill *standard-output* (cdr enc-arg) nil)))
1606 ((cons cons)
1607 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1608 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1609 (prin1 (caar enc-arg))
1610 (write-char #\space)
1611 (print-arg (keyword-arg.arg-name arg)))
1612 (unless (null (cdr enc-arg))
1613 (write-char #\space))
1614 (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1615 (t ; required formal or provided actual arg
1616 (princ arg))))
1617 (print-space ()
1618 (ecase need-space
1619 ((nil))
1620 ((:miser)
1621 (write-char #\space)
1622 (pprint-newline :miser))
1623 ((t)
1624 (write-char #\space)
1625 (pprint-newline :fill)))
1626 (setq need-space t))
1627 (print-with-space (obj)
1628 (print-space)
1629 (print-arg obj))
1630 (print-with-highlight (arg &optional (index-ok-p #'=))
1631 (print-space)
1632 (cond
1633 ((and highlight (funcall index-ok-p index highlight))
1634 (princ "===> ")
1635 (print-arg arg)
1636 (princ " <==="))
1637 (t
1638 (print-arg arg)))
1639 (incf index)))
1640 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1641 (when operator
1642 (print-with-highlight operator)
1643 (setq need-space :miser))
1644 (mapc #'print-with-highlight
1645 (arglist.provided-args arglist))
1646 (mapc #'print-with-highlight
1647 (arglist.required-args arglist))
1648 (when (arglist.optional-args arglist)
1649 (print-with-space '&optional)
1650 (mapc #'print-with-highlight
1651 (arglist.optional-args arglist)))
1652 (when (arglist.key-p arglist)
1653 (print-with-space '&key)
1654 (mapc #'print-with-space
1655 (arglist.keyword-args arglist)))
1656 (when (arglist.allow-other-keys-p arglist)
1657 (print-with-space '&allow-other-keys))
1658 (cond ((not (arglist.rest arglist)))
1659 ((arglist.body-p arglist)
1660 (print-with-space '&body)
1661 (print-with-highlight (arglist.rest arglist) #'<=))
1662 (t
1663 (print-with-space '&rest)
1664 (print-with-highlight (arglist.rest arglist) #'<=)))
1665 (mapc #'print-with-space
1666 (arglist.unknown-junk arglist))))))
1667
1668 (defun decoded-arglist-to-string (arglist package
1669 &key operator print-right-margin
1670 print-lines highlight)
1671 "Print the decoded ARGLIST for display in the echo area. The
1672 argument name are printed without package qualifiers and pretty
1673 printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
1674 non-nil, it must be the index of an argument; highlight this argument.
1675 If OPERATOR is non-nil, put it in front of the arglist."
1676 (with-output-to-string (*standard-output*)
1677 (with-standard-io-syntax
1678 (let ((*package* package) (*print-case* :downcase)
1679 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1680 (*print-level* 10) (*print-length* 20)
1681 (*print-right-margin* print-right-margin)
1682 (*print-lines* print-lines))
1683 (print-arglist arglist :operator operator :highlight highlight)))))
1684
1685 (defslimefun variable-desc-for-echo-area (variable-name)
1686 "Return a short description of VARIABLE-NAME, or NIL."
1687 (with-buffer-syntax ()
1688 (let ((sym (parse-symbol variable-name)))
1689 (if (and sym (boundp sym))
1690 (let ((*print-pretty* nil) (*print-level* 4)
1691 (*print-length* 10) (*print-circle* t))
1692 (format nil "~A => ~A" sym (symbol-value sym)))))))
1693
1694 (defun decode-required-arg (arg)
1695 "ARG can be a symbol or a destructuring pattern."
1696 (etypecase arg
1697 (symbol arg)
1698 (list (decode-arglist arg))))
1699
1700 (defun encode-required-arg (arg)
1701 (etypecase arg
1702 (symbol arg)
1703 (arglist (encode-arglist arg))))
1704
1705 (defstruct (keyword-arg
1706 (:conc-name keyword-arg.)
1707 (:constructor make-keyword-arg (keyword arg-name default-arg)))
1708 keyword
1709 arg-name
1710 default-arg)
1711
1712 (defun decode-keyword-arg (arg)
1713 "Decode a keyword item of formal argument list.
1714 Return three values: keyword, argument name, default arg."
1715 (cond ((symbolp arg)
1716 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1717 arg
1718 nil))
1719 ((and (consp arg)
1720 (consp (car arg)))
1721 (make-keyword-arg (caar arg)
1722 (decode-required-arg (cadar arg))
1723 (cadr arg)))
1724 ((consp arg)
1725 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1726 (car arg)
1727 (cadr arg)))
1728 (t
1729 (abort-request "Bad keyword item of formal argument list"))))
1730
1731 (defun encode-keyword-arg (arg)
1732 (cond
1733 ((arglist-p (keyword-arg.arg-name arg))
1734 ;; Destructuring pattern
1735 (let ((keyword/name (list (keyword-arg.keyword arg)
1736 (encode-required-arg
1737 (keyword-arg.arg-name arg)))))
1738 (if (keyword-arg.default-arg arg)
1739 (list keyword/name
1740 (keyword-arg.default-arg arg))
1741 (list keyword/name))))
1742 ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1743 keyword-package)
1744 (keyword-arg.keyword arg))
1745 (if (keyword-arg.default-arg arg)
1746 (list (keyword-arg.arg-name arg)
1747 (keyword-arg.default-arg arg))
1748 (keyword-arg.arg-name arg)))
1749 (t
1750 (let ((keyword/name (list (keyword-arg.keyword arg)
1751 (keyword-arg.arg-name arg))))
1752 (if (keyword-arg.default-arg arg)
1753 (list keyword/name
1754 (keyword-arg.default-arg arg))
1755 (list keyword/name))))))
1756
1757 (progn
1758 (assert (equalp (decode-keyword-arg 'x)
1759 (make-keyword-arg :x 'x nil)))
1760 (assert (equalp (decode-keyword-arg '(x t))
1761 (make-keyword-arg :x 'x t)))
1762 (assert (equalp (decode-keyword-arg '((:x y)))
1763 (make-keyword-arg :x 'y nil)))
1764 (assert (equalp (decode-keyword-arg '((:x y) t))
1765 (make-keyword-arg :x 'y t))))
1766
1767 (defstruct (optional-arg
1768 (:conc-name optional-arg.)
1769 (:constructor make-optional-arg (arg-name default-arg)))
1770 arg-name
1771 default-arg)
1772
1773 (defun decode-optional-arg (arg)
1774 "Decode an optional item of a formal argument list.
1775 Return an OPTIONAL-ARG structure."
1776 (etypecase arg
1777 (symbol (make-optional-arg arg nil))
1778 (list (make-optional-arg (decode-required-arg (car arg))
1779 (cadr arg)))))
1780
1781 (defun encode-optional-arg (optional-arg)
1782 (if (or (optional-arg.default-arg optional-arg)
1783 (arglist-p (optional-arg.arg-name optional-arg)))
1784 (list (encode-required-arg
1785 (optional-arg.arg-name optional-arg))
1786 (optional-arg.default-arg optional-arg))
1787 (optional-arg.arg-name optional-arg)))
1788
1789 (progn
1790 (assert (equalp (decode-optional-arg 'x)
1791 (make-optional-arg 'x nil)))
1792 (assert (equalp (decode-optional-arg '(x t))
1793 (make-optional-arg 'x t))))
1794
1795 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1796
1797 (defun decode-arglist (arglist)
1798 "Parse the list ARGLIST and return an ARGLIST structure."
1799 (let ((mode nil)
1800 (result (make-arglist)))
1801 (dolist (arg arglist)
1802 (cond
1803 ((eql mode '&unknown-junk)
1804 ;; don't leave this mode -- we don't know how the arglist
1805 ;; after unknown lambda-list keywords is interpreted
1806 (push arg (arglist.unknown-junk result)))
1807 ((eql arg '&allow-other-keys)
1808 (setf (arglist.allow-other-keys-p result) t))
1809 ((eql arg '&key)
1810 (setf (arglist.key-p result) t
1811 mode arg))
1812 ((member arg '(&optional &rest &body &aux))
1813 (setq mode arg))
1814 ((member arg '(&whole &environment))
1815 (setq mode arg)
1816 (push arg (arglist.known-junk result)))
1817 ((member arg lambda-list-keywords)
1818 (setq mode '&unknown-junk)
1819 (push arg (arglist.unknown-junk result)))
1820 (t
1821 (ecase mode
1822 (&key
1823 (push (decode-keyword-arg arg)
1824 (arglist.keyword-args result)))
1825 (&optional
1826 (push (decode-optional-arg arg)
1827 (arglist.optional-args result)))
1828 (&body
1829 (setf (arglist.body-p result) t
1830 (arglist.rest result) arg))
1831 (&rest
1832 (setf (arglist.rest result) arg))
1833 (&aux
1834 (push (decode-optional-arg arg)
1835 (arglist.aux-args result)))
1836 ((nil)
1837 (push (decode-required-arg arg)
1838 (arglist.required-args result)))
1839 ((&whole &environment)
1840 (setf mode nil)
1841 (push arg (arglist.known-junk result)))))))
1842 (nreversef (arglist.required-args result))
1843 (nreversef (arglist.optional-args result))
1844 (nreversef (arglist.keyword-args result))
1845 (nreversef (arglist.aux-args result))
1846 (nreversef (arglist.known-junk result))
1847 (nreversef (arglist.unknown-junk result))
1848 result))
1849
1850 (defun encode-arglist (decoded-arglist)
1851 (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
1852 (when (arglist.optional-args decoded-arglist)
1853 '(&optional))
1854 (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1855 (when (arglist.key-p decoded-arglist)
1856 '(&key))
1857 (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1858 (when (arglist.allow-other-keys-p decoded-arglist)
1859 '(&allow-other-keys))
1860 (cond ((not (arglist.rest decoded-arglist))
1861 '())
1862 ((arglist.body-p decoded-arglist)
1863 `(&body ,(arglist.rest decoded-arglist)))
1864 (t
1865 `(&rest ,(arglist.rest decoded-arglist))))
1866 (when (arglist.aux-args decoded-arglist)
1867 `(&aux ,(arglist.aux-args decoded-arglist)))
1868 (arglist.known-junk decoded-arglist)
1869 (arglist.unknown-junk decoded-arglist)))
1870
1871 (defun arglist-keywords (arglist)
1872 "Return the list of keywords in ARGLIST.
1873 As a secondary value, return whether &allow-other-keys appears."
1874 (let ((decoded-arglist (decode-arglist arglist)))
1875 (values (arglist.keyword-args decoded-arglist)
1876 (arglist.allow-other-keys-p decoded-arglist))))
1877
1878 (defun methods-keywords (methods)
1879 "Collect all keywords in the arglists of METHODS.
1880 As a secondary value, return whether &allow-other-keys appears somewhere."
1881 (let ((keywords '())
1882 (allow-other-keys nil))
1883 (dolist (method methods)
1884 (multiple-value-bind (kw aok)
1885 (arglist-keywords
1886 (swank-mop:method-lambda-list method))
1887 (setq keywords (remove-duplicates (append keywords kw)
1888 :key #'keyword-arg.keyword)
1889 allow-other-keys (or allow-other-keys aok))))
1890 (values keywords allow-other-keys)))
1891
1892 (defun generic-function-keywords (generic-function)
1893 "Collect all keywords in the methods of GENERIC-FUNCTION.
1894 As a secondary value, return whether &allow-other-keys appears somewhere."
1895 (methods-keywords
1896 (swank-mop:generic-function-methods generic-function)))
1897
1898 (defun applicable-methods-keywords (generic-function arguments)
1899 "Collect all keywords in the methods of GENERIC-FUNCTION that are
1900 applicable for argument of CLASSES. As a secondary value, return
1901 whether &allow-other-keys appears somewhere."
1902 (methods-keywords
1903 (multiple-value-bind (amuc okp)
1904 (swank-mop:compute-applicable-methods-using-classes
1905 generic-function (mapcar #'class-of arguments))
1906 (if okp
1907 amuc
1908 (compute-applicable-methods generic-function arguments)))))
1909
1910 (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1911 (with-output-to-string (*standard-output*)
1912 (with-standard-io-syntax
1913 (let ((*package* package) (*print-case* :downcase)
1914 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1915 (*print-level* 10) (*print-length* 20))
1916 (print-decoded-arglist-as-template decoded-arglist
1917 :prefix prefix
1918 :suffix suffix)))))
1919
1920 (defun print-decoded-arglist-as-template (decoded-arglist &key
1921 (prefix "(") (suffix ")"))
1922 (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1923 (let ((first-p t))
1924 (flet ((space ()
1925 (unless first-p
1926 (write-char #\space)
1927 (pprint-newline :fill))
1928 (setq first-p nil))
1929 (print-arg-or-pattern (arg)
1930 (etypecase arg
1931 (symbol (princ arg))
1932 (string (princ arg))
1933 (list (princ arg))
1934 (arglist (print-decoded-arglist-as-template arg)))))
1935 (dolist (arg (arglist.required-args decoded-arglist))
1936 (space)
1937 (print-arg-or-pattern arg))
1938 (dolist (arg (arglist.optional-args decoded-arglist))
1939 (space)
1940 (princ "[")
1941 (print-arg-or-pattern (optional-arg.arg-name arg))
1942 (princ "]"))
1943 (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1944 (space)
1945 (let ((arg-name (keyword-arg.arg-name keyword-arg))
1946 (keyword (keyword-arg.keyword keyword-arg)))
1947 (format t "~W "
1948 (if (keywordp keyword) keyword `',keyword))
1949 (print-arg-or-pattern arg-name)))
1950 (when (and (arglist.rest decoded-arglist)
1951 (or (not (arglist.keyword-args decoded-arglist))
1952 (arglist.allow-other-keys-p decoded-arglist)))
1953 (if (arglist.body-p decoded-arglist)
1954 (pprint-newline :mandatory)
1955 (space))
1956 (format t "~A..." (arglist.rest decoded-arglist)))))
1957 (pprint-newline :fill)))
1958
1959 (defgeneric extra-keywords (operator &rest args)
1960 (:documentation "Return a list of extra keywords of OPERATOR (a
1961 symbol) when applied to the (unevaluated) ARGS.
1962 As a secondary value, return whether other keys are allowed.
1963 As a tertiary value, return the initial sublist of ARGS that was needed
1964 to determine the extra keywords."))
1965
1966 (defmethod extra-keywords (operator &rest args)
1967 ;; default method
1968 (declare (ignore args))
1969 (let ((symbol-function (symbol-function operator)))
1970 (if (typep symbol-function 'generic-function)
1971 (generic-function-keywords symbol-function)
1972 nil)))
1973
1974 (defun class-from-class-name-form (class-name-form)
1975 (when (and (listp class-name-form)
1976 (= (length class-name-form) 2)
1977 (eq (car class-name-form) 'quote))
1978 (let* ((class-name (cadr class-name-form))
1979 (class (find-class class-name nil)))
1980 (when (and class
1981 (not (swank-mop:class-finalized-p class)))
1982 ;; Try to finalize the class, which can fail if
1983 ;; superclasses are not defined yet
1984 (handler-case (swank-mop:finalize-inheritance class)
1985 (program-error (c)
1986 (declare (ignore c)))))
1987 class)))
1988
1989 (defun extra-keywords/slots (class)
1990 (multiple-value-bind (slots allow-other-keys-p)
1991 (if (swank-mop:class-finalized-p class)
1992 (values (swank-mop:class-slots class) nil)
1993 (values (swank-mop:class-direct-slots class) t))
1994 (let ((slot-init-keywords
1995 (loop for slot in slots append
1996 (mapcar (lambda (initarg)
1997 (make-keyword-arg
1998 initarg
1999 (swank-mop:slot-definition-name slot)
2000 (swank-mop:slot-definition-initform slot)))
2001 (swank-mop:slot-definition-initargs slot)))))
2002 (values slot-init-keywords allow-other-keys-p))))
2003
2004 (defun extra-keywords/make-instance (operator &rest args)
2005 (declare (ignore operator))
2006 (unless (null args)
2007 (let* ((class-name-form (car args))
2008 (class (class-from-class-name-form class-name-form)))
2009 (when class
2010 (multiple-value-bind (slot-init-keywords class-aokp)
2011 (extra-keywords/slots class)
2012 (multiple-value-bind (allocate-instance-keywords ai-aokp)
2013 (applicable-methods-keywords
2014 #'allocate-instance (list class))
2015 (multiple-value-bind (initialize-instance-keywords ii-aokp)
2016 (applicable-methods-keywords
2017 #'initialize-instance (list (swank-mop:class-prototype class)))
2018 (multiple-value-bind (shared-initialize-keywords si-aokp)
2019 (applicable-methods-keywords
2020 #'shared-initialize (list (swank-mop:class-prototype class) t))
2021 (values (append slot-init-keywords
2022 allocate-instance-keywords
2023 initialize-instance-keywords
2024 shared-initialize-keywords)
2025 (or class-aokp ai-aokp ii-aokp si-aokp)
2026 (list class-name-form))))))))))
2027
2028 (defun extra-keywords/change-class (operator &rest args)
2029 (declare (ignore operator))
2030 (unless (null args)
2031 (let* ((class-name-form (car args))
2032 (class (class-from-class-name-form class-name-form)))
2033 (when class
2034 (multiple-value-bind (slot-init-keywords class-aokp)
2035 (extra-keywords/slots class)
2036 (declare (ignore class-aokp))
2037 (multiple-value-bind (shared-initialize-keywords si-aokp)
2038 (applicable-methods-keywords
2039 #'shared-initialize (list (swank-mop:class-prototype class) t))
2040 ;; FIXME: much as it would be nice to include the
2041 ;; applicable keywords from
2042 ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
2043 ;; how to do it: so we punt, always declaring
2044 ;; &ALLOW-OTHER-KEYS.
2045 (declare (ignore si-aokp))
2046 (values (append slot-init-keywords shared-initialize-keywords)
2047 t
2048 (list class-name-form))))))))
2049
2050 (defmacro multiple-value-or (&rest forms)
2051 (if (null forms)
2052 nil
2053 (let ((first (first forms))
2054 (rest (rest forms)))
2055 `(let* ((values (multiple-value-list ,first))
2056 (primary-value (first values)))
2057 (if primary-value
2058 (values-list values)
2059 (multiple-value-or ,@rest))))))
2060
2061 (defmethod extra-keywords ((operator (eql 'make-instance))
2062 &rest args)
2063 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2064 (call-next-method)))
2065
2066 (defmethod extra-keywords ((operator (eql 'make-condition))
2067 &rest args)
2068 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2069 (call-next-method)))
2070
2071 (defmethod extra-keywords ((operator (eql 'error))
2072 &rest args)
2073 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2074 (call-next-method)))
2075
2076 (defmethod extra-keywords ((operator (eql 'signal))
2077 &rest args)
2078 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2079 (call-next-method)))
2080
2081 (defmethod extra-keywords ((operator (eql 'warn))
2082 &rest args)
2083 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2084 (call-next-method)))
2085
2086 (defmethod extra-keywords ((operator (eql 'cerror))
2087 &rest args)
2088 (multiple-value-bind (keywords aok determiners)
2089 (apply #'extra-keywords/make-instance operator
2090 (cdr args))
2091 (if keywords
2092 (values keywords aok
2093 (cons (car args) determiners))
2094 (call-next-method))))
2095
2096 (defmethod extra-keywords ((operator (eql 'change-class))
2097 &rest args)
2098 (multiple-value-bind (keywords aok determiners)
2099 (apply #'extra-keywords/change-class operator (cdr args))
2100 (if keywords
2101 (values keywords aok
2102 (cons (car args) determiners))
2103 (call-next-method))))
2104
2105 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
2106 "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
2107 (when keywords
2108 (setf (arglist.key-p decoded-arglist) t)
2109 (setf (arglist.keyword-args decoded-arglist)
2110 (remove-duplicates
2111 (append (arglist.keyword-args decoded-arglist)
2112 keywords)
2113 :key #'keyword-arg.keyword)))
2114 (setf (arglist.allow-other-keys-p decoded-arglist)
2115 (or (arglist.allow-other-keys-p decoded-arglist)
2116 allow-other-keys-p)))
2117
2118 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
2119 "Determine extra keywords from the function call FORM, and modify
2120 DECODED-ARGLIST to include them. As a secondary return value, return
2121 the initial sublist of ARGS that was needed to determine the extra
2122 keywords. As a tertiary return value, return whether any enrichment
2123 was done."
2124 (multiple-value-bind (extra-keywords extra-aok determining-args)
2125 (apply #'extra-keywords form)
2126 ;; enrich the list of keywords with the extra keywords
2127 (enrich-decoded-arglist-with-keywords decoded-arglist
2128 extra-keywords extra-aok)
2129 (values decoded-arglist
2130 determining-args
2131 (or extra-keywords extra-aok))))
2132
2133 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
2134 (:documentation
2135 "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2136 ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2137 If the arglist is not available, return :NOT-AVAILABLE."))
2138
2139 (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2140 (let ((arglist (arglist operator-form)))
2141 (etypecase arglist
2142 ((member :not-available)
2143 :not-available)
2144 (list
2145 (let ((decoded-arglist (decode-arglist arglist)))
2146 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2147 (cons operator-form
2148 argument-forms)))))))
2149
2150 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2151 argument-forms)
2152 (declare (ignore argument-forms))
2153 (multiple-value-bind (decoded-arglist determining-args)
2154 (call-next-method)
2155 (let ((first-arg (first (arglist.required-args decoded-arglist)))
2156 (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2157 (when (and (arglist-p first-arg) (arglist-p open-arglist))
2158 (enrich-decoded-arglist-with-keywords
2159 first-arg
2160 (arglist.keyword-args open-arglist)
2161 nil)))
2162 (values decoded-arglist determining-args t)))
2163
2164 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
2165 argument-forms)
2166 (let ((function-name-form (car argument-forms)))
2167 (when (and (listp function-name-form)
2168 (= (length function-name-form) 2)
2169 (member (car function-name-form) '(quote function)))
2170 (let ((function-name (cadr function-name-form)))
2171 (when (valid-operator-symbol-p function-name)
2172 (let ((function-arglist
2173 (compute-enriched-decoded-arglist function-name
2174 (cdr argument-forms))))
2175 (return-from compute-enriched-decoded-arglist
2176 (values (make-arglist :required-args
2177 (list 'function)
2178 :optional-args
2179 (append
2180 (mapcar #'(lambda (arg)
2181 (make-optional-arg arg nil))
2182 (arglist.required-args function-arglist))
2183 (arglist.optional-args function-arglist))
2184 :key-p
2185 (arglist.key-p function-arglist)
2186 :keyword-args
2187 (arglist.keyword-args function-arglist)
2188 :rest
2189 'args
2190 :allow-other-keys-p
2191 (arglist.allow-other-keys-p function-arglist))
2192 (list function-name-form)
2193 t)))))))
2194 (call-next-method))
2195
2196 (defslimefun arglist-for-insertion (name)
2197 (with-buffer-syntax ()
2198 (let ((symbol (parse-symbol name)))
2199 (cond
2200 ((and symbol
2201 (valid-operator-name-p name))
2202 (let ((decoded-arglist
2203 (compute-enriched-decoded-arglist symbol nil)))
2204 (if (eql decoded-arglist :not-available)
2205 :not-available
2206 (decoded-arglist-to-template-string decoded-arglist
2207 *buffer-package*))))
2208 (t
2209 :not-available)))))
2210
2211 (defvar *remove-keywords-alist*
2212 '((:test :test-not)
2213 (:test-not :test)))
2214
2215 (defun remove-actual-args (decoded-arglist actual-arglist)
2216 "Remove from DECODED-ARGLIST the arguments that have already been
2217 provided in ACTUAL-ARGLIST."
2218 (loop while (and actual-arglist
2219 (arglist.required-args decoded-arglist))
2220 do (progn (pop actual-arglist)
2221 (pop (arglist.required-args decoded-arglist))))
2222 (loop while (and actual-arglist
2223 (arglist.optional-args decoded-arglist))
2224 do (progn (pop actual-arglist)
2225 (pop (arglist.optional-args decoded-arglist))))
2226 (loop for keyword in actual-arglist by #'cddr
2227 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
2228 do (setf (arglist.keyword-args decoded-arglist)
2229 (remove-if (lambda (kw)
2230 (or (eql kw keyword)
2231 (member kw keywords-to-remove)))
2232 (arglist.keyword-args decoded-arglist)
2233 :key #'keyword-arg.keyword))))
2234
2235 (defgeneric form-completion (operator-form argument-forms &key remove-args))
2236
2237 (defmethod form-completion (operator-form argument-forms &key (remove-args t))
2238 (when (and (symbolp operator-form)
2239 (valid-operator-symbol-p operator-form))
2240 (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2241 (compute-enriched-decoded-arglist operator-form argument-forms)
2242 (etypecase decoded-arglist
2243 ((member :not-available)
2244 :not-available)
2245 (arglist
2246 (cond
2247 (remove-args
2248 ;; get rid of formal args already provided
2249 (remove-actual-args decoded-arglist argument-forms))
2250 (t
2251 ;; replace some formal args by determining actual args
2252 (remove-actual-args decoded-arglist determining-args)
2253 (setf (arglist.provided-args decoded-arglist)
2254 determining-args)))
2255 (return-from form-completion
2256 (values decoded-arglist any-enrichment))))))
2257 :not-available)
2258
2259 (defmethod form-completion ((operator-form (eql 'defmethod))
2260 argument-forms &key (remove-args t))
2261 (when (and (listp argument-forms)
2262 (not (null argument-forms)) ;have generic function name
2263 (notany #'listp (rest argument-forms))) ;don't have arglist yet
2264 (let* ((gf-name (first argument-forms))
2265 (gf (and (or (symbolp gf-name)
2266 (and (listp gf-name)
2267 (eql (first gf-name) 'setf)))
2268 (fboundp gf-name)
2269 (fdefinition gf-name))))
2270 (when (typep gf 'generic-function)
2271 (let ((arglist (arglist gf)))
2272 (etypecase arglist
2273 ((member :not-available))
2274 (list
2275 (return-from form-completion
2276 (values (make-arglist :provided-args (if remove-args
2277 nil
2278 (list gf-name))
2279 :required-args (list arglist)
2280 :rest "body" :body-p t)
2281 t))))))))
2282 (call-next-method))
2283
2284 (defun read-incomplete-form-from-string (form-string)
2285 (with-buffer-syntax ()
2286 (handler-case
2287 (read-from-string form-string)
2288 (reader-error (c)
2289 (declare (ignore c))
2290 nil)
2291 (stream-error (c)
2292 (declare (ignore c))
2293 nil))))
2294
2295 (defslimefun complete-form (form-string)
2296 "Read FORM-STRING in the current buffer package, then complete it
2297 by adding a template for the missing arguments."
2298 (let ((form (read-incomplete-form-from-string form-string)))
2299 (when (consp form)
2300 (let ((operator-form (first form))
2301 (argument-forms (rest form)))
2302 (let ((form-completion
2303 (form-completion operator-form argument-forms)))
2304 (unless (eql form-completion :not-available)
2305 (return-from complete-form
2306 (decoded-arglist-to-template-string form-completion
2307 *buffer-package*
2308 :prefix ""))))))
2309 :not-available))
2310
2311 (defun format-arglist-for-echo-area (form operator-name
2312 &key print-right-margin print-lines
2313 highlight)
2314 "Return the arglist for FORM as a string."
2315 (when (consp form)
2316 (destructuring-bind (operator-form &rest argument-forms)
2317 form
2318 (let ((form-completion
2319 (form-completion operator-form argument-forms
2320 :remove-args nil)))
2321 (unless (eql form-completion :not-available)
2322 (return-from format-arglist-for-echo-area
2323 (decoded-arglist-to-string
2324 form-completion
2325 *package*
2326 :operator operator-name
2327 :print-right-margin print-right-margin
2328 :print-lines print-lines
2329 :highlight highlight))))))
2330 nil)
2331
2332 (defun keywords-of-operator (operator)
2333 "Return a list of KEYWORD-ARGs that OPERATOR accepts.
2334 This function is useful for writing EXTRA-KEYWORDS methods for
2335 user-defined functions which are declared &ALLOW-OTHER-KEYS and which
2336 forward keywords to OPERATOR."
2337 (let ((arglist (form-completion operator nil
2338 :remove-args nil)))
2339 (unless (eql arglist :not-available)
2340 (values
2341 (arglist.keyword-args arglist)
2342 (arglist.allow-other-keys-p arglist)))))
2343
2344 (defun arglist-ref (decoded-arglist operator &rest indices)
2345 (cond
2346 ((null indices) decoded-arglist)
2347 ((not (arglist-p decoded-arglist)) nil)
2348 (t
2349 (let ((index (first indices))
2350 (args (append (and operator
2351 (list operator))
2352 (arglist.required-args decoded-arglist)
2353 (arglist.optional-args decoded-arglist))))
2354 (when (< index (length args))
2355 (let ((arg (elt args index)))
2356 (apply #'arglist-ref arg nil (rest indices))))))))
2357
2358 (defslimefun completions-for-keyword (names keyword-string arg-indices)
2359 (with-buffer-syntax ()
2360 (multiple-value-bind (name index)
2361 (find-valid-operator-name names)
2362 (when name
2363 (let* ((form (operator-designator-to-form name))
2364 (operator-form (first form))
2365 (argument-forms (rest form))
2366 (arglist
2367 (form-completion operator-form argument-forms
2368 :remove-args nil)))
2369 (unless (eql arglist :not-available)
2370 (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2371 (arglist (apply #'arglist-ref arglist operator-form indices)))
2372 (when (and arglist (arglist-p arglist))
2373 ;; It would be possible to complete keywords only if we
2374 ;; are in a keyword position, but it is not clear if we
2375 ;; want that.
2376 (let* ((keywords
2377 (mapcar #'keyword-arg.keyword
2378 (arglist.keyword-args arglist)))
2379 (keyword-name
2380 (tokenize-symbol keyword-string))
2381 (matching-keywords
2382 (find-matching-symbols-in-list keyword-name keywords
2383 #'compound-prefix-match))
2384 (converter (completion-output-symbol-converter keyword-string))
2385 (strings
2386 (mapcar converter
2387 (mapcar #'symbol-name matching-keywords)))
2388 (completion-set
2389 (format-completion-set strings nil "")))
2390 (list completion-set
2391 (longest-compound-prefix completion-set)))))))))))
2392
2393
2394 (defun arglist-to-string (arglist package &key print-right-margin highlight)
2395 (decoded-arglist-to-string (decode-arglist arglist)
2396 package
2397 :print-right-margin print-right-margin
2398 :highlight highlight))
2399
2400 (defun test-print-arglist ()
2401 (flet ((test (list string)
2402 (let* ((p (find-package :swank))
2403 (actual (arglist-to-string list p)))
2404 (unless (string= actual string)
2405 (warn "Test failed: ~S => ~S~% Expected: ~S"
2406 list actual string)))))
2407 (test '(function cons) "(function cons)")
2408 (test '(quote cons) "(quote cons)")
2409 (test '(&key (function #'+)) "(&key (function #'+))")
2410 (test '(&whole x y z) "(y z)")
2411 (test '(x &aux y z) "(x)")
2412 (test '(x &environment env y) "(x y)")
2413 (test '(&key ((function f))) "(&key ((function f)))")))
2414
2415 (test-print-arglist)
2416
2417
2418 ;;;; Recording and accessing results of computations
2419
2420 (defvar *record-repl-results* t
2421 "Non-nil means that REPL results are saved for later lookup.")
2422
2423 (defvar *object-to-presentation-id*
2424 (make-weak-key-hash-table :test 'eq)
2425 "Store the mapping of objects to numeric identifiers")
2426
2427 (defvar *presentation-id-to-object*
2428 (make-weak-value-hash-table :test 'eql)
2429 "Store the mapping of numeric identifiers to objects")
2430
2431 (defun clear-presentation-tables ()
2432 (clrhash *object-to-presentation-id*)
2433 (clrhash *presentation-id-to-object*))
2434
2435 (defvar *presentation-counter* 0 "identifier counter")
2436
2437 (defvar *nil-surrogate* (make-symbol "nil-surrogate"))
2438
2439 ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
2440 ;; rest of slime isn't thread safe either), do we really care?
2441 (defun save-presented-object (object)
2442 "Save OBJECT and return the assigned id.
2443 If OBJECT was saved previously return the old id."
2444 (let ((object (if (null object) *nil-surrogate* object)))
2445 ;; We store *nil-surrogate* instead of nil, to distinguish it from
2446 ;; an object that was garbage collected.
2447 (or (gethash object *object-to-presentation-id*)
2448 (let ((id (incf *presentation-counter*)))
2449 (setf (gethash id *presentation-id-to-object*) object)
2450 (setf (gethash object *object-to-presentation-id*) id)
2451 id))))
2452
2453 (defun lookup-presented-object (id)
2454 "Retrieve the object corresponding to ID.
2455 The secondary value indicates the absence of an entry."
2456 (etypecase id
2457 (integer
2458 ;;
2459 (multiple-value-bind (object foundp)
2460 (gethash id *presentation-id-to-object*)
2461 (cond
2462 ((eql object *nil-surrogate*)
2463 ;; A stored nil object
2464 (values nil t))
2465 ((null object)
2466 ;; Object that was replaced by nil in the weak hash table
2467 ;; when the object was garbage collected.
2468 (values nil nil))
2469 (t
2470 (values object foundp)))))
2471 (cons
2472 (destructure-case id
2473 ((:frame-var thread-id frame index)
2474 (declare (ignore thread-id)) ; later
2475 (handler-case
2476 (frame-var-value frame index)
2477 (t (condition)
2478 (declare (ignore condition))
2479 (values nil nil))
2480 (:no-error (value)
2481 (values value t))))
2482 ((:inspected-part part-index)
2483 (declare (special *inspectee-parts*))
2484 (if (< part-index (length *inspectee-parts*))
2485 (values (inspector-nth-part part-index) t)
2486 (values nil nil)))))))
2487
2488 (defslimefun get-repl-result (id)
2489 "Get the result of the previous REPL evaluation with ID."
2490 (multiple-value-bind (object foundp) (lookup-presented-object id)
2491 (cond (foundp object)
2492 (t (abort-request "Attempt to access unrecorded object (id ~D)." id)))))
2493
2494 (defslimefun clear-repl-results ()
2495 "Forget the results of all previous REPL evaluations."
2496 (clear-presentation-tables)
2497 t)
2498
2499
2500 ;;;; Evaluation
2501
2502 (defvar *pending-continuations* '()
2503 "List of continuations for Emacs. (thread local)")
2504
2505 (defun guess-buffer-package (string)
2506 "Return a package for STRING.
2507 Fall back to the the current if no such package exists."
2508 (or (and string (guess-package string))
2509 *package*))
2510
2511 (defun eval-for-emacs (form buffer-package id)
2512 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2513 Return the result to the continuation ID.
2514 Errors are trapped and invoke our debugger."
2515 (call-with-debugger-hook
2516 #'swank-debugger-hook
2517 (lambda ()
2518 (let (ok result reason)
2519 (unwind-protect
2520 (let ((*buffer-package* (guess-buffer-package buffer-package))
2521 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2522 (*pending-continuations* (cons id *pending-continuations*)))
2523 (check-type *buffer-package* package)
2524 (check-type *buffer-readtable* readtable)
2525 ;; APPLY would be cleaner than EVAL.
2526 ;;(setq result (apply (car form) (cdr form)))
2527 (handler-case
2528 (progn
2529 (setq result (eval form))
2530 (run-hook *pre-reply-hook*)
2531 (finish-output)
2532 (setq ok t))
2533 (request-abort (c)
2534 (setf ok nil)
2535 (setf reason (swank-backend::reason c)))))
2536 (force-user-output)
2537 (send-to-emacs `(:return ,(current-thread)
2538 ,(if ok
2539 `(:ok ,result)
2540 `(:abort ,reason))
2541 ,id)))))))
2542
2543 (defvar *echo-area-prefix* "=> "
2544 "A prefix that `format-values-for-echo-area' should use.")
2545
2546 (defun format-values-for-echo-area (values)
2547 (with-buffer-syntax ()
2548 (let ((*print-readably* nil))
2549 (cond ((null values) "; No value")
2550 ((and (null (cdr values)) (integerp (car values)))
2551 (let ((i (car values)))
2552 (format nil "~A~D (#x~X, #o~O, #b~B)"
2553 *echo-area-prefix* i i i i)))
2554 (t (with-output-to-string (s)
2555 (pprint-logical-block (s () :prefix *echo-area-prefix*)
2556 (format s "~{~S~^, ~}" values))))))))
2557
2558 (defslimefun interactive-eval (string)
2559 (with-buffer-syntax ()
2560 (let ((values (multiple-value-list (eval (from-string string)))))
2561 (fresh-line)
2562 (finish-output)
2563 (format-values-for-echo-area values))))
2564
2565 (defslimefun eval-and-grab-output (string)
2566 (with-buffer-syntax ()
2567 (let* ((s (make-string-output-stream))
2568 (*standard-output* s)
2569 (values (multiple-value-list (eval (from-string string)))))
2570 (list (get-output-stream-string s)
2571 (format nil "~{~S~^~%~}" values)))))
2572
2573 ;;; XXX do we need this stuff? What is it good for?
2574 (defvar *slime-repl-advance-history* nil
2575 "In the dynamic scope of a single form typed at the repl, is set to nil to
2576 prevent the repl from advancing the history - * ** *** etc.")
2577
2578 (defvar *slime-repl-suppress-output* nil
2579 "In the dynamic scope of a single form typed at the repl, is set to nil to
2580 prevent the repl from printing the result of the evalation.")
2581
2582 (defvar *slime-repl-eval-hook-pass* (gensym "PASS")
2583 "Token to indicate that a repl hook declines to evaluate the form")
2584
2585 (defvar *slime-repl-eval-hooks* nil
2586 "A list of functions. When the repl is about to eval a form, first try running each of
2587 these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
2588 is considered a replacement for calling eval. If there are no hooks, or all
2589 pass, then eval is used.")
2590
2591 (defslimefun repl-eval-hook-pass ()
2592 "call when repl hook declines to evaluate the form"
2593 (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
2594
2595 (defslimefun repl-suppress-output ()
2596 "In the dynamic scope of a single form typed at the repl, call to
2597 prevent the repl from printing the result of the evalation."
2598 (setq *slime-repl-suppress-output* t))
2599
2600 (defslimefun repl-suppress-advance-history ()
2601 "In the dynamic scope of a single form typed at the repl, call to
2602 prevent the repl from advancing the history - * ** *** etc."
2603 (setq *slime-repl-advance-history* nil))
2604
2605 (defun eval-region (string &optional package-update-p)
2606 "Evaluate STRING and return the result.
2607 If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
2608 change, then send Emacs an update."
2609 (unwind-protect
2610 (with-input-from-string (stream string)
2611 (let (- values)
2612 (loop
2613 (let ((form (read stream nil stream)))
2614 (when (eq form stream)
2615 (fresh-line)
2616 (finish-output)
2617 (return (values values -)))
2618 (setq - form)
2619 (if *slime-repl-eval-hooks*
2620 (setq values (run-repl-eval-hooks form))
2621 (setq values (multiple-value-list (eval form))))
2622 (finish-output)))))
2623 (when (and package-update-p (not (eq *package* *buffer-package*)))
2624 (send-to-emacs
2625 (list :new-package (package-name *package*)
2626 (package-string-for-prompt *package*))))))
2627
2628 (defun run-repl-eval-hooks (form)
2629 (loop for hook in *slime-repl-eval-hooks*
2630 for res = (catch *slime-repl-eval-hook-pass*
2631 (multiple-value-list (funcall hook form)))
2632 until (not (eq res *slime-repl-eval-hook-pass*))
2633 finally (return
2634 (if (eq res *slime-repl-eval-hook-pass*)
2635 (multiple-value-list (eval form))
2636 res))))
2637
2638 (defun package-string-for-prompt (package)
2639 "Return the shortest nickname (or canonical name) of PACKAGE."
2640 (unparse-name
2641 (or (canonical-package-nickname package)
2642 (auto-abbreviated-package-name package)
2643 (shortest-package-nickname package))))
2644
2645 (defun canonical-package-nickname (package)
2646 "Return the canonical package nickname, if any, of PACKAGE."
2647 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2648 :test #'string=))))
2649 (and name (string name))))
2650
2651 (defun auto-abbreviated-package-name (package)
2652 "Return an abbreviated 'name' for PACKAGE.
2653
2654 N.B. this is not an actual package name or nickname."
2655 (when *auto-abbreviate-dotted-packages*
2656 (let ((last-dot (position #\. (package-name package) :from-end t)))
2657 (when last-dot (subseq (package-name package) (1+ last-dot))))))
2658
2659 (defun shortest-package-nickname (package)
2660 "Return the shortest nickname (or canonical name) of PACKAGE."
2661 (loop for name in (cons (package-name package) (package-nicknames package))
2662 for shortest = name then (if (< (length name) (length shortest))
2663 name
2664 shortest)
2665 finally (return shortest)))
2666
2667 (defslimefun interactive-eval-region (string)
2668 (with-buffer-syntax ()
2669 (format-values-for-echo-area (eval-region string))))
2670
2671 (defslimefun re-evaluate-defvar (form)
2672 (with-buffer-syntax ()
2673 (let ((form (read-from-string form)))
2674 (destructuring-bind (dv name &optional value doc) form
2675 (declare (ignore value doc))
2676 (assert (eq dv 'defvar))
2677 (makunbound name)
2678 (prin1-to-string (eval form))))))
2679
2680 (defvar *swank-pprint-bindings*
2681 `((*print-pretty* . t)
2682 (*print-level* . nil)
2683 (*print-length* . nil)
2684 (*print-circle* . t)
2685 (*print-gensym* . t)
2686 (*print-readably* . nil))
2687 "A list of variables bindings during pretty printing.
2688 Used by pprint-eval.")
2689
2690 (defun swank-pprint (list)
2691 "Bind some printer variables and pretty print each object in LIST."
2692 (with-buffer-syntax ()
2693 (with-bindings *swank-pprint-bindings*
2694 (cond ((null list) "; No value")
2695 (t (with-output-to-string (*standard-output*)
2696 (dolist (o list)
2697 (pprint o)
2698 (terpri))))))))
2699
2700 (defslimefun pprint-eval (string)
2701 (with-buffer-syntax ()
2702 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
2703
2704 (defslimefun set-package (name)
2705 "Set *package* to the package named NAME.
2706 Return the full package-name and the string to use in the prompt."
2707 (let ((p (guess-package name)))
2708 (assert (packagep p))
2709 (setq *package* p)
2710 (list (package-name p) (package-string-for-prompt p))))
2711
2712 (defun send-repl-results-to-emacs (values)
2713 (flet ((send (value)
2714 (let ((id (and *record-repl-results*
2715 (save-presented-object value))))
2716 (send-to-emacs `(:write-string ,(prin1-to-string value)
2717 ,id :repl-result))
2718 (send-to-emacs `(:write-string ,(string #\Newline)
2719 nil :repl-result)))))
2720 (if (null values)
2721 (send-to-emacs `(:write-string "; No value" nil :repl-result))
2722 (mapc #'send values))))
2723
2724 (defslimefun listener-eval (string)
2725 (clear-user-input)
2726 (with-buffer-syntax ()
2727 (let ((*slime-repl-suppress-output* :unset)
2728 (*slime-repl-advance-history* :unset))
2729 (multiple-value-bind (values last-form) (eval-region string t)
2730 (unless (or (and (eq values nil) (eq last-form nil))
2731 (eq *slime-repl-advance-history* nil))
2732 (setq *** ** ** * * (car values)
2733 /// // // / / values))
2734 (setq +++ ++ ++ + + last-form)
2735 (unless (eq *slime-repl-suppress-output* t)
2736 (send-repl-results-to-emacs values)))))
2737 nil)
2738
2739 (defslimefun ed-in-emacs (&optional what)
2740 "Edit WHAT in Emacs.
2741
2742 WHAT can be:
2743 A pathname or a string,
2744 A list (PATHNAME-OR-STRING LINE [COLUMN]),
2745 A function name (symbol or cons),
2746 NIL.
2747
2748 Returns true if it actually called emacs, or NIL if not."
2749 (flet ((pathname-or-string-p (thing)
2750 (or (pathnamep thing) (typep thing 'string))))
2751 (let ((target
2752 (cond ((and (listp what) (pathname-or-string-p (first what)))
2753 (cons (canonicalize-filename (car what)) (cdr what)))
2754 ((pathname-or-string-p what)
2755 (canonicalize-filename what))
2756 ((symbolp what) what)
2757 ((consp what) what)
2758 (t (return-from ed-in-emacs nil)))))
2759 (cond
2760 (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2761 ((default-connection)
2762 (with-connection ((default-connection))
2763 (send-oob-to-emacs `(:ed ,target))))
2764 (t nil)))))
2765
2766 (defslimefun inspect-in-emacs (what)
2767 "Inspect WHAT in Emacs."
2768 (flet ((send-it ()
2769 (with-buffer-syntax ()
2770 (reset-inspector)
2771 (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
2772 (cond
2773 (*emacs-connection*
2774 (send-it))
2775 ((default-connection)
2776 (with-connection ((default-connection))
2777 (send-it))))
2778 what))
2779
2780 (defslimefun value-for-editing (form)
2781 "Return a readable value of FORM for editing in Emacs.
2782 FORM is expected, but not required, to be SETF'able."
2783 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2784 (with-buffer-syntax ()
2785 (prin1-to-string (eval (read-from-string form)))))
2786
2787 (defslimefun commit-edited-value (form value)
2788 "Set the value of a setf'able FORM to VALUE.
2789 FORM and VALUE are both strings from Emacs."
2790 (with-buffer-syntax ()
2791 (eval `(setf ,(read-from-string form)
2792 ,(read-from-string (concatenate 'string "`" value))))
2793 t))
2794
2795 (defun background-message (format-string &rest args)
2796 "Display a message in Emacs' echo area.
2797
2798 Use this function for informative messages only. The message may even
2799 be dropped, if we are too busy with other things."
2800 (when *emacs-connection*
2801 (send-to-emacs `(:background-message
2802 ,(apply #'format nil format-string args)))))
2803
2804
2805 ;;;; Debugger
2806
2807 (defun swank-debugger-hook (condition hook)
2808 "Debugger function for binding *DEBUGGER-HOOK*.
2809 Sends a message to Emacs declaring that the debugger has been entered,
2810 then waits to handle further requests from Emacs. Eventually returns
2811 after Emacs causes a restart to be invoked."
2812 (declare (ignore hook))
2813 (cond (*emacs-connection*
2814 (debug-in-emacs condition))
2815 ((default-connection)
2816 (with-connection ((default-connection))
2817 (debug-in-emacs condition)))))
2818
2819 (defvar *global-debugger* t
2820 "Non-nil means the Swank debugger hook will be installed globally.")
2821
2822 (add-hook *new-connection-hook* 'install-debugger)
2823 (defun install-debugger (connection)
2824 (declare (ignore connection))
2825 (when *global-debugger*
2826 (install-debugger-globally #'swank-debugger-hook)))
2827
2828 ;;;;; Debugger loop
2829 ;;;
2830 ;;; These variables are dynamically bound during debugging.
2831 ;;;
2832 (defvar *swank-debugger-condition* nil
2833 "The condition being debugged.")
2834
2835 (defvar *sldb-level* 0
2836 "The current level of recursive debugging.")
2837
2838 (defvar *sldb-initial-frames* 20
2839 "The initial number of backtrace frames to send to Emacs.")
2840
2841 (defvar *sldb-restarts* nil
2842 "The list of currenlty active restarts.")
2843
2844 (defvar *sldb-stepping-p* nil
2845 "True during execution of a step command.")
2846
2847 (defun debug-in-emacs (condition)
2848 (let ((*swank-debugger-condition* condition)
2849 (*sldb-restarts* (compute-sane-restarts condition))
2850 (*package* (or (and (boundp '*buffer-package*)
2851 (symbol-value '*buffer-package*))
2852 *package*))
2853 (*sldb-level* (1+ *sldb-level*))
2854 (*sldb-stepping-p* nil)
2855 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2856 (force-user-output)
2857 (call-with-debugging-environment
2858 (lambda ()
2859 (with-bindings *sldb-printer-bindings*
2860 (sldb-loop *sldb-level*))))))
2861
2862 (defun sldb-loop (level)
2863 (unwind-protect
2864 (catch 'sldb-enter-default-debugger
2865 (send-to-emacs
2866 (list* :debug (current-thread) level
2867 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2868 (loop (catch 'sldb-loop-catcher
2869 (with-simple-restart (abort "Return to sldb level ~D." level)
2870 (send-to-emacs (list :debug-activate (current-thread)
2871 level))
2872 (handler-bind ((sldb-condition #'handle-sldb-condition))
2873 (read-from-emacs))))))
2874 (send-to-emacs `(:debug-return
2875 ,(current-thread) ,level ,*sldb-stepping-p*))))
2876
2877 (defun handle-sldb-condition (condition)
2878 "Handle an internal debugger condition.
2879 Rather than recursively debug the debugger (a dangerous idea!), these
2880 conditions are simply reported."
2881 (let ((real-condition (original-condition condition)))
2882 (send-to-emacs `(:debug-condition ,(current-thread)
2883 ,(princ-to-string real-condition))))
2884 (throw 'sldb-loop-catcher nil))
2885
2886 (defun safe-condition-message (condition)
2887 "Safely print condition to a string, handling any errors during
2888 printing."
2889 (let ((*print-pretty* t))
2890 (handler-case
2891 (format-sldb-condition condition)
2892 (error (cond)
2893 ;; Beware of recursive errors in printing, so only use the condition
2894 ;; if it is printable itself:
2895 (format nil "Unable to display error condition~@[: ~A~]"
2896 (ignore-errors (princ-to-string cond)))))))
2897
2898 (defun debugger-condition-for-emacs ()
2899 (list (safe-condition-message *swank-debugger-condition*)
2900 (format nil " [Condition of type ~S]"
2901 (type-of *swank-debugger-condition*))
2902 (condition-references *swank-debugger-condition*)
2903 (condition-extras *swank-debugger-condition*)))
2904
2905 (defun format-restarts-for-emacs ()
2906 "Return a list of restarts for *swank-debugger-condition* in a
2907 format suitable for Emacs."
2908 (let ((*print-right-margin* most-positive-fixnum))
2909 (loop for restart in *sldb-restarts*
2910 collect (list (princ-to-string (restart-name restart))
2911 (princ-to-string restart)))))
2912
2913
2914 ;;;;; SLDB entry points
2915
2916 (defslimefun sldb-break-with-default-debugger ()
2917 "Invoke the default debugger by returning from our debugger-loop."
2918 (throw 'sldb-enter-default-debugger nil))
2919
2920 (defslimefun backtrace (start end)
2921 "Return a list ((I FRAME) ...) of frames from START to END.
2922 I is an integer describing and FRAME a string."
2923 (loop for frame in (compute-backtrace start end)
2924 for i from start
2925 collect (list i (with-output-to-string (stream)
2926 (handler-case
2927 (print-frame frame stream)
2928 (t ()
2929 (format stream "[error printing frame]")))))))
2930
2931 (defslimefun debugger-info-for-emacs (start end)
2932 "Return debugger state, with stack frames from START to END.
2933 The result is a list:
2934 (condition ({restart}*) ({stack-frame}*) (cont*))
2935 where
2936 condition ::= (description type [extra])
2937 restart ::= (name description)
2938 stack-frame ::= (number description)
2939 extra ::= (:references and other random things)
2940 cont ::= continutation
2941 condition---a pair of strings: message, and type. If show-source is
2942 not nil it is a frame number for which the source should be displayed.
2943
2944 restart---a pair of strings: restart name, and description.
2945
2946 stack-frame---a number from zero (the top), and a printed
2947 representation of the frame's call.
2948
2949 continutation---the id of a pending Emacs continuation.
2950
2951 Below is an example return value. In this case the condition was a
2952 division by zero (multi-line description), and only one frame is being
2953 fetched (start=0, end=1).
2954
2955 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2956 Operation was KERNEL::DIVISION, operands (1 0).\"
2957 \"[Condition of type DIVISION-BY-ZERO]\")
2958 ((\"ABORT\" \"Return to Slime toplevel.\")
2959 (\"ABORT\" \"Return to Top-Level.\"))
2960 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2961 (4))"
2962 (list (debugger-condition-for-emacs)
2963 (format-restarts-for-emacs)
2964 (backtrace start end)
2965 *pending-continuations*))
2966
2967 (defun nth-restart (index)
2968 (nth index *sldb-restarts*))
2969
2970 (defslimefun invoke-nth-restart (index)
2971 (invoke-restart-interactively (nth-restart index)))
2972
2973 (defslimefun sldb-abort ()
2974 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2975
2976 (defslimefun sldb-continue ()
2977 (continue))
2978
2979 (defslimefun throw-to-toplevel ()
2980 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2981 If we are not evaluating an RPC then ABORT instead."
2982 (let ((restart (find-restart *sldb-quit-restart*)))
2983 (cond (restart (invoke-restart restart))
2984 (t (format nil
2985 "Restart not found: ~a"
2986 *sldb-quit-restart*)))))
2987
2988 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2989 "Invoke the Nth available restart.
2990 SLDB-LEVEL is the debug level when the request was made. If this
2991 has changed, ignore the request."
2992 (when (= sldb-level *sldb-level*)
2993 (invoke-nth-restart n)))
2994
2995 (defun wrap-sldb-vars (form)
2996 `(let ((*sldb-level* ,*sldb-level*))
2997 ,form))
2998
2999 (defslimefun eval-string-in-frame (string index)
3000 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
3001 index)))
3002
3003 (defslimefun pprint-eval-string-in-frame (string index)
3004 (swank-pprint
3005 (multiple-value-list
3006 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
3007
3008 (defslimefun frame-locals-for-emacs (index)
3009 "Return a property list ((&key NAME ID VALUE) ...) describing
3010 the local variables in the frame INDEX."
3011 (mapcar (lambda (frame-locals)
3012 (destructuring-bind (&key name id value) frame-locals
3013 (list :name (prin1-to-string name) :id id
3014 :value (to-string value))))
3015 (frame-locals index)))
3016
3017 (defslimefun frame-catch-tags-for-emacs (frame-index)
3018 (mapcar #'to-string (frame-catch-tags frame-index)))
3019
3020 (defslimefun sldb-disassemble (index)
3021 (with-output-to-string (*standard-output*)
3022 (disassemble-frame index)))
3023
3024 (defslimefun sldb-return-from-frame (index string)
3025 (let ((form (from-string string)))
3026 (to-string (multiple-value-list (return-from-frame index form)))))
3027
3028 (defslimefun sldb-break (name)
3029 (with-buffer-syntax ()
3030 (sldb-break-at-start (read-from-string name))))
3031
3032 (defmacro define-stepper-function (name backend-function-name)
3033 `(defslimefun ,name (frame)
3034 (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
3035 (setq *sldb-stepping-p* t)
3036 (,backend-function-name))
3037 ((find-restart 'continue)
3038 (activate-stepping frame)
3039 (setq *sldb-stepping-p* t)
3040 (continue))
3041 (t
3042 (error "Not currently single-stepping, and no continue restart available.")))))
3043
3044 (define-stepper-function sldb-step sldb-step-into)
3045 (define-stepper-function sldb-next sldb-step-next)
3046 (define-stepper-function sldb-out sldb-step-out)
3047
3048
3049 ;;;; Compilation Commands.
3050
3051 (defvar *compiler-notes* '()
3052 "List of compiler notes for the last compilation unit.")
3053
3054 (defun clear-compiler-notes ()
3055 (setf *compiler-notes* '()))
3056
3057 (defun canonicalize-filename (filename)
3058 (namestring (truename filename)))
3059
3060 (defslimefun compiler-notes-for-emacs ()
3061 "Return the list of compiler notes for the last compilation unit."
3062 (reverse *compiler-notes*))
3063
3064 (defun measure-time-interval (fn)
3065 "Call FN and return the first return value and the elapsed time.
3066 The time is measured in microseconds."
3067 (declare (type function fn))
3068 (let ((before (get-internal-real-time)))
3069 (values
3070 (funcall fn)
3071 (* (- (get-internal-real-time) before)
3072 (/ 1000000 internal-time-units-per-second)))))
3073
3074 (defun record-note-for-condition (condition)
3075 "Record a note for a compiler-condition."
3076 (push (make-compiler-note condition) *compiler-notes*))
3077
3078 (defun make-compiler-note (condition)
3079 "Make a compiler note data structure from a compiler-condition."
3080 (declare (type compiler-condition condition))
3081 (list* :message (message condition)
3082 :severity (severity condition)
3083 :location (location condition)
3084 :references (references condition)
3085 (let ((s (short-message condition)))
3086 (if s (list :short-message s)))))
3087
3088 (defun swank-compiler (function)
3089 (clear-compiler-notes)
3090 (multiple-value-bind (result usecs)
3091 (with-simple-restart (abort "Abort SLIME compilation.")
3092 (handler-bind ((compiler-condition #'record-note-for-condition))
3093 (measure-time-interval function)))
3094 ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
3095 ;; unfortunately the SWANK protocol doesn't support returning multiple
3096 ;; values, so we gotta convert it explicitely to a list in either case.
3097 (if (and (not result) (eq usecs 't))
3098 (list nil nil)
3099 (list (to-string result)
3100 (format nil "~,2F" (/ usecs 1000000.0))))))
3101
3102 (defslimefun compile-file-for-emacs (filename load-p)
3103 "Compile FILENAME and, when LOAD-P, load the result.
3104 Record compiler notes signalled as `compiler-condition's."
3105 (with-buffer-syntax ()
3106 (let ((*compile-print* nil))
3107 (swank-compiler
3108 (lambda ()
3109 (swank-compile-file filename load-p
3110 (or (guess-external-format filename)
3111 :default)))))))
3112
3113 (defslimefun compile-string-for-emacs (string buffer position directory)
3114 "Compile STRING (exerpted from BUFFER at POSITION).
3115 Record compiler notes signalled as `compiler-condition's."
3116 (with-buffer-syntax ()
3117 (swank-compiler
3118 (lambda ()
3119 (let ((*compile-print* nil) (*compile-verbose* t))
3120 (swank-compile-string string :buffer buffer :position position
3121 :directory directory))))))
3122
3123 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
3124 "Compile and load SYSTEM using ASDF.
3125 Record compiler notes signalled as `compiler-condition's."
3126 (swank-compiler
3127 (lambda ()
3128 (apply #'operate-on-system system-name operation keywords))))
3129
3130 (defun asdf-central-registry ()
3131 (when (find-package :asdf)
3132 (symbol-value (find-symbol (string :*central-registry*) :asdf))))
3133
3134 (defslimefun list-all-systems-in-central-registry ()
3135 "Returns a list of all systems in ASDF's central registry."
3136 (mapcar #'pathname-name
3137 (delete-duplicates
3138 (loop for dir in (asdf-central-registry)
3139 for defaults = (eval dir)
3140 when defaults
3141 nconc (mapcar #'file-namestring
3142 (directory
3143 (make-pathname :defaults defaults
3144 :version :newest
3145 :type "asd"
3146 :name :wild
3147 :case :local))))
3148 :test #'string=)))
3149
3150 (defslimefun list-all-systems-known-to-asdf ()
3151 "Returns a list of all systems ASDF knows already."
3152 (unless (find-package :asdf)
3153 (error "ASDF not loaded"))
3154 ;; ugh, yeah, it's unexported - but do we really expect this to
3155 ;; change anytime soon?
3156 (loop for name being the hash-keys of (read-from-string
3157 "#.asdf::*defined-systems*")
3158 collect name))
3159
3160 (defslimefun list-asdf-systems ()
3161 "Returns the systems in ASDF's central registry and those which ASDF
3162 already knows."
3163 (nunion (list-all-systems-known-to-asdf)
3164 (list-all-systems-in-central-registry)
3165 :test #'string=))
3166
3167 (defun file-newer-p (new-file old-file)
3168 "Returns true if NEW-FILE is newer than OLD-FILE."
3169 (> (file-write-date new-file) (file-write-date old-file)))
3170
3171 (defun requires-compile-p (source-file)
3172 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
3173 (or (not fasl-file)
3174 (file-newer-p source-file fasl-file))))
3175
3176 (defslimefun compile-file-if-needed (filename loadp)
3177 (cond ((requires-compile-p filename)
3178 (compile-file-for-emacs filename loadp))
3179 (loadp
3180 (load (compile-file-pathname filename))
3181 nil)))
3182
3183
3184 ;;;; Loading
3185
3186 (defslimefun load-file (filename)
3187 (to-string (load filename)))
3188
3189 (defslimefun load-file-set-package (filename &optional package)
3190 (load-file filename)
3191 (if package
3192 (set-package package)))
3193
3194
3195 ;;;;; swank-require
3196
3197 (defslimefun swank-require (module &optional filename)
3198 "Load the module MODULE."
3199 (require module (or filename (module-filename module)))
3200 nil)
3201
3202 (defvar *find-module* 'find-module
3203 "Pluggable function to locate modules.
3204 The function receives a module name as argument and should return
3205 the filename of the module (or nil if the file doesn't exist).")
3206
3207 (defun module-filename (module)
3208 "Return the filename for the module MODULE."
3209 (or (funcall *find-module* module)
3210 (error "Can't locate module: ~s" module)))
3211
3212 ;;;;;; Simple *find-module* function.
3213
3214 (defun merged-directory (dirname defaults)
3215 (pathname-directory
3216 (merge-pathnames
3217 (make-pathname :directory `(:relative ,dirname) :defaults defaults)
3218 defaults)))
3219
3220 (defvar *load-path*
3221 (list (make-pathname :directory (merged-directory "contrib" *load-truename*)
3222 :name nil :type nil :version nil
3223 :defaults *load-truename*))
3224 "A list of directories to search for modules.")
3225
3226 (defun module-canditates (name dir)
3227 (list (compile-file-pathname (make-pathname :name name :defaults dir))
3228 (make-pathname :name name :type "lisp" :defaults dir)))
3229
3230 (defun find-module (module)
3231 (let ((name (string-downcase module)))
3232 (some (lambda (dir) (some #'probe-file (module-canditates name dir)))
3233 *load-path*)))
3234
3235
3236 ;;;; Macroexpansion
3237
3238 (defvar *macroexpand-printer-bindings*
3239 '((*print-circle* . nil)
3240 (*print-pretty* . t)
3241 (*print-escape* . t)
3242 (*print-lines* . nil)
3243 (*print-level* . nil)
3244 (*print-length* . nil)))
3245
3246 (defun apply-macro-expander (expander string)
3247 (with-buffer-syntax ()
3248 (with-bindings *macroexpand-printer-bindings*
3249 (prin1-to-string (funcall expander (from-string string))))))
3250
3251 (defslimefun swank-macroexpand-1 (string)
3252 (apply-macro-expander #'macroexpand-1 string))
3253
3254 (defslimefun swank-macroexpand (string)
3255 (apply-macro-expander #'macroexpand string))
3256
3257 (defslimefun swank-macroexpand-all (string)
3258 (apply-macro-expander #'macroexpand-all string))
3259
3260 (defslimefun swank-compiler-macroexpand-1 (string)
3261 (apply-macro-expander #'compiler-macroexpand-1 string))
3262
3263 (defslimefun swank-compiler-macroexpand (string)
3264 (apply-macro-expander #'compiler-macroexpand string))
3265
3266 (defslimefun disassemble-symbol (name)
3267 (with-buffer-syntax ()
3268 (with-output-to-string (*standard-output*)
3269 (let ((*print-readably* nil))
3270 (disassemble (fdefinition (from-string name)))))))
3271
3272
3273 ;;;; Basic completion
3274
3275 (defslimefun completions (string default-package-name)
3276 "Return a list of completions for a symbol designator STRING.
3277
3278 The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
3279 COMPLETION-SET is the list of all matching completions, and
3280 COMPLETED-PREFIX is the best (partial) completion of the input
3281 string.
3282
3283 Simple compound matching is supported on a per-hyphen basis:
3284
3285 (completions \"m-v-\" \"COMMON-LISP\")
3286 ==> ((\"multiple-value-bind\" \"multiple-value-call\"
3287 \"multiple-value-list\" \"multiple-value-prog1\"
3288 \"multiple-value-setq\" \"multiple-values-limit\")
3289 \"multiple-value\")
3290
3291 \(For more advanced compound matching, see FUZZY-COMPLETIONS.)
3292
3293 If STRING is package qualified the result list will also be
3294 qualified. If string is non-qualified the result strings are
3295 also not qualified and are considered relative to
3296 DEFAULT-PACKAGE-NAME.
3297
3298 The way symbols are matched depends on the symbol designator's
3299 format. The cases are as follows:
3300 FOO - Symbols with matching prefix and accessible in the buffer package.
3301 PKG:FOO - Symbols with matching prefix and external in package PKG.
3302 PKG::FOO - Symbols with matching prefix and accessible in package PKG.
3303 "
3304 (let ((completion-set (completion-set string default-package-name
3305 #'compound-prefix-match)))
3306 (when completion-set
3307 (list completion-set (longest-compound-prefix completion-set)))))
3308
3309
3310 (defslimefun simple-completions (string default-package-name)
3311 "Return a list of completions for a symbol designator STRING."
3312 (let ((completion-set (completion-set string default-package-name
3313 #'prefix-match-p)))
3314 (list completion-set (longest-common-prefix completion-set))))
3315
3316 ;;;;; Find completion set
3317
3318 (defun completion-set (string default-package-name matchp)
3319 "Return the set of completion-candidates as strings."
3320 (multiple-value-bind (name package-name package internal-p)
3321 (parse-completion-arguments string default-package-name)
3322 (let* ((symbols (mapcar (completion-output-symbol-converter name)
3323 (and package
3324 (mapcar #'symbol-name
3325 (find-matching-symbols name
3326 package
3327 (and (not internal-p)
3328 package-name)
3329 matchp)))))
3330 (packs (mapcar (completion-output-package-converter name)
3331 (and (not package-name)
3332 (find-matching-packages name matchp)))))
3333 (format-completion-set (nconc symbols packs) internal-p package-name))))
3334
3335 (defun find-matching-symbols (string package external test)
3336 "Return a list of symbols in PACKAGE matching STRING.
3337 TEST is called with two strings. If EXTERNAL is true, only external
3338 symbols are returned."
3339 (let ((completions '())
3340 (converter (completion-output-symbol-converter string)))
3341 (flet ((symbol-matches-p (symbol)
3342 (and (or (not external)
3343 (symbol-external-p symbol package))
3344 (funcall test string
3345 (funcall converter (symbol-name symbol))))))
3346 (do-symbols* (symbol package)
3347 (when (symbol-matches-p symbol)
3348 (push symbol completions))))
3349 completions))
3350
3351 (defun find-matching-symbols-in-list (string list test)
3352 "Return a list of symbols in LIST matching STRING.
3353 TEST is called with two strings."
3354 (let ((completions '())
3355 (converter (completion-output-symbol-converter string)))
3356 (flet ((symbol-matches-p (symbol)
3357 (funcall test string
3358 (funcall converter (symbol-name symbol)))))
3359 (dolist (symbol list)
3360 (when (symbol-matches-p symbol)
3361 (push symbol completions))))
3362 (remove-duplicates completions)))
3363
3364 (defun find-matching-packages (name matcher)
3365 "Return a list of package names matching NAME with MATCHER.
3366 MATCHER is a two-argument predicate."
3367 (let ((to-match (string-upcase name)))
3368 (remove-if-not (lambda (x) (funcall matcher to-match x))
3369 (mapcar (lambda (pkgname)
3370 (concatenate 'string pkgname ":"))
3371 (loop for package in (list-all-packages)
3372 collect (package-name package)
3373 append (package-nicknames package))))))
3374
3375
3376 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
3377 "Returns one of
3378
3379 :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
3380
3381 :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
3382
3383 :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
3384 but is not _present_ in PACKAGE,
3385
3386 or NIL if SYMBOL is not _accessible_ in PACKAGE.
3387
3388
3389 Be aware not to get confused with :INTERNAL and how \"internal
3390 symbols\" are defined in the spec; there is a slight mismatch of
3391 definition with the Spec and what's commonly meant when talking
3392 about internal symbols most times. As the spec says:
3393
3394 In a package P, a symbol S is
3395
3396 _accessible_ if S is either _present_ in P itself or was
3397 inherited from another package Q (which implies
3398 that S is _external_ in Q.)
3399
3400 You can check that with: (AND (SYMBOL-STATUS S P) T)
3401
3402
3403 _present_ if either P is the /home package/ of S or S has been
3404 imported into P or exported from P by IMPORT, or
3405 EXPORT respectively.
3406
3407 Or more simply, if S is not _inherited_.
3408
3409 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
3410 (AND STATUS
3411 (NOT (EQ STATUS :INHERITED))))
3412
3413
3414 _external_ if S is going to be inherited into any package that
3415 /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
3416 DEFPACKAGE.
3417
3418 Note that _external_ implies _present_, since to
3419 make a symbol _external_, you'd have to use EXPORT
3420 which will automatically make the symbol _present_.
3421
3422 You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
3423
3424
3425 _internal_ if S is _accessible_ but not _external_.
3426
3427 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
3428 (AND STATUS
3429 (NOT (EQ STATUS :EXTERNAL))))
3430
3431
3432 Notice that this is *different* to
3433 (EQ (SYMBOL-STATUS S P) :INTERNAL)
3434 because what the spec considers _internal_ is split up into two
3435 explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
3436 CL:FIND-SYMBOL does.
3437
3438 The rationale is that most times when you speak about \"internal\"
3439 symbols, you're actually not including the symbols inherited
3440 from other packages, but only about the symbols directly specific
3441 to the package in question.
3442 "
3443 (when package ; may be NIL when symbol is completely uninterned.
3444 (check-type symbol symbol) (check-type package package)
3445 (multiple-value-bind (present-symbol status)
3446 (find-symbol (symbol-name symbol) package)
3447 (and (eq symbol present-symbol) status))))
3448
3449 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
3450 "True if SYMBOL is external in PACKAGE.
3451 If PACKAGE is not specified, the home package of SYMBOL is used."
3452 (eq (symbol-status symbol package) :external))
3453
3454
3455 ;; PARSE-COMPLETION-ARGUMENTS return table:
3456 ;;
3457 ;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
3458 ;; ----------------+--------+--------------+-----------------------------------
3459 ;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
3460 ;; | | | or *BUFFER-PACKAGE*
3461 ;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
3462 ;; | | |
3463 ;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
3464 ;; | | |
3465 ;; as:fo [tab] | "fo" | "as" | NIL
3466 ;; | | |
3467 ;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
3468 ;; | | |
3469 ;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
3470 ;;
3471 (defun parse-completion-arguments (string default-package-name)
3472 "Parse STRING as a symbol designator.
3473 Return these values:
3474 SYMBOL-NAME
3475 PACKAGE-NAME, or nil if the designator does not include an explicit package.
3476 PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
3477 NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
3478 if PACKAGE is non-NIL but a package cannot be found under that name,
3479 return NIL.)
3480 INTERNAL-P, if the symbol is qualified with `::'."
3481 (multiple-value-bind (name package-name internal-p)
3482 (tokenize-symbol string)
3483 (if package-name
3484 (let ((package (guess-package (if (equal package-name "")
3485 "KEYWORD"
3486 package-name))))
3487 (values name package-name package internal-p))
3488 (let ((package (guess-package default-package-name)))
3489 (values name package-name (or package *buffer-package*) internal-p))
3490 )))
3491
3492
3493 ;;;;; Format completion results
3494 ;;;
3495 ;;; We try to format results in the case as inputs. If you complete
3496 ;;; `FOO' then your result should include `FOOBAR' rather than
3497 ;;; `foobar'.
3498
3499 (defun format-completion-set (strings internal-p package-name)
3500 "Format a set of completion strings.
3501 Returns a list of completions with package qualifiers if needed."
3502 (mapcar (lambda (string)
3503 (format-completion-result string internal-p package-name))
3504 (sort strings #'string<)))
3505
3506 (defun format-completion-result (string internal-p package-name)
3507 (let ((result (untokenize-symbol package-name internal-p string)))
3508 ;; We return the length of the possibly added prefix as second value.
3509 (values result (search string result))))
3510
3511
3512 (defun completion-output-case-converter (input &optional with-escaping-p)
3513 "Return a function to convert strings for the completion output.
3514 INPUT is used to guess the preferred case."
3515 (ecase (readtable-case *readtable*)
3516 (:upcase (cond ((or with-escaping-p
3517 (not (some #'lower-case-p input)))
3518 #'identity)
3519 (t #'string-downcase)))
3520 (:invert (lambda (output)
3521 (multiple-value-bind (lower upper) (determine-case output)
3522 (cond ((and lower upper) output)
3523 (lower (string-upcase output))
3524 (upper (string-downcase output))
3525 (t output)))))
3526 (:downcase (cond ((or with-escaping-p
3527 (not (some #'upper-case-p input)))
3528 #'identity)
3529 (t #'string-upcase)))
3530 (:preserve #'identity)))
3531
3532 (defun completion-output-package-converter (input)
3533 "Return a function to convert strings for the completion output.
3534 INPUT is used to guess the preferred case."
3535 (completion-output-case-converter input))
3536
3537 (defun completion-output-symbol-converter (input)
3538 "Return a function to convert strings for the completion output.
3539 INPUT is used to guess the preferred case. Escape symbols when needed."
3540 (let ((case-converter (completion-output-case-converter input))
3541 (case-converter-with-escaping (completion-output-case-converter input t)))
3542 (lambda (str)
3543 (if (or (multiple-value-bind (lowercase uppercase)
3544 (determine-case str)
3545 ;; In these readtable cases, symbols with letters from
3546 ;; the wrong case need escaping
3547 (case (readtable-case *readtable*)
3548 (:upcase lowercase)
3549 (:downcase uppercase)
3550 (t nil)))
3551 (some (lambda (el)
3552 (or (member el '(#\: #\Space #\Newline #\Tab))
3553 (multiple-value-bind (macrofun nonterminating)
3554 (get-macro-character el)
3555 (and macrofun
3556 (not nonterminating)))))
3557 str))
3558 (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
3559 (funcall case-converter str)))))
3560
3561
3562 (defun determine-case (string)
3563 "Return two booleans LOWER and UPPER indicating whether STRING
3564 contains lower or upper case characters."
3565 (values (some #'lower-case-p string)
3566 (some #'upper-case-p string)))
3567
3568
3569 ;;;;; Compound-prefix matching
3570
3571 (defun make-compound-prefix-matcher (delimeter &key (test #'char=))
3572 "Returns a matching function that takes a `prefix' and a
3573 `target' string and which returns T if `prefix' is a
3574 compound-prefix of `target', and otherwise NIL.
3575
3576 Viewing each of `prefix' and `target' as a series of substrings
3577 delimited by DELIMETER, if each substring of `prefix' is a prefix
3578 of the corresponding substring in `target' then we call `prefix'
3579 a compound-prefix of `target'."
3580 (lambda (prefix target)
3581 (declare (type simple-string prefix target))
3582 (loop for ch across prefix
3583 with tpos = 0
3584 always (and (< tpos (length target))
3585 (if (char= ch delimeter)
3586 (setf tpos (position #\- target :start tpos))
3587 (funcall test ch (aref target tpos))))
3588 do (incf tpos))))
3589
3590 (defun compound-prefix-match (prefix target)
3591 "Examples:
3592 \(compound-prefix-match \"foo\" \"foobar\") => t
3593 \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
3594 \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL
3595 "
3596 (funcall (make-compound-prefix-matcher #\-) prefix target))
3597
3598 (defun prefix-match-p (prefix string)
3599 "Return true if PREFIX is a prefix of STRING."
3600 (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
3601
3602
3603 ;;;;; Extending the input string by completion
3604
3605 (defun longest-compound-prefix (completions &optional (delimeter #\-))
3606 "Return the longest compound _prefix_ for all COMPLETIONS."
3607 (flet ((tokenizer (string) (tokenize-completion string delimeter)))
3608 (untokenize-completion
3609 (loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
3610 if (notevery #'string= token-list (rest token-list))
3611 collect (longest-common-prefix token-list) ; Note that we possibly collect
3612 and do (loop-finish) ; the "" here as well, so that
3613 else collect (first token-list))))) ; UNTOKENIZE-COMPLETION will
3614 ; append a hyphen for us.
3615 (defun tokenize-completion (string delimeter)
3616 "Return all substrings of STRING delimited by DELIMETER."
3617 (loop with end
3618 for start = 0 then (1+ end)
3619 until (> start (length string))
3620 do (setq end (or (position delimeter string :start start) (length string)))
3621 collect (subseq string start end)))
3622
3623 (defun untokenize-completion (tokens)
3624 (format nil "~{~A~^-~}" tokens))
3625
3626 (defun transpose-lists (lists)
3627 "Turn a list-of-lists on its side.
3628 If the rows are of unequal length, truncate uniformly to the shortest.
3629
3630 For example:
3631 \(transpose-lists '((ONE TWO THREE) (1 2)))
3632 => ((ONE 1) (TWO 2))"
3633 (cond ((null lists) '())
3634 ((some #'null lists) '())
3635 (t (cons (mapcar #'car lists)
3636 (transpose-lists (mapcar #'cdr lists))))))
3637
3638 (defun longest-common-prefix (strings)
3639 "Return the longest string that is a common prefix of STRINGS."
3640 (if (null strings)
3641 ""
3642 (flet ((common-prefix (s1 s2)
3643 (let ((diff-pos (mismatch s1 s2)))
3644 (if diff-pos (subseq s1 0 diff-pos) s1))))
3645 (reduce #'common-prefix strings))))
3646
3647
3648 ;;;; Completion for character names
3649
3650 (defslimefun completions-for-character (prefix)
3651 (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
3652 (completion-set (character-completion-set prefix matcher))
3653 (completions (sort completion-set #'string<)))
3654 (list completions (longest-compound-prefix completions #\_))))
3655
3656
3657
3658 ;;;;; Completion Tests
3659
3660 (defpackage :swank-completion-test
3661 (:use))
3662
3663 (let ((*readtable* (copy-readtable *readtable*))
3664 (p (find-package :swank-completion-test)))
3665 (intern "foo" p)
3666 (intern "Foo" p)
3667 (intern "FOO" p)
3668 (setf (readtable-case *readtable*) :invert)
3669 (flet ((names (prefix)
3670 (sort (mapcar #'symbol-name
3671 (find-matching-symbols prefix p nil #'prefix-match-p))
3672 #'string<)))
3673 (assert (equal '("FOO") (names "f")))
3674 (assert (equal '("Foo" "foo") (names "F")))
3675 (assert (equal '("Foo") (names "Fo")))
3676 (assert (equal '("foo") (names "FO")))))
3677
3678
3679 ;;;; Documentation
3680
3681 (defslimefun apropos-list-for-emacs (name &optional external-only
3682 case-sensitive package)
3683 "Make an apropos search for Emacs.
3684 The result is a list of property lists."
3685 (let ((package (if package
3686 (or (parse-package package)
3687 (error "No such package: ~S" package)))))
3688 ;; The MAPCAN will filter all uninteresting symbols, i.e. those
3689 ;; who cannot be meaningfully described.
3690 (mapcan (listify #'briefly-describe-symbol-for-emacs)
3691 (sort (remove-duplicates
3692 (apropos-symbols name external-only case-sensitive package))
3693 #'present-symbol-before-p))))
3694
3695 (defun briefly-describe-symbol-for-emacs (symbol)
3696 "Return a property list describing SYMBOL.
3697 Like `describe-symbol-for-emacs' but with at most one line per item."
3698 (flet ((first-line (string)
3699 (let ((pos (position #\newline string)))
3700 (if (null pos) string (subseq string 0 pos)))))
3701 (let ((desc (map-if #'stringp #'first-line
3702 (describe-symbol-for-emacs symbol))))
3703 (if desc
3704 (list* :designator (to-string symbol) desc)))))
3705
3706 (defun map-if (test fn &rest lists)
3707 "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
3708 Example:
3709 \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
3710 (apply #'mapcar
3711 (lambda (x) (if (funcall test x) (funcall fn x) x))
3712 lists))
3713
3714 (defun listify (f)
3715 "Return a function like F, but which returns any non-null value
3716 wrapped in a list."
3717 (lambda (x)
3718 (let ((y (funcall f x)))
3719 (and y (list y)))))
3720