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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.352 - (show annotations)
Fri Nov 11 23:47:50 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.351: +8 -1 lines
(*dedicated-output-stream-buffering*): New variable to customize the
buffering scheme.  For single-threaded Lisps we disable buffering
because lazy programmers forget to call finish-output.
(open-dedicated-output-stream): Use it.
1 ;;; -*- outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-
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-swank-server
20 #:create-server
21 #:ed-in-emacs
22 #:print-indentation-lossage
23 #:swank-debugger-hook
24 ;; These are user-configurable variables:
25 #:*communication-style*
26 #:*log-events*
27 #:*log-output*
28 #:*use-dedicated-output-stream*
29 #:*dedicated-output-stream-port*
30 #:*configure-emacs-indentation*
31 #:*readtable-alist*
32 #:*globally-redirect-io*
33 #:*global-debugger*
34 #:*sldb-printer-bindings*
35 #:*swank-pprint-bindings*
36 #:*default-worker-thread-bindings*
37 #:*macroexpand-printer-bindings*
38 #:*record-repl-results*
39 ;; These are re-exported directly from the backend:
40 #:buffer-first-change
41 #:frame-source-location-for-emacs
42 #:restart-frame
43 #:sldb-step
44 #:sldb-break
45 #:sldb-break-on-return
46 #:profiled-functions
47 #:profile-report
48 #:profile-reset
49 #:unprofile-all
50 #:profile-package
51 #:default-directory
52 #:set-default-directory
53 #:quit-lisp))
54
55 (in-package :swank)
56
57
58 ;;;; Top-level variables, constants, macros
59
60 (defconstant cl-package (find-package :cl)
61 "The COMMON-LISP package.")
62
63 (defconstant keyword-package (find-package :keyword)
64 "The KEYWORD package.")
65
66 (defvar *canonical-package-nicknames*
67 `((:common-lisp-user . :cl-user))
68 "Canonical package names to use instead of shortest name/nickname.")
69
70 (defvar *auto-abbreviate-dotted-packages* t
71 "Abbreviate dotted package names to their last component if T.")
72
73 (defvar *swank-io-package*
74 (let ((package (make-package :swank-io-package :use '())))
75 (import '(nil t quote) package)
76 package))
77
78 (defconstant default-server-port 4005
79 "The default TCP port for the server (when started manually).")
80
81 (defvar *swank-debug-p* t
82 "When true, print extra debugging information.")
83
84 (defvar *redirect-io* t
85 "When non-nil redirect Lisp standard I/O to Emacs.
86 Redirection is done while Lisp is processing a request for Emacs.")
87
88 (defvar *sldb-printer-bindings*
89 `((*print-pretty* . nil)
90 (*print-level* . 4)
91 (*print-length* . 10)
92 (*print-circle* . t)
93 (*print-readably* . nil)
94 (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
95 (*print-gensym* . t)
96 (*print-base* . 10)
97 (*print-radix* . nil)
98 (*print-array* . t)
99 (*print-lines* . 200)
100 (*print-escape* . t))
101 "A set of printer variables used in the debugger.")
102
103 (defvar *default-worker-thread-bindings* '()
104 "An alist to initialize dynamic variables in worker threads.
105 The list has the form ((VAR . VALUE) ...). Each variable VAR will be
106 bound to the corresponding VALUE.")
107
108 (defun call-with-bindings (alist fun)
109 "Call FUN with variables bound according to ALIST.
110 ALIST is a list of the form ((VAR . VAL) ...)."
111 (let* ((rlist (reverse alist))
112 (vars (mapcar #'car rlist))
113 (vals (mapcar #'cdr rlist)))
114 (progv vars vals
115 (funcall fun))))
116
117 (defmacro with-bindings (alist &body body)
118 "See `call-with-bindings'."
119 `(call-with-bindings ,alist (lambda () ,@body)))
120
121 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
122 ;;; RPC.
123
124 (defmacro defslimefun (name arglist &body rest)
125 "A DEFUN for functions that Emacs can call by RPC."
126 `(progn
127 (defun ,name ,arglist ,@rest)
128 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
129 (eval-when (:compile-toplevel :load-toplevel :execute)
130 (export ',name :swank))))
131
132 (declaim (ftype (function () nil) missing-arg))
133 (defun missing-arg ()
134 "A function that the compiler knows will never to return a value.
135 You can use (MISSING-ARG) as the initform for defstruct slots that
136 must always be supplied. This way the :TYPE slot option need not
137 include some arbitrary initial value like NIL."
138 (error "A required &KEY or &OPTIONAL argument was not supplied."))
139
140
141 ;;;; Hooks
142 ;;;
143 ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
144 ;;; simple indirection. The interface is more CLish than the Emacs
145 ;;; Lisp one.
146
147 (defmacro add-hook (place function)
148 "Add FUNCTION to the list of values on PLACE."
149 `(pushnew ,function ,place))
150
151 (defun run-hook (functions &rest arguments)
152 "Call each of FUNCTIONS with ARGUMENTS."
153 (dolist (function functions)
154 (apply function arguments)))
155
156 (defvar *new-connection-hook* '()
157 "This hook is run each time a connection is established.
158 The connection structure is given as the argument.
159 Backend code should treat the connection structure as opaque.")
160
161 (defvar *connection-closed-hook* '()
162 "This hook is run when a connection is closed.
163 The connection as passed as an argument.
164 Backend code should treat the connection structure as opaque.")
165
166 (defvar *pre-reply-hook* '()
167 "Hook run (without arguments) immediately before replying to an RPC.")
168
169
170 ;;;; Connections
171 ;;;
172 ;;; Connection structures represent the network connections between
173 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
174 ;;; streams that redirect to Emacs, and optionally a second socket
175 ;;; used solely to pipe user-output to Emacs (an optimization).
176 ;;;
177
178 (defvar *coding-system* ':iso-latin-1-unix)
179
180 (defstruct (connection
181 (:conc-name connection.)
182 (:print-function print-connection))
183 ;; Raw I/O stream of socket connection.
184 (socket-io (missing-arg) :type stream :read-only t)
185 ;; Optional dedicated output socket (backending `user-output' slot).
186 ;; Has a slot so that it can be closed with the connection.
187 (dedicated-output nil :type (or stream null))
188 ;; Streams that can be used for user interaction, with requests
189 ;; redirected to Emacs.
190 (user-input nil :type (or stream null))
191 (user-output nil :type (or stream null))
192 (user-io nil :type (or stream null))
193 ;; In multithreaded systems we delegate certain tasks to specific
194 ;; threads. The `reader-thread' is responsible for reading network
195 ;; requests from Emacs and sending them to the `control-thread'; the
196 ;; `control-thread' is responsible for dispatching requests to the
197 ;; threads that should handle them; the `repl-thread' is the one
198 ;; that evaluates REPL expressions. The control thread dispatches
199 ;; all REPL evaluations to the REPL thread and for other requests it
200 ;; spawns new threads.
201 reader-thread
202 control-thread
203 repl-thread
204 ;; Callback functions:
205 ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
206 ;; from Emacs.
207 (serve-requests (missing-arg) :type function)
208 ;; (READ) is called to read and return one message from Emacs.
209 (read (missing-arg) :type function)
210 ;; (SEND OBJECT) is called to send one message to Emacs.
211 (send (missing-arg) :type function)
212 ;; (CLEANUP <this-connection>) is called when the connection is
213 ;; closed.
214 (cleanup nil :type (or null function))
215 ;; Cache of macro-indentation information that has been sent to Emacs.
216 ;; This is used for preparing deltas to update Emacs's knowledge.
217 ;; Maps: symbol -> indentation-specification
218 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
219 ;; The list of packages represented in the cache:
220 (indentation-cache-packages '())
221 ;; The communication style used.
222 (communication-style nil :type (member nil :spawn :sigio :fd-handler))
223 ;; The coding system for network streams.
224 (external-format *coding-system* :type (member :iso-latin-1-unix
225 :emacs-mule-unix
226 :utf-8-unix
227 :euc-jp-unix)))
228
229 (defun print-connection (conn stream depth)
230 (declare (ignore depth))
231 (print-unreadable-object (conn stream :type t :identity t)))
232
233 (defvar *connections* '()
234 "List of all active connections, with the most recent at the front.")
235
236 (defvar *emacs-connection* nil
237 "The connection to Emacs currently in use.")
238
239 (defvar *swank-state-stack* '()
240 "A list of symbols describing the current state. Used for debugging
241 and to detect situations where interrupts can be ignored.")
242
243 (defun default-connection ()
244 "Return the 'default' Emacs connection.
245 This connection can be used to talk with Emacs when no specific
246 connection is in use, i.e. *EMACS-CONNECTION* is NIL.
247
248 The default connection is defined (quite arbitrarily) as the most
249 recently established one."
250 (first *connections*))
251
252 (defslimefun state-stack ()
253 "Return the value of *SWANK-STATE-STACK*."
254 *swank-state-stack*)
255
256 (define-condition slime-protocol-error (error)
257 ((condition :initarg :condition :reader slime-protocol-error.condition))
258 (:report (lambda (condition stream)
259 (format stream "~A" (slime-protocol-error.condition condition)))))
260
261 (add-hook *new-connection-hook* 'notify-backend-of-connection)
262 (defun notify-backend-of-connection (connection)
263 (declare (ignore connection))
264 (emacs-connected))
265
266
267 ;;;; Helper macros
268
269 (defmacro with-io-redirection ((connection) &body body)
270 "Execute BODY I/O redirection to CONNECTION.
271 If *REDIRECT-IO* is true then all standard I/O streams are redirected."
272 `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
273
274 (defun maybe-call-with-io-redirection (connection fun)
275 (if *redirect-io*
276 (call-with-redirected-io connection fun)
277 (funcall fun)))
278
279 (defmacro with-connection ((connection) &body body)
280 "Execute BODY in the context of CONNECTION."
281 `(call-with-connection ,connection (lambda () ,@body)))
282
283 (defun call-with-connection (connection fun)
284 (let ((*emacs-connection* connection))
285 (with-io-redirection (*emacs-connection*)
286 (let ((*debugger-hook* #'swank-debugger-hook))
287 (funcall fun)))))
288
289 (defmacro without-interrupts (&body body)
290 `(call-without-interrupts (lambda () ,@body)))
291
292 (defmacro destructure-case (value &rest patterns)
293 "Dispatch VALUE to one of PATTERNS.
294 A cross between `case' and `destructuring-bind'.
295 The pattern syntax is:
296 ((HEAD . ARGS) . BODY)
297 The list of patterns is searched for a HEAD `eq' to the car of
298 VALUE. If one is found, the BODY is executed with ARGS bound to the
299 corresponding values in the CDR of VALUE."
300 (let ((operator (gensym "op-"))
301 (operands (gensym "rand-"))
302 (tmp (gensym "tmp-")))
303 `(let* ((,tmp ,value)
304 (,operator (car ,tmp))
305 (,operands (cdr ,tmp)))
306 (case ,operator
307 ,@(loop for (pattern . body) in patterns collect
308 (if (eq pattern t)
309 `(t ,@body)
310 (destructuring-bind (op &rest rands) pattern
311 `(,op (destructuring-bind ,rands ,operands
312 ,@body)))))
313 ,@(if (eq (caar (last patterns)) t)
314 '()
315 `((t (error "destructure-case failed: ~S" ,tmp))))))))
316
317 (defmacro with-temp-package (var &body body)
318 "Execute BODY with VAR bound to a temporary package.
319 The package is deleted before returning."
320 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
321 (unwind-protect (progn ,@body)
322 (delete-package ,var))))
323
324 (defvar *log-events* nil)
325 (defvar *log-output* *error-output*)
326
327 (defun log-event (format-string &rest args)
328 "Write a message to *terminal-io* when *log-events* is non-nil.
329 Useful for low level debugging."
330 (when *log-events*
331 (apply #'format *log-output* format-string args)
332 (force-output *log-output*)))
333
334
335 ;;;; TCP Server
336
337 (defvar *use-dedicated-output-stream* t
338 "When T swank will attempt to create a second connection to
339 Emacs which is used just to send output.")
340
341 (defvar *dedicated-output-stream-port* 0
342 "Which port we should use for the dedicated output stream.")
343
344 (defvar *communication-style* (preferred-communication-style))
345
346 (defvar *dedicated-output-stream-buffering*
347 (if (eq *communication-style* :spawn) :full :none)
348 "The buffering scheme that should be used for the output stream.
349 Valid values are :none, :line, and :full.")
350
351 (defun start-server (port-file &key (style *communication-style*)
352 dont-close (external-format *coding-system*))
353 "Start the server and write the listen port number to PORT-FILE.
354 This is the entry point for Emacs."
355 (when (eq style :spawn)
356 (initialize-multiprocessing))
357 (setup-server 0 (lambda (port) (announce-server-port port-file port))
358 style dont-close external-format)
359 (when (eq style :spawn)
360 (startup-idle-and-top-level-loops)))
361
362 (defun create-server (&key (port default-server-port)
363 (style *communication-style*)
364 dont-close (external-format *coding-system*))
365 "Start a SWANK server on PORT running in STYLE.
366 If DONT-CLOSE is true then the listen socket will accept multiple
367 connections, otherwise it will be closed after the first."
368 (setup-server port #'simple-announce-function style dont-close
369 external-format))
370
371 (defun create-swank-server (&optional (port default-server-port)
372 (style *communication-style*)
373 (announce-fn #'simple-announce-function)
374 dont-close (external-format *coding-system*))
375 (setup-server port announce-fn style dont-close external-format))
376
377 (defparameter *loopback-interface* "127.0.0.1")
378
379 (defun setup-server (port announce-fn style dont-close external-format)
380 (declare (type function announce-fn))
381 (let* ((socket (create-socket *loopback-interface* port))
382 (port (local-port socket)))
383 (funcall announce-fn port)
384 (flet ((serve ()
385 (serve-connection socket style dont-close external-format)))
386 (ecase style
387 (:spawn
388 (spawn (lambda () (loop do (serve) while dont-close))
389 :name "Swank"))
390 ((:fd-handler :sigio)
391 (add-fd-handler socket (lambda () (serve))))
392 ((nil) (loop do (serve) while dont-close)))
393 port)))
394
395 (defun serve-connection (socket style dont-close external-format)
396 (let ((client (accept-authenticated-connection
397 socket :external-format external-format)))
398 (unless dont-close
399 (close-socket socket))
400 (let ((connection (create-connection client style external-format)))
401 (run-hook *new-connection-hook* connection)
402 (push connection *connections*)
403 (serve-requests connection))))
404
405 (defun accept-authenticated-connection (&rest args)
406 (let ((new (apply #'accept-connection args))
407 (secret (slime-secret)))
408 (when secret
409 (let ((first-val (decode-message new)))
410 (unless (and (stringp first-val) (string= first-val secret))
411 (close new)
412 (error "Incoming connection doesn't know the password."))))
413 new))
414
415 (defun slime-secret ()
416 "Finds the magic secret from the user's home directory. Returns nil
417 if the file doesn't exist; otherwise the first line of the file."
418 (with-open-file (in
419 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
420 :if-does-not-exist nil)
421 (and in (read-line in nil ""))))
422
423 (defun serve-requests (connection)
424 "Read and process all requests on connections."
425 (funcall (connection.serve-requests connection) connection))
426
427 (defun announce-server-port (file port)
428 (with-open-file (s file
429 :direction :output
430 :if-exists :error
431 :if-does-not-exist :create)
432 (format s "~S~%" port))
433 (simple-announce-function port))
434
435 (defun simple-announce-function (port)
436 (when *swank-debug-p*
437 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)
438 (force-output *debug-io*)))
439
440 (defun open-streams (connection)
441 "Return the 4 streams for IO redirection:
442 DEDICATED-OUTPUT INPUT OUTPUT IO"
443 (multiple-value-bind (output-fn dedicated-output)
444 (make-output-function connection)
445 (let ((input-fn
446 (lambda ()
447 (with-connection (connection)
448 (with-simple-restart (abort-read
449 "Abort reading input from Emacs.")
450 (read-user-input-from-emacs))))))
451 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
452 (let ((out (or dedicated-output out)))
453 (let ((io (make-two-way-stream in out)))
454 (mapc #'make-stream-interactive (list in out io))
455 (values dedicated-output in out io)))))))
456
457 (defun make-output-function (connection)
458 "Create function to send user output to Emacs.
459 This function may open a dedicated socket to send output. It
460 returns two values: the output function, and the dedicated
461 stream (or NIL if none was created)."
462 (if *use-dedicated-output-stream*
463 (let ((stream (open-dedicated-output-stream
464 (connection.socket-io connection)
465 (connection.external-format connection))))
466 (values (lambda (string)
467 (write-string string stream)
468 (force-output stream))
469 stream))
470 (values (lambda (string)
471 (with-connection (connection)
472 (with-simple-restart
473 (abort "Abort sending output to Emacs.")
474 (send-to-emacs `(:write-string ,string)))))
475 nil)))
476
477 (defun open-dedicated-output-stream (socket-io external-format)
478 "Open a dedicated output connection to the Emacs on SOCKET-IO.
479 Return an output stream suitable for writing program output.
480
481 This is an optimized way for Lisp to deliver output to Emacs."
482 (let* ((socket (create-socket *loopback-interface*
483 *dedicated-output-stream-port*))
484 (port (local-port socket)))
485 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
486 (accept-authenticated-connection
487 socket :external-format external-format
488 :buffering *dedicated-output-stream-buffering*)))
489
490 (defun handle-request (connection)
491 "Read and process one request. The processing is done in the extend
492 of the toplevel restart."
493 (assert (null *swank-state-stack*))
494 (let ((*swank-state-stack* '(:handle-request))
495 (*debugger-hook* nil))
496 (with-connection (connection)
497 (with-simple-restart (abort-request "Abort handling SLIME request.")
498 (read-from-emacs)))))
499
500 (defun current-socket-io ()
501 (connection.socket-io *emacs-connection*))
502
503 (defun close-connection (c &optional condition)
504 (let ((cleanup (connection.cleanup c)))
505 (when cleanup
506 (funcall cleanup c)))
507 (close (connection.socket-io c))
508 (when (connection.dedicated-output c)
509 (close (connection.dedicated-output c)))
510 (setf *connections* (remove c *connections*))
511 (run-hook *connection-closed-hook* c)
512 (when condition
513 (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)
514 (finish-output *debug-io*)))
515
516 (defmacro with-reader-error-handler ((connection) &body body)
517 `(handler-case (progn ,@body)
518 (slime-protocol-error (e)
519 (close-connection ,connection e))))
520
521 (defslimefun simple-break ()
522 (with-simple-restart (continue "Continue from interrupt.")
523 (let ((*debugger-hook* #'swank-debugger-hook))
524 (invoke-debugger
525 (make-condition 'simple-error
526 :format-control "Interrupt from Emacs"))))
527 nil)
528
529 ;;;;;; Thread based communication
530
531 (defvar *active-threads* '())
532
533 (defun read-loop (control-thread input-stream connection)
534 (with-reader-error-handler (connection)
535 (loop (send control-thread (decode-message input-stream)))))
536
537 (defun dispatch-loop (socket-io connection)
538 (let ((*emacs-connection* connection))
539 (handler-case
540 (loop (dispatch-event (receive) socket-io))
541 (error (e)
542 (close-connection connection e)))))
543
544 (defun repl-thread (connection)
545 (let ((thread (connection.repl-thread connection)))
546 (if (thread-alive-p thread)
547 thread
548 (setf (connection.repl-thread connection)
549 (spawn-repl-thread connection "new-repl-thread")))))
550
551
552 (defun find-worker-thread (id)
553 (etypecase id
554 ((member t)
555 (car *active-threads*))
556 ((member :repl-thread)
557 (repl-thread *emacs-connection*))
558 (fixnum
559 (find-thread id))))
560
561 (defun interrupt-worker-thread (id)
562 (let ((thread (or (find-worker-thread id)
563 (repl-thread *emacs-connection*))))
564 (interrupt-thread thread #'simple-break)))
565
566 (defun thread-for-evaluation (id)
567 "Find or create a thread to evaluate the next request."
568 (let ((c *emacs-connection*))
569 (etypecase id
570 ((member t)
571 (spawn-worker-thread c))
572 ((member :repl-thread)
573 (repl-thread c))
574 (fixnum
575 (find-thread id)))))
576
577 (defun spawn-worker-thread (connection)
578 (spawn (lambda ()
579 (with-bindings *default-worker-thread-bindings*
580 (handle-request connection)))
581 :name "worker"))
582
583 (defun spawn-repl-thread (connection name)
584 (spawn (lambda ()
585 (with-bindings *default-worker-thread-bindings*
586 (repl-loop connection)))
587 :name name))
588
589 (defun dispatch-event (event socket-io)
590 "Handle an event triggered either by Emacs or within Lisp."
591 (log-event "DISPATCHING: ~S~%" event)
592 (destructure-case event
593 ((:emacs-rex form package thread-id id)
594 (let ((thread (thread-for-evaluation thread-id)))
595 (push thread *active-threads*)
596 (send thread `(eval-for-emacs ,form ,package ,id))))
597 ((:return thread &rest args)
598 (let ((tail (member thread *active-threads*)))
599 (setq *active-threads* (nconc (ldiff *active-threads* tail)
600 (cdr tail))))
601 (encode-message `(:return ,@args) socket-io))
602 ((:emacs-interrupt thread-id)
603 (interrupt-worker-thread thread-id))
604 (((:debug :debug-condition :debug-activate :debug-return)
605 thread &rest args)
606 (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
607 ((:read-string thread &rest args)
608 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
609 ((:y-or-n-p thread &rest args)
610 (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
611 ((:read-aborted thread &rest args)
612 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
613 ((:emacs-return-string thread-id tag string)
614 (send (find-thread thread-id) `(take-input ,tag ,string)))
615 ((:eval thread &rest args)
616 (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
617 ((:emacs-return thread-id tag value)
618 (send (find-thread thread-id) `(take-input ,tag ,value)))
619 (((:write-string :presentation-start :presentation-end
620 :new-package :new-features :ed :%apply :indentation-update
621 :eval-no-wait :background-message)
622 &rest _)
623 (declare (ignore _))
624 (encode-message event socket-io))))
625
626 (defun spawn-threads-for-connection (connection)
627 (let* ((socket-io (connection.socket-io connection))
628 (control-thread (spawn (lambda ()
629 (let ((*debugger-hook* nil))
630 (dispatch-loop socket-io connection)))
631 :name "control-thread")))
632 (setf (connection.control-thread connection) control-thread)
633 (let ((reader-thread (spawn (lambda ()
634 (let ((*debugger-hook* nil))
635 (read-loop control-thread socket-io
636 connection)))
637 :name "reader-thread"))
638 (repl-thread (spawn-repl-thread connection "repl-thread")))
639 (setf (connection.reader-thread connection) reader-thread)
640 (setf (connection.repl-thread connection) repl-thread)
641 connection)))
642
643 (defun cleanup-connection-threads (connection)
644 (let ((threads (list (connection.repl-thread connection)
645 (connection.reader-thread connection)
646 (connection.control-thread connection))))
647 (dolist (thread threads)
648 (unless (equal (current-thread) thread)
649 (kill-thread thread)))))
650
651 (defun repl-loop (connection)
652 (with-connection (connection)
653 (loop (handle-request connection))))
654
655 (defun process-available-input (stream fn)
656 (loop while (and (open-stream-p stream)
657 (listen stream))
658 do (funcall fn)))
659
660 ;;;;;; Signal driven IO
661
662 (defun install-sigio-handler (connection)
663 (let ((client (connection.socket-io connection)))
664 (flet ((handler ()
665 (cond ((null *swank-state-stack*)
666 (with-reader-error-handler (connection)
667 (process-available-input
668 client (lambda () (handle-request connection)))))
669 ((eq (car *swank-state-stack*) :read-next-form))
670 (t (process-available-input client #'read-from-emacs)))))
671 (add-sigio-handler client #'handler)
672 (handler))))
673
674 (defun deinstall-sigio-handler (connection)
675 (remove-sigio-handlers (connection.socket-io connection)))
676
677 ;;;;;; SERVE-EVENT based IO
678
679 (defun install-fd-handler (connection)
680 (let ((client (connection.socket-io connection)))
681 (flet ((handler ()
682 (cond ((null *swank-state-stack*)
683 (with-reader-error-handler (connection)
684 (process-available-input
685 client (lambda () (handle-request connection)))))
686 ((eq (car *swank-state-stack*) :read-next-form))
687 (t (process-available-input client #'read-from-emacs)))))
688 (setq *debugger-hook*
689 (lambda (c h)
690 (with-reader-error-handler (connection)
691 (block debugger
692 (with-connection (connection)
693 (swank-debugger-hook c h)
694 (return-from debugger))
695 (abort)))))
696 (add-fd-handler client #'handler)
697 (handler))))
698
699 (defun deinstall-fd-handler (connection)
700 (remove-fd-handlers (connection.socket-io connection)))
701
702 ;;;;;; Simple sequential IO
703
704 (defun simple-serve-requests (connection)
705 (with-reader-error-handler (connection)
706 (unwind-protect (loop (with-simple-restart
707 (abort "Return to SLIME top-level.")
708 (handle-request connection)))
709 (close-connection connection))))
710
711 (defun read-from-socket-io ()
712 (let ((event (decode-message (current-socket-io))))
713 (log-event "DISPATCHING: ~S~%" event)
714 (destructure-case event
715 ((:emacs-rex form package thread id)
716 (declare (ignore thread))
717 `(eval-for-emacs ,form ,package ,id))
718 ((:emacs-interrupt thread)
719 (declare (ignore thread))
720 '(simple-break))
721 ((:emacs-return-string thread tag string)
722 (declare (ignore thread))
723 `(take-input ,tag ,string))
724 ((:emacs-return thread tag value)
725 (declare (ignore thread))
726 `(take-input ,tag ,value)))))
727
728 (defun send-to-socket-io (event)
729 (log-event "DISPATCHING: ~S~%" event)
730 (flet ((send (o)
731 (without-interrupts
732 (encode-message o (current-socket-io)))))
733 (destructure-case event
734 (((:debug-activate :debug :debug-return :read-string :read-aborted
735 :y-or-n-p :eval)
736 thread &rest args)
737 (declare (ignore thread))
738 (send `(,(car event) 0 ,@args)))
739 ((:return thread &rest args)
740 (declare (ignore thread))
741 (send `(:return ,@args)))
742 (((:write-string :new-package :new-features :debug-condition
743 :presentation-start :presentation-end
744 :indentation-update :ed :%apply :eval-no-wait
745 :background-message)
746 &rest _)
747 (declare (ignore _))
748 (send event)))))
749
750 (defun initialize-streams-for-connection (connection)
751 (multiple-value-bind (dedicated in out io) (open-streams connection)
752 (setf (connection.dedicated-output connection) dedicated
753 (connection.user-io connection) io
754 (connection.user-output connection) out
755 (connection.user-input connection) in)
756 connection))
757
758 (defun create-connection (socket-io style external-format)
759 (let ((c (ecase style
760 (:spawn
761 (make-connection :socket-io socket-io
762 :read #'read-from-control-thread
763 :send #'send-to-control-thread
764 :serve-requests #'spawn-threads-for-connection
765 :cleanup #'cleanup-connection-threads))
766 (:sigio
767 (make-connection :socket-io socket-io
768 :read #'read-from-socket-io
769 :send #'send-to-socket-io
770 :serve-requests #'install-sigio-handler
771 :cleanup #'deinstall-sigio-handler))
772 (:fd-handler
773 (make-connection :socket-io socket-io
774 :read #'read-from-socket-io
775 :send #'send-to-socket-io
776 :serve-requests #'install-fd-handler
777 :cleanup #'deinstall-fd-handler))
778 ((nil)
779 (make-connection :socket-io socket-io
780 :read #'read-from-socket-io
781 :send #'send-to-socket-io
782 :serve-requests #'simple-serve-requests)))))
783 (setf (connection.communication-style c) style)
784 (setf (connection.external-format c) external-format)
785 (initialize-streams-for-connection c)
786 c))
787
788
789 ;;;; IO to Emacs
790 ;;;
791 ;;; This code handles redirection of the standard I/O streams
792 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
793 ;;; contains the appropriate streams, so all we have to do is make the
794 ;;; right bindings.
795
796 ;;;;; Global I/O redirection framework
797 ;;;
798 ;;; Optionally, the top-level global bindings of the standard streams
799 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
800 ;;; redirect the streams into the connection, and they keep going into
801 ;;; that connection even if more are established. If the connection
802 ;;; handling the streams closes then another is chosen, or if there
803 ;;; are no connections then we revert to the original (real) streams.
804 ;;;
805 ;;; It is slightly tricky to assign the global values of standard
806 ;;; streams because they are often shadowed by dynamic bindings. We
807 ;;; solve this problem by introducing an extra indirection via synonym
808 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
809 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
810 ;;; variables, so they can always be assigned to affect a global
811 ;;; change.
812
813 (defvar *globally-redirect-io* nil
814 "When non-nil globally redirect all standard streams to Emacs.")
815
816 (defmacro setup-stream-indirection (stream-var)
817 "Setup redirection scaffolding for a global stream variable.
818 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
819
820 1. Saves the value of *STANDARD-INPUT* in a variable called
821 *REAL-STANDARD-INPUT*.
822
823 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
824 *STANDARD-INPUT*.
825
826 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
827 *CURRENT-STANDARD-INPUT*.
828
829 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
830 effective global value for *STANDARD-INPUT*. This way we can assign
831 the effective global value even when *STANDARD-INPUT* is shadowed by a
832 dynamic binding."
833 (let ((real-stream-var (prefixed-var "REAL" stream-var))
834 (current-stream-var (prefixed-var "CURRENT" stream-var)))
835 `(progn
836 ;; Save the real stream value for the future.
837 (defvar ,real-stream-var ,stream-var)
838 ;; Define a new variable for the effective stream.
839 ;; This can be reassigned.
840 (defvar ,current-stream-var ,stream-var)
841 ;; Assign the real binding as a synonym for the current one.
842 (setq ,stream-var (make-synonym-stream ',current-stream-var)))))
843
844 (eval-when (:compile-toplevel :load-toplevel :execute)
845 (defun prefixed-var (prefix variable-symbol)
846 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
847 (let ((basename (subseq (symbol-name variable-symbol) 1)))
848 (intern (format nil "*~A-~A" prefix basename) :swank))))
849
850 ;;;;; Global redirection setup
851
852 (setup-stream-indirection *standard-output*)
853 (setup-stream-indirection *error-output*)
854 (setup-stream-indirection *trace-output*)
855 (setup-stream-indirection *standard-input*)
856 (setup-stream-indirection *debug-io*)
857 (setup-stream-indirection *query-io*)
858 (setup-stream-indirection *terminal-io*)
859
860 (defparameter *standard-output-streams*
861 '(*standard-output* *error-output* *trace-output*)
862 "The symbols naming standard output streams.")
863
864 (defparameter *standard-input-streams*
865 '(*standard-input*)
866 "The symbols naming standard input streams.")
867
868 (defparameter *standard-io-streams*
869 '(*debug-io* *query-io* *terminal-io*)
870 "The symbols naming standard io streams.")
871
872 (defun globally-redirect-io-to-connection (connection)
873 "Set the standard I/O streams to redirect to CONNECTION.
874 Assigns *CURRENT-<STREAM>* for all standard streams."
875 (dolist (o *standard-output-streams*)
876 (set (prefixed-var "CURRENT" o)
877 (connection.user-output connection)))
878 ;; FIXME: If we redirect standard input to Emacs then we get the
879 ;; regular Lisp top-level trying to read from our REPL.
880 ;;
881 ;; Perhaps the ideal would be for the real top-level to run in a
882 ;; thread with local bindings for all the standard streams. Failing
883 ;; that we probably would like to inhibit it from reading while
884 ;; Emacs is connected.
885 ;;
886 ;; Meanwhile we just leave *standard-input* alone.
887 #+NIL
888 (dolist (i *standard-input-streams*)
889 (set (prefixed-var "CURRENT" i)
890 (connection.user-input connection)))
891 (dolist (io *standard-io-streams*)
892 (set (prefixed-var "CURRENT" io)
893 (connection.user-io connection))))
894
895 (defun revert-global-io-redirection ()
896 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
897 (dolist (stream-var (append *standard-output-streams*
898 *standard-input-streams*
899 *standard-io-streams*))
900 (set (prefixed-var "CURRENT" stream-var)
901 (symbol-value (prefixed-var "REAL" stream-var)))))
902
903 ;;;;; Global redirection hooks
904
905 (defvar *global-stdio-connection* nil
906 "The connection to which standard I/O streams are globally redirected.
907 NIL if streams are not globally redirected.")
908
909 (defun maybe-redirect-global-io (connection)
910 "Consider globally redirecting to a newly-established CONNECTION."
911 (when (and *globally-redirect-io* (null *global-stdio-connection*))
912 (setq *global-stdio-connection* connection)
913 (globally-redirect-io-to-connection connection)))
914
915 (defun update-redirection-after-close (closed-connection)
916 "Update redirection after a connection closes."
917 (when (eq *global-stdio-connection* closed-connection)
918 (if (and (default-connection) *globally-redirect-io*)
919 ;; Redirect to another connection.
920 (globally-redirect-io-to-connection (default-connection))
921 ;; No more connections, revert to the real streams.
922 (progn (revert-global-io-redirection)
923 (setq *global-stdio-connection* nil)))))
924
925 (add-hook *new-connection-hook* 'maybe-redirect-global-io)
926 (add-hook *connection-closed-hook* 'update-redirection-after-close)
927
928 ;;;;; Redirection during requests
929 ;;;
930 ;;; We always redirect the standard streams to Emacs while evaluating
931 ;;; an RPC. This is done with simple dynamic bindings.
932
933 (defun call-with-redirected-io (connection function)
934 "Call FUNCTION with I/O streams redirected via CONNECTION."
935 (declare (type function function))
936 (let* ((io (connection.user-io connection))
937 (in (connection.user-input connection))
938 (out (connection.user-output connection))
939 (*standard-output* out)
940 (*error-output* out)
941 (*trace-output* out)
942 (*debug-io* io)
943 (*query-io* io)
944 (*standard-input* in)
945 (*terminal-io* io))
946 (funcall function)))
947
948 (defun read-from-emacs ()
949 "Read and process a request from Emacs."
950 (apply #'funcall (funcall (connection.read *emacs-connection*))))
951
952 (defun read-from-control-thread ()
953 (receive))
954
955 (defun decode-message (stream)
956 "Read an S-expression from STREAM using the SLIME protocol.
957 If a protocol error occurs then a SLIME-PROTOCOL-ERROR is signalled."
958 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
959 (handler-case
960 (let* ((length (decode-message-length stream))
961 (string (make-string length))
962 (pos (read-sequence string stream)))
963 (assert (= pos length) ()
964 "Short read: length=~D pos=~D" length pos)
965 (let ((form (read-form string)))
966 (log-event "READ: ~A~%" string)
967 form))
968 (serious-condition (c)
969 (error (make-condition 'slime-protocol-error :condition c))))))
970
971 (defun decode-message-length (stream)
972 (let ((buffer (make-string 6)))
973 (dotimes (i 6)
974 (setf (aref buffer i) (read-char stream)))
975 (parse-integer buffer :radix #x10)))
976
977 (defun read-form (string)
978 (with-standard-io-syntax
979 (let ((*package* *swank-io-package*))
980 (read-from-string string))))
981
982 (defvar *slime-features* nil
983 "The feature list that has been sent to Emacs.")
984
985 (defun send-to-emacs (object)
986 "Send OBJECT to Emacs."
987 (funcall (connection.send *emacs-connection*) object))
988
989 (defun send-oob-to-emacs (object)
990 (send-to-emacs object))
991
992 (defun send-to-control-thread (object)
993 (send (connection.control-thread *emacs-connection*) object))
994
995 (defun encode-message (message stream)
996 (let* ((string (prin1-to-string-for-emacs message))
997 (length (length string)))
998 (log-event "WRITE: ~A~%" string)
999 (let ((*print-pretty* nil))
1000 (format stream "~6,'0x" length))
1001 (write-string string stream)
1002 ;;(terpri stream)
1003 (force-output stream)))
1004
1005 (defun prin1-to-string-for-emacs (object)
1006 (with-standard-io-syntax
1007 (let ((*print-case* :downcase)
1008 (*print-readably* nil)
1009 (*print-pretty* nil)
1010 (*package* *swank-io-package*))
1011 (prin1-to-string object))))
1012
1013 (defun force-user-output ()
1014 (force-output (connection.user-io *emacs-connection*))
1015 (finish-output (connection.user-output *emacs-connection*)))
1016
1017 (defun clear-user-input ()
1018 (clear-input (connection.user-input *emacs-connection*)))
1019
1020 (defvar *read-input-catch-tag* 0)
1021
1022 (defun intern-catch-tag (tag)
1023 ;; fixnums aren't eq in ABCL, so we use intern to create tags
1024 (intern (format nil "~D" tag) :swank))
1025
1026 (defun read-user-input-from-emacs ()
1027 (let ((tag (incf *read-input-catch-tag*)))
1028 (force-output)
1029 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1030 (let ((ok nil))
1031 (unwind-protect
1032 (prog1 (catch (intern-catch-tag tag)
1033 (loop (read-from-emacs)))
1034 (setq ok t))
1035 (unless ok
1036 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1037
1038 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1039 "Like y-or-n-p, but ask in the Emacs minibuffer."
1040 (let ((tag (incf *read-input-catch-tag*))
1041 (question (apply #'format nil format-string arguments)))
1042 (force-output)
1043 (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1044 (catch (intern-catch-tag tag)
1045 (loop (read-from-emacs)))))
1046
1047 (defslimefun take-input (tag input)
1048 "Return the string INPUT to the continuation TAG."
1049 (throw (intern-catch-tag tag) input))
1050
1051 (defun process-form-for-emacs (form)
1052 "Returns a string which emacs will read as equivalent to
1053 FORM. FORM can contain lists, strings, characters, symbols and
1054 numbers.
1055
1056 Characters are converted emacs' ?<char> notaion, strings are left
1057 as they are (except for espacing any nested \" chars, numbers are
1058 printed in base 10 and symbols are printed as their symbol-nome
1059 converted to lower case."
1060 (etypecase form
1061 (string (format nil "~S" form))
1062 (cons (format nil "(~A . ~A)"
1063 (process-form-for-emacs (car form))
1064 (process-form-for-emacs (cdr form))))
1065 (character (format nil "?~C" form))
1066 (symbol (string-downcase (symbol-name form)))
1067 (number (let ((*print-base* 10))
1068 (princ-to-string form)))))
1069
1070 (defun eval-in-emacs (form &optional nowait)
1071 "Eval FORM in Emacs."
1072 (cond (nowait
1073 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1074 (t
1075 (force-output)
1076 (let* ((tag (incf *read-input-catch-tag*))
1077 (value (catch (intern-catch-tag tag)
1078 (send-to-emacs
1079 `(:eval ,(current-thread) ,tag
1080 ,(process-form-for-emacs form)))
1081 (loop (read-from-emacs)))))
1082 (destructure-case value
1083 ((:ok value) value)
1084 ((:abort) (abort)))))))
1085
1086 (defslimefun connection-info ()
1087 "Return a key-value list of the form:
1088 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE)
1089 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1090 STYLE: the communication style
1091 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1092 FEATURES: a list of keywords
1093 PACKAGE: a list (&key NAME PROMPT)"
1094 (setq *slime-features* *features*)
1095 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1096 :lisp-implementation (:type ,(lisp-implementation-type)
1097 :name ,(lisp-implementation-type-name)
1098 :version ,(lisp-implementation-version))
1099 :machine (:instance ,(machine-instance)
1100 :type ,(machine-type)
1101 :version ,(machine-version))
1102 :features ,(features-for-emacs)
1103 :package (:name ,(package-name *package*)
1104 :prompt ,(package-string-for-prompt *package*))))
1105
1106 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1107 (let* ((s *standard-output*)
1108 (*trace-output* (make-broadcast-stream s *log-output*)))
1109 (time (progn
1110 (dotimes (i n)
1111 (format s "~D abcdefghijklm~%" i)
1112 (when (zerop (mod n m))
1113 (force-output s)))
1114 (finish-output s)
1115 (when *emacs-connection*
1116 (eval-in-emacs '(message "done.")))))
1117 (terpri *trace-output*)
1118 (finish-output *trace-output*)
1119 nil))
1120
1121
1122 ;;;; Reading and printing
1123
1124 (defmacro define-special (name doc)
1125 "Define a special variable NAME with doc string DOC.
1126 This is like defvar, but NAME will not be initialized."
1127 `(progn
1128 (defvar ,name)
1129 (setf (documentation ',name 'variable) ,doc)))
1130
1131 (define-special *buffer-package*
1132 "Package corresponding to slime-buffer-package.
1133
1134 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1135 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1136
1137 (define-special *buffer-readtable*
1138 "Readtable associated with the current buffer")
1139
1140 (defmacro with-buffer-syntax ((&rest _) &body body)
1141 "Execute BODY with appropriate *package* and *readtable* bindings.
1142
1143 This should be used for code that is conceptionally executed in an
1144 Emacs buffer."
1145 (destructuring-bind () _
1146 `(call-with-buffer-syntax (lambda () ,@body))))
1147
1148 (defun call-with-buffer-syntax (fun)
1149 (let ((*package* *buffer-package*))
1150 ;; Don't shadow *readtable* unnecessarily because that prevents
1151 ;; the user from assigning to it.
1152 (if (eq *readtable* *buffer-readtable*)
1153 (call-with-syntax-hooks fun)
1154 (let ((*readtable* *buffer-readtable*))
1155 (call-with-syntax-hooks fun)))))
1156
1157 (defun to-string (object)
1158 "Write OBJECT in the *BUFFER-PACKAGE*.
1159 The result may not be readable."
1160 (with-buffer-syntax ()
1161 (let ((*print-readably* nil))
1162 (prin1-to-string object))))
1163
1164 (defun from-string (string)
1165 "Read string in the *BUFFER-PACKAGE*"
1166 (with-buffer-syntax ()
1167 (let ((*read-suppress* nil))
1168 (read-from-string string))))
1169
1170 ;; FIXME: deal with #\| etc. hard to do portably.
1171 (defun tokenize-symbol (string)
1172 (let ((package (let ((pos (position #\: string)))
1173 (if pos (subseq string 0 pos) nil)))
1174 (symbol (let ((pos (position #\: string :from-end t)))
1175 (if pos (subseq string (1+ pos)) string)))
1176 (internp (search "::" string)))
1177 (values symbol package internp)))
1178
1179 ;; FIXME: Escape chars are ignored
1180 (defun casify (string)
1181 "Convert string accoring to readtable-case."
1182 (ecase (readtable-case *readtable*)
1183 (:preserve string)
1184 (:upcase (string-upcase string))
1185 (:downcase (string-downcase string))
1186 (:invert (multiple-value-bind (lower upper) (determine-case string)
1187 (cond ((and lower upper) string)
1188 (lower (string-upcase string))
1189 (upper (string-downcase string))
1190 (t string))))))
1191
1192 (defun parse-symbol (string &optional (package *package*))
1193 "Find the symbol named STRING.
1194 Return the symbol and a flag indicating whether the symbols was found."
1195 (multiple-value-bind (sname pname) (tokenize-symbol string)
1196 (let ((package (cond ((string= pname "") keyword-package)
1197 (pname (find-package (casify pname)))
1198 (t package))))
1199 (if package
1200 (find-symbol (casify sname) package)
1201 (values nil nil)))))
1202
1203 (defun parse-symbol-or-lose (string &optional (package *package*))
1204 (multiple-value-bind (symbol status) (parse-symbol string package)
1205 (if status
1206 (values symbol status)
1207 (error "Unknown symbol: ~A [in ~A]" string package))))
1208
1209 ;; FIXME: interns the name
1210 (defun parse-package (string)
1211 "Find the package named STRING.
1212 Return the package or nil."
1213 (multiple-value-bind (name pos)
1214 (if (zerop (length string))
1215 (values :|| 0)
1216 (let ((*package* keyword-package))
1217 (ignore-errors (read-from-string string))))
1218 (if (and (or (keywordp name) (stringp name))
1219 (= (length string) pos))
1220 (find-package name))))
1221
1222 (defun guess-package-from-string (name &optional (default-package *package*))
1223 (or (and name
1224 (or (parse-package name)
1225 (find-package (string-upcase name))
1226 (parse-package (substitute #\- #\! name))))
1227 default-package))
1228
1229 (defvar *readtable-alist* (default-readtable-alist)
1230 "An alist mapping package names to readtables.")
1231
1232 (defun guess-buffer-readtable (package-name &optional (default *readtable*))
1233 (let ((package (guess-package-from-string package-name)))
1234 (if package
1235 (or (cdr (assoc (package-name package) *readtable-alist*
1236 :test #'string=))
1237 default)
1238 default)))
1239
1240 (defun valid-operator-symbol-p (symbol)
1241 "Test if SYMBOL names a function, macro, or special-operator."
1242 (or (fboundp symbol)
1243 (macro-function symbol)
1244 (special-operator-p symbol)))
1245
1246 (defun valid-operator-name-p (string)
1247 "Test if STRING names a function, macro, or special-operator."
1248 (let ((symbol (parse-symbol string)))
1249 (valid-operator-symbol-p symbol)))
1250
1251
1252 ;;;; Arglists
1253
1254 (defslimefun arglist-for-echo-area (names)
1255 "Return the arglist for the first function, macro, or special-op in NAMES."
1256 (handler-case
1257 (with-buffer-syntax ()
1258 (let ((name (find-if #'valid-operator-name-p names)))
1259 (if name (format-arglist-for-echo-area (parse-symbol name) name))))
1260 (error (cond)
1261 (format nil "ARGLIST: ~A" cond))))
1262
1263 (defun format-arglist-for-echo-area (symbol name)
1264 "Return SYMBOL's arglist as string for display in the echo area.
1265 Use the string NAME as operator name."
1266 (let ((arglist (arglist symbol)))
1267 (etypecase arglist
1268 ((member :not-available)
1269 nil)
1270 (list
1271 (let ((enriched-arglist
1272 (if (extra-keywords symbol)
1273 ;; When there are extra keywords, we decode the
1274 ;; arglist, merge in the keywords and encode it
1275 ;; again.
1276 (let ((decoded-arglist (decode-arglist arglist)))
1277 (enrich-decoded-arglist-with-extra-keywords
1278 decoded-arglist (list symbol))
1279 (encode-arglist decoded-arglist))
1280 ;; Otherwise, just use the original arglist.
1281 ;; This works better for implementation-specific
1282 ;; lambda-list-keywords like CMUCL's &parse-body.
1283 arglist)))
1284 (arglist-to-string (cons name enriched-arglist)
1285 (symbol-package symbol)))))))
1286
1287 (defun clean-arglist (arglist)
1288 "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1289 (cond ((null arglist) '())
1290 ((member (car arglist) '(&whole &environment))
1291 (clean-arglist (cddr arglist)))
1292 ((eq (car arglist) '&aux)
1293 '())
1294 (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1295
1296 (defun arglist-to-string (arglist package)
1297 "Print the list ARGLIST for display in the echo area.
1298 The argument name are printed without package qualifiers and
1299 pretty printing of (function foo) as #'foo is suppressed."
1300 (setq arglist (clean-arglist arglist))
1301 (etypecase arglist
1302 (null "()")
1303 (cons
1304 (with-output-to-string (*standard-output*)
1305 (with-standard-io-syntax
1306 (let ((*package* package) (*print-case* :downcase)
1307 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1308 (*print-level* 10) (*print-length* 20))
1309 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1310 (loop
1311 (let ((arg (pop arglist)))
1312 (etypecase arg
1313 (symbol (princ arg))
1314 (string (princ arg))
1315 (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1316 (princ (car arg))
1317 (unless (null (cdr arg))
1318 (write-char #\space))
1319 (pprint-fill *standard-output* (cdr arg) nil))))
1320 (when (null arglist) (return))
1321 (write-char #\space)
1322 (pprint-newline :fill))))))))))
1323
1324 (defun test-print-arglist (list string)
1325 (string= (arglist-to-string list (find-package :swank)) string))
1326
1327 ;; Should work:
1328 (progn
1329 (assert (test-print-arglist '(function cons) "(function cons)"))
1330 (assert (test-print-arglist '(quote cons) "(quote cons)"))
1331 (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
1332 (assert (test-print-arglist '(&whole x y z) "(y z)"))
1333 (assert (test-print-arglist '(x &aux y z) "(x)"))
1334 (assert (test-print-arglist '(x &environment env y) "(x y)")))
1335 ;; Expected failure:
1336 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
1337
1338 (defslimefun variable-desc-for-echo-area (variable-name)
1339 "Return a short description of VARIABLE-NAME, or NIL."
1340 (with-buffer-syntax ()
1341 (let ((sym (parse-symbol variable-name)))
1342 (if (and sym (boundp sym))
1343 (let ((*print-pretty* nil) (*print-level* 4)
1344 (*print-length* 10) (*print-circle* t))
1345 (format nil "~A => ~A" sym (symbol-value sym)))))))
1346
1347 (defstruct (keyword-arg
1348 (:conc-name keyword-arg.)
1349 (:constructor make-keyword-arg (keyword arg-name default-arg)))
1350 keyword
1351 arg-name
1352 default-arg)
1353
1354 (defun decode-keyword-arg (arg)
1355 "Decode a keyword item of formal argument list.
1356 Return three values: keyword, argument name, default arg."
1357 (cond ((symbolp arg)
1358 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1359 arg
1360 nil))
1361 ((and (consp arg)
1362 (consp (car arg)))
1363 (make-keyword-arg (caar arg)
1364 (cadar arg)
1365 (cadr arg)))
1366 ((consp arg)
1367 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1368 (car arg)
1369 (cadr arg)))
1370 (t
1371 (error "Bad keyword item of formal argument list"))))
1372
1373 (defun encode-keyword-arg (arg)
1374 (if (eql (intern (symbol-name (keyword-arg.arg-name arg))
1375 keyword-package)
1376 (keyword-arg.keyword arg))
1377 (if (keyword-arg.default-arg arg)
1378 (list (keyword-arg.arg-name arg)
1379 (keyword-arg.default-arg arg))
1380 (keyword-arg.arg-name arg))
1381 (let ((keyword/name (list (keyword-arg.arg-name arg)
1382 (keyword-arg.keyword arg))))
1383 (if (keyword-arg.default-arg arg)
1384 (list keyword/name
1385 (keyword-arg.default-arg arg))
1386 (list keyword/name)))))
1387
1388 (progn
1389 (assert (equalp (decode-keyword-arg 'x)
1390 (make-keyword-arg :x 'x nil)))
1391 (assert (equalp (decode-keyword-arg '(x t))
1392 (make-keyword-arg :x 'x t)))
1393 (assert (equalp (decode-keyword-arg '((:x y)))
1394 (make-keyword-arg :x 'y nil)))
1395 (assert (equalp (decode-keyword-arg '((:x y) t))
1396 (make-keyword-arg :x 'y t))))
1397
1398 (defstruct (optional-arg
1399 (:conc-name optional-arg.)
1400 (:constructor make-optional-arg (arg-name default-arg)))
1401 arg-name
1402 default-arg)
1403
1404 (defun decode-optional-arg (arg)
1405 "Decode an optional item of a formal argument list.
1406 Return an OPTIONAL-ARG structure."
1407 (etypecase arg
1408 (symbol (make-optional-arg arg nil))
1409 (list (make-optional-arg (car arg) (cadr arg)))))
1410
1411 (defun encode-optional-arg (optional-arg)
1412 (if (optional-arg.default-arg optional-arg)
1413 (list (optional-arg.arg-name optional-arg)
1414 (optional-arg.default-arg optional-arg))
1415 (optional-arg.arg-name optional-arg)))
1416
1417 (progn
1418 (assert (equalp (decode-optional-arg 'x)
1419 (make-optional-arg 'x nil)))
1420 (assert (equalp (decode-optional-arg '(x t))
1421 (make-optional-arg 'x t))))
1422
1423 (defstruct (arglist (:conc-name arglist.))
1424 required-args ; list of the required arguments
1425 optional-args ; list of the optional arguments
1426 key-p ; whether &key appeared
1427 keyword-args ; list of the keywords
1428 rest ; name of the &rest or &body argument (if any)
1429 body-p ; whether the rest argument is a &body
1430 allow-other-keys-p) ; whether &allow-other-keys appeared
1431
1432 (defun decode-arglist (arglist)
1433 "Parse the list ARGLIST and return an ARGLIST structure."
1434 (let ((mode nil)
1435 (result (make-arglist)))
1436 (dolist (arg arglist)
1437 (cond
1438 ((eql arg '&allow-other-keys)
1439 (setf (arglist.allow-other-keys-p result) t))
1440 ((eql arg '&key)
1441 (setf (arglist.key-p result) t
1442 mode arg))
1443 ((member arg lambda-list-keywords)
1444 (setq mode arg))
1445 (t
1446 (case mode
1447 (&key
1448 (push (decode-keyword-arg arg)
1449 (arglist.keyword-args result)))
1450 (&optional
1451 (push (decode-optional-arg arg)
1452 (arglist.optional-args result)))
1453 (&body
1454 (setf (arglist.body-p result) t
1455 (arglist.rest result) arg))
1456 (&rest
1457 (setf (arglist.rest result) arg))
1458 ((nil)
1459 (push arg (arglist.required-args result)))
1460 ((&whole &environment)
1461 (setf mode nil))))))
1462 (setf (arglist.required-args result)
1463 (nreverse (arglist.required-args result)))
1464 (setf (arglist.optional-args result)
1465 (nreverse (arglist.optional-args result)))
1466 (setf (arglist.keyword-args result)
1467 (nreverse (arglist.keyword-args result)))
1468 result))
1469
1470 (defun encode-arglist (decoded-arglist)
1471 (append (arglist.required-args decoded-arglist)
1472 (when (arglist.optional-args decoded-arglist)
1473 '(&optional))
1474 (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1475 (when (arglist.key-p decoded-arglist)
1476 '(&key))
1477 (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1478 (when (arglist.allow-other-keys-p decoded-arglist)
1479 '(&allow-other-keys))
1480 (cond ((not (arglist.rest decoded-arglist))
1481 '())
1482 ((arglist.body-p decoded-arglist)
1483 `(&body ,(arglist.rest decoded-arglist)))
1484 (t
1485 `(&rest ,(arglist.rest decoded-arglist))))))
1486
1487 (defun arglist-keywords (arglist)
1488 "Return the list of keywords in ARGLIST.
1489 As a secondary value, return whether &allow-other-keys appears."
1490 (let ((decoded-arglist (decode-arglist arglist)))
1491 (values (arglist.keyword-args decoded-arglist)
1492 (arglist.allow-other-keys-p decoded-arglist))))
1493
1494 (defun methods-keywords (methods)
1495 "Collect all keywords in the arglists of METHODS.
1496 As a secondary value, return whether &allow-other-keys appears somewhere."
1497 (let ((keywords '())
1498 (allow-other-keys nil))
1499 (dolist (method methods)
1500 (multiple-value-bind (kw aok)
1501 (arglist-keywords
1502 (swank-mop:method-lambda-list method))
1503 (setq keywords (remove-duplicates (append keywords kw)
1504 :key #'keyword-arg.keyword)
1505 allow-other-keys (or allow-other-keys aok))))
1506 (values keywords allow-other-keys)))
1507
1508 (defun generic-function-keywords (generic-function)
1509 "Collect all keywords in the methods of GENERIC-FUNCTION.
1510 As a secondary value, return whether &allow-other-keys appears somewhere."
1511 (methods-keywords
1512 (swank-mop:generic-function-methods generic-function)))
1513
1514 (defun applicable-methods-keywords (generic-function classes)
1515 "Collect all keywords in the methods of GENERIC-FUNCTION that are
1516 applicable for argument of CLASSES. As a secondary value, return
1517 whether &allow-other-keys appears somewhere."
1518 (methods-keywords
1519 (swank-mop:compute-applicable-methods-using-classes
1520 generic-function classes)))
1521
1522 (defun arglist-to-template-string (arglist package)
1523 "Print the list ARGLIST for insertion as a template for a function call."
1524 (decoded-arglist-to-template-string
1525 (decode-arglist arglist) package))
1526
1527 (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1528 (with-output-to-string (*standard-output*)
1529 (with-standard-io-syntax
1530 (let ((*package* package) (*print-case* :downcase)
1531 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1532 (*print-level* 10) (*print-length* 20))
1533 (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1534 (print-decoded-arglist-as-template decoded-arglist))))))
1535
1536 (defun print-decoded-arglist-as-template (decoded-arglist)
1537 (let ((first-p t))
1538 (flet ((space ()
1539 (unless first-p
1540 (write-char #\space)
1541 (pprint-newline :fill))
1542 (setq first-p nil)))
1543 (dolist (arg (arglist.required-args decoded-arglist))
1544 (space)
1545 (princ arg))
1546 (dolist (arg (arglist.optional-args decoded-arglist))
1547 (space)
1548 (format t "[~A]" (optional-arg.arg-name arg)))
1549 (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1550 (space)
1551 (let ((arg-name (keyword-arg.arg-name keyword-arg))
1552 (keyword (keyword-arg.keyword keyword-arg)))
1553 (format t "~W ~A"
1554 (if (keywordp keyword) keyword `',keyword)
1555 arg-name)))
1556 (when (and (arglist.rest decoded-arglist)
1557 (or (not (arglist.keyword-args decoded-arglist))
1558 (arglist.allow-other-keys-p decoded-arglist)))
1559 (if (arglist.body-p decoded-arglist)
1560 (pprint-newline :mandatory)
1561 (space))
1562 (format t "~A..." (arglist.rest decoded-arglist)))))
1563 (pprint-newline :fill))
1564
1565 (defgeneric extra-keywords (operator &rest args)
1566 (:documentation "Return a list of extra keywords of OPERATOR (a
1567 symbol) when applied to the (unevaluated) ARGS. As a secondary value,
1568 return whether other keys are allowed."))
1569
1570 (defmethod extra-keywords (operator &rest args)
1571 ;; default method
1572 (declare (ignore args))
1573 (let ((symbol-function (symbol-function operator)))
1574 (if (typep symbol-function 'generic-function)
1575 (generic-function-keywords symbol-function)
1576 nil)))
1577
1578 (defmethod extra-keywords ((operator (eql 'make-instance))
1579 &rest args)
1580 (unless (null args)
1581 (let ((class-name-form (car args)))
1582 (when (and (listp class-name-form)
1583 (= (length class-name-form) 2)
1584 (eq (car class-name-form) 'quote))
1585 (let* ((class-name (cadr class-name-form))
1586 (class (find-class class-name nil)))
1587 (unless (swank-mop:class-finalized-p class)
1588 ;; Try to finalize the class, which can fail if
1589 ;; superclasses are not defined yet
1590 (handler-case (swank-mop:finalize-inheritance class)
1591 (program-error (c)
1592 (declare (ignore c)))))
1593 (when class
1594 ;; We have the case (make-instance 'CLASS ...)
1595 ;; with a known CLASS.
1596 (multiple-value-bind (slots allow-other-keys-p)
1597 (if (swank-mop:class-finalized-p class)
1598 (values (swank-mop:class-slots class) nil)
1599 (values (swank-mop:class-direct-slots class) t))
1600 (let ((slot-init-keywords
1601 (loop for slot in slots append
1602 (mapcar (lambda (initarg)
1603 (make-keyword-arg
1604 initarg
1605 initarg ; FIXME
1606 (swank-mop:slot-definition-initform slot)))
1607 (swank-mop:slot-definition-initargs slot))))
1608 (initialize-instance-keywords
1609 (applicable-methods-keywords #'initialize-instance
1610 (list class))))
1611 (return-from extra-keywords
1612 (values (append slot-init-keywords
1613 initialize-instance-keywords)
1614 allow-other-keys-p)))))))))
1615 (call-next-method))
1616
1617 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
1618 (multiple-value-bind (extra-keywords extra-aok)
1619 (apply #'extra-keywords form)
1620 ;; enrich the list of keywords with the extra keywords
1621 (when extra-keywords
1622 (setf (arglist.key-p decoded-arglist) t)
1623 (setf (arglist.keyword-args decoded-arglist)
1624 (remove-duplicates
1625 (append (arglist.keyword-args decoded-arglist)
1626 extra-keywords)
1627 :key #'keyword-arg.keyword)))
1628 (setf (arglist.allow-other-keys-p decoded-arglist)
1629 (or (arglist.allow-other-keys-p decoded-arglist) extra-aok)))
1630 decoded-arglist)
1631
1632 (defslimefun arglist-for-insertion (name)
1633 (with-buffer-syntax ()
1634 (let ((symbol (parse-symbol name)))
1635 (cond
1636 ((and symbol
1637 (valid-operator-name-p name))
1638 (let ((arglist (arglist symbol)))
1639 (etypecase arglist
1640 ((member :not-available)
1641 :not-available)
1642 (list
1643 (let ((decoded-arglist (decode-arglist arglist)))
1644 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
1645 (list symbol))
1646 (decoded-arglist-to-template-string decoded-arglist
1647 *buffer-package*))))))
1648 (t
1649 :not-available)))))
1650
1651 (defvar *remove-keywords-alist*
1652 '((:test :test-not)
1653 (:test-not :test)))
1654
1655 (defun remove-actual-args (decoded-arglist actual-arglist)
1656 "Remove from DECODED-ARGLIST the arguments that have already been
1657 provided in ACTUAL-ARGLIST."
1658 (loop while (and actual-arglist
1659 (arglist.required-args decoded-arglist))
1660 do (progn (pop actual-arglist)
1661 (pop (arglist.required-args decoded-arglist))))
1662 (loop while (and actual-arglist
1663 (arglist.optional-args decoded-arglist))
1664 do (progn (pop actual-arglist)
1665 (pop (arglist.optional-args decoded-arglist))))
1666 (loop for keyword in actual-arglist by #'cddr
1667 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
1668 do (setf (arglist.keyword-args decoded-arglist)
1669 (remove-if (lambda (kw)
1670 (or (eql kw keyword)
1671 (member kw keywords-to-remove)))
1672 (arglist.keyword-args decoded-arglist)
1673 :key #'keyword-arg.keyword))))
1674
1675 (defgeneric form-completion (operator-form &rest argument-forms))
1676
1677 (defmethod form-completion (operator-form &rest argument-forms)
1678 (when (and (symbolp operator-form)
1679 (valid-operator-symbol-p operator-form))
1680 (let ((arglist (arglist operator-form)))
1681 (etypecase arglist
1682 ((member :not-available)
1683 :not-available)
1684 (list
1685 (let ((decoded-arglist (decode-arglist arglist)))
1686 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
1687 (cons operator-form
1688 argument-forms))
1689 ;; get rid of formal args already provided
1690 (remove-actual-args decoded-arglist argument-forms)
1691 (return-from form-completion decoded-arglist))))))
1692 :not-available)
1693
1694 (defmethod form-completion ((operator-form (eql 'defmethod))
1695 &rest argument-forms)
1696 (when (and (listp argument-forms)
1697 (not (null argument-forms)) ;have generic function name
1698 (notany #'listp (rest argument-forms))) ;don't have arglist yet
1699 (let* ((gf-name (first argument-forms))
1700 (gf (and (or (symbolp gf-name)
1701 (and (listp gf-name)
1702 (eql (first gf-name) 'setf)))
1703 (fboundp gf-name)
1704 (fdefinition gf-name))))
1705 (when (typep gf 'generic-function)
1706 (let ((arglist (arglist gf)))
1707 (etypecase arglist
1708 ((member :not-available))
1709 (list
1710 (return-from form-completion
1711 (make-arglist :required-args (list arglist)
1712 :rest "body" :body-p t))))))))
1713 (call-next-method))
1714
1715 (defslimefun complete-form (form-string)
1716 "Read FORM-STRING in the current buffer package, then complete it
1717 by adding a template for the missing arguments."
1718 (with-buffer-syntax ()
1719 (handler-case
1720 (let ((form (read-from-string form-string)))
1721 (when (consp form)
1722 (let ((operator-form (first form))
1723 (argument-forms (rest form)))
1724 (let ((form-completion
1725 (apply #'form-completion operator-form argument-forms)))
1726 (unless (eql form-completion :not-available)
1727 (return-from complete-form
1728 (decoded-arglist-to-template-string form-completion
1729 *buffer-package*
1730 :prefix ""))))))
1731 :not-available)
1732 (reader-error (c)
1733 (declare (ignore c))
1734 :not-available))))
1735
1736
1737 ;;;; Recording and accessing results of computations
1738
1739 (defvar *record-repl-results* t
1740 "Non-nil means that REPL results are saved for later lookup.")
1741
1742 (defvar *object-to-presentation-id*
1743 (make-weak-key-hash-table :test 'eq)
1744 "Store the mapping of objects to numeric identifiers")
1745
1746 (defvar *presentation-id-to-object*
1747 (make-weak-value-hash-table :test 'eql)
1748 "Store the mapping of numeric identifiers to objects")
1749
1750 (defun clear-presentation-tables ()
1751 (clrhash *object-to-presentation-id*)
1752 (clrhash *presentation-id-to-object*))
1753
1754 (defvar *presentation-counter* 0 "identifier counter")
1755
1756 ;; XXX thread safety?
1757 (defun save-presented-object (object)
1758 "Save OBJECT and return the assigned id.
1759 If OBJECT was saved previously return the old id."
1760 (or (gethash object *object-to-presentation-id*)
1761 (let ((id (decf *presentation-counter*)))
1762 (setf (gethash id *presentation-id-to-object*) object)
1763 (setf (gethash object *object-to-presentation-id*) id)
1764 id)))
1765
1766 (defun lookup-presented-object (id)
1767 "Retrieve the object corresponding to ID.
1768 The secondary value indicates the absence of an entry."
1769 (gethash id *presentation-id-to-object*))
1770
1771 (defslimefun get-repl-result (id)
1772 "Get the result of the previous REPL evaluation with ID."
1773 (multiple-value-bind (object foundp) (lookup-presented-object id)
1774 (cond (foundp object)
1775 (t (error "Attempt to access unrecorded object (id ~D)." id)))))
1776
1777 (defslimefun clear-repl-results ()
1778 "Forget the results of all previous REPL evaluations."
1779 (clear-presentation-tables)
1780 t)
1781
1782
1783 ;;;; Evaluation
1784
1785 (defvar *pending-continuations* '()
1786 "List of continuations for Emacs. (thread local)")
1787
1788 (defun guess-buffer-package (string)
1789 "Return a package for STRING.
1790 Fall back to the the current if no such package exists."
1791 (or (guess-package-from-string string nil)
1792 *package*))
1793
1794 (defun eval-for-emacs (form buffer-package id)
1795 "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
1796 Return the result to the continuation ID.
1797 Errors are trapped and invoke our debugger."
1798 (call-with-debugger-hook
1799 #'swank-debugger-hook
1800 (lambda ()
1801 (let (ok result)
1802 (unwind-protect
1803 (let ((*buffer-package* (guess-buffer-package buffer-package))
1804 (*buffer-readtable* (guess-buffer-readtable buffer-package))
1805 (*pending-continuations* (cons id *pending-continuations*)))
1806 (check-type *buffer-package* package)
1807 (check-type *buffer-readtable* readtable)
1808 (setq result (eval form))
1809 (finish-output)
1810 (run-hook *pre-reply-hook*)
1811 (setq ok t))
1812 (force-user-output)
1813 (send-to-emacs `(:return ,(current-thread)
1814 ,(if ok `(:ok ,result) '(:abort))
1815 ,id)))))))
1816
1817 (defvar *echo-area-prefix* "=> "
1818 "A prefix that `format-values-for-echo-area' should use.")
1819
1820 (defun format-values-for-echo-area (values)
1821 (with-buffer-syntax ()
1822 (let ((*print-readably* nil))
1823 (cond ((null values) "; No value")
1824 ((and (null (cdr values)) (integerp (car values)))
1825 (let ((i (car values)))
1826 (format nil "~A~D (#x~X, #o~O, #b~B)"
1827 *echo-area-prefix* i i i i)))
1828 (t (format nil "~A~{~S~^, ~}" *echo-area-prefix* values))))))
1829
1830 (defslimefun interactive-eval (string)
1831 (with-buffer-syntax ()
1832 (let ((values (multiple-value-list (eval (from-string string)))))
1833 (fresh-line)
1834 (finish-output)
1835 (format-values-for-echo-area values))))
1836
1837 (defslimefun eval-and-grab-output (string)
1838 (with-buffer-syntax ()
1839 (let* ((s (make-string-output-stream))
1840 (*standard-output* s)
1841 (values (multiple-value-list (eval (from-string string)))))
1842 (list (get-output-stream-string s)
1843 (format nil "~{~S~^~%~}" values)))))
1844
1845 ;;; XXX do we need this stuff? What is it good for?
1846 (defvar *slime-repl-advance-history* nil
1847 "In the dynamic scope of a single form typed at the repl, is set to nil to
1848 prevent the repl from advancing the history - * ** *** etc.")
1849
1850 (defvar *slime-repl-suppress-output* nil
1851 "In the dynamic scope of a single form typed at the repl, is set to nil to
1852 prevent the repl from printing the result of the evalation.")
1853
1854 (defvar *slime-repl-eval-hook-pass* (gensym "PASS")
1855 "Token to indicate that a repl hook declines to evaluate the form")
1856
1857 (defvar *slime-repl-eval-hooks* nil
1858 "A list of functions. When the repl is about to eval a form, first try running each of
1859 these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
1860 is considered a replacement for calling eval. If there are no hooks, or all
1861 pass, then eval is used.")
1862
1863 (defslimefun repl-eval-hook-pass ()
1864 "call when repl hook declines to evaluate the form"
1865 (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
1866
1867 (defslimefun repl-suppress-output ()
1868 "In the dynamic scope of a single form typed at the repl, call to
1869 prevent the repl from printing the result of the evalation."
1870 (setq *slime-repl-suppress-output* t))
1871
1872 (defslimefun repl-suppress-advance-history ()
1873 "In the dynamic scope of a single form typed at the repl, call to
1874 prevent the repl from advancing the history - * ** *** etc."
1875 (setq *slime-repl-advance-history* nil))
1876
1877 (defun eval-region (string &optional package-update-p)
1878 "Evaluate STRING and return the result.
1879 If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
1880 change, then send Emacs an update."
1881 (unwind-protect
1882 (with-input-from-string (stream string)
1883 (let (- values)
1884 (loop
1885 (let ((form (read stream nil stream)))
1886 (when (eq form stream)
1887 (fresh-line)
1888 (finish-output)
1889 (return (values values -)))
1890 (setq - form)
1891 (if *slime-repl-eval-hooks*
1892 (setq values (run-repl-eval-hooks form))
1893 (setq values (multiple-value-list (eval form))))
1894 (finish-output)))))
1895 (when (and package-update-p (not (eq *package* *buffer-package*)))
1896 (send-to-emacs
1897 (list :new-package (package-name *package*)
1898 (package-string-for-prompt *package*))))))
1899
1900 (defun run-repl-eval-hooks (form)
1901 (loop for hook in *slime-repl-eval-hooks*
1902 for res = (catch *slime-repl-eval-hook-pass*
1903 (multiple-value-list (funcall hook form)))
1904 until (not (eq res *slime-repl-eval-hook-pass*))
1905 finally (return
1906 (if (eq res *slime-repl-eval-hook-pass*)
1907 (multiple-value-list (eval form))
1908 res))))
1909
1910 (defun package-string-for-prompt (package)
1911 "Return the shortest nickname (or canonical name) of PACKAGE."
1912 (princ-to-string
1913 (make-symbol
1914 (or (canonical-package-nickname package)
1915 (auto-abbreviated-package-name package)
1916 (shortest-package-nickname package)))))
1917
1918 (defun canonical-package-nickname (package)
1919 "Return the canonical package nickname, if any, of PACKAGE."
1920 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
1921 :test #'string=))))
1922 (and name (string name))))
1923
1924 (defun auto-abbreviated-package-name (package)
1925 "Return an abbreviated 'name' for PACKAGE.
1926
1927 N.B. this is not an actual package name or nickname."
1928 (when *auto-abbreviate-dotted-packages*
1929 (let ((last-dot (position #\. (package-name package) :from-end t)))
1930 (when last-dot (subseq (package-name package) (1+ last-dot))))))
1931
1932 (defun shortest-package-nickname (package)
1933 "Return the shortest nickname (or canonical name) of PACKAGE."
1934 (loop for name in (cons (package-name package) (package-nicknames package))
1935 for shortest = name then (if (< (length name) (length shortest))
1936 name
1937 shortest)
1938 finally (return shortest)))
1939
1940 (defslimefun interactive-eval-region (string)
1941 (with-buffer-syntax ()
1942 (format-values-for-echo-area (eval-region string))))
1943
1944 (defslimefun re-evaluate-defvar (form)
1945 (with-buffer-syntax ()
1946 (let ((form (read-from-string form)))
1947 (destructuring-bind (dv name &optional value doc) form
1948 (declare (ignore value doc))
1949 (assert (eq dv 'defvar))
1950 (makunbound name)
1951 (prin1-to-string (eval form))))))
1952
1953 (defvar *swank-pprint-bindings*
1954 `((*print-pretty* . t)
1955 (*print-level* . nil)
1956 (*print-length* . nil)
1957 (*print-circle* . t)
1958 (*print-gensym* . t)
1959 (*print-readably* . nil))
1960 "A list of variables bindings during pretty printing.
1961 Used by pprint-eval.")
1962
1963 (defun swank-pprint (list)
1964 "Bind some printer variables and pretty print each object in LIST."
1965 (with-buffer-syntax ()
1966 (with-bindings *swank-pprint-bindings*
1967 (cond ((null list) "; No value")
1968 (t (with-output-to-string (*standard-output*)
1969 (dolist (o list)
1970 (pprint o)
1971 (terpri))))))))
1972
1973 (defslimefun pprint-eval (string)
1974 (with-buffer-syntax ()
1975 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1976
1977 (defslimefun set-package (package)
1978 "Set *package* to PACKAGE.
1979 Return its name and the string to use in the prompt."
1980 (let ((p (setq *package* (guess-package-from-string package))))
1981 (list (package-name p) (package-string-for-prompt p))))
1982
1983 (defslimefun listener-eval (string)
1984 (clear-user-input)
1985 (with-buffer-syntax ()
1986 (let ((*slime-repl-suppress-output* :unset)
1987 (*slime-repl-advance-history* :unset))
1988 (multiple-value-bind (values last-form) (eval-region string t)
1989 (unless (or (and (eq values nil) (eq last-form nil))
1990 (eq *slime-repl-advance-history* nil))
1991 (setq *** ** ** * * (car values)
1992 /// // // / / values))
1993 (setq +++ ++ ++ + + last-form)
1994 (cond ((eq *slime-repl-suppress-output* t) '(:suppress-output))
1995 (*record-repl-results*
1996 `(:present ,(loop for x in values
1997 collect (cons (prin1-to-string x)
1998 (save-presented-object x)))))
1999 (t
2000 `(:values ,(mapcar #'prin1-to-string values))))))))
2001
2002 (defslimefun ed-in-emacs (&optional what)
2003 "Edit WHAT in Emacs.
2004
2005 WHAT can be:
2006 A pathname or a string,
2007 A list (PATHNAME-OR-STRING LINE [COLUMN]),
2008 A function name (symbol),
2009 NIL.
2010
2011 Returns true if it actually called emacs, or NIL if not."
2012 (flet ((pathname-or-string-p (thing)
2013 (or (pathnamep thing) (typep thing 'string))))
2014 (let ((target
2015 (cond ((and (listp what) (pathname-or-string-p (first what)))
2016 (cons (canonicalize-filename (car what)) (cdr what)))
2017 ((pathname-or-string-p what)
2018 (canonicalize-filename what))
2019 ((symbolp what) what)
2020 (t (return-from ed-in-emacs nil)))))
2021 (send-oob-to-emacs `(:ed ,target))
2022 t)))
2023
2024 (defslimefun value-for-editing (form)
2025 "Return a readable value of FORM for editing in Emacs.
2026 FORM is expected, but not required, to be SETF'able."
2027 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2028 (with-buffer-syntax ()
2029 (prin1-to-string (eval (read-from-string form)))))
2030
2031 (defslimefun commit-edited-value (form value)
2032 "Set the value of a setf'able FORM to VALUE.
2033 FORM and VALUE are both strings from Emacs."
2034 (with-buffer-syntax ()
2035 (eval `(setf ,(read-from-string form)
2036 ,(read-from-string (concatenate 'string "`" value))))
2037 t))
2038
2039 (defun background-message (format-string &rest args)
2040 "Display a message in Emacs' echo area.
2041
2042 Use this function for informative messages only. The message may even
2043 be dropped, if we are too busy with other things."
2044 (when *emacs-connection*
2045 (send-to-emacs `(:background-message
2046 ,(apply #'format nil format-string args)))))
2047
2048
2049 ;;;; Debugger
2050
2051 (defun swank-debugger-hook (condition hook)
2052 "Debugger function for binding *DEBUGGER-HOOK*.
2053 Sends a message to Emacs declaring that the debugger has been entered,
2054 then waits to handle further requests from Emacs. Eventually returns
2055 after Emacs causes a restart to be invoked."
2056 (declare (ignore hook))
2057 (cond (*emacs-connection*
2058 (debug-in-emacs condition))
2059 ((default-connection)
2060 (with-connection ((default-connection))
2061 (debug-in-emacs condition)))))
2062
2063 (defvar *global-debugger* t
2064 "Non-nil means the Swank debugger hook will be installed globally.")
2065
2066 (add-hook *new-connection-hook* 'install-debugger)
2067 (defun install-debugger (connection)
2068 (declare (ignore connection))
2069 (when *global-debugger*
2070 (install-debugger-globally #'swank-debugger-hook)))
2071
2072 ;;;;; Debugger loop
2073 ;;;
2074 ;;; These variables are dynamically bound during debugging.
2075 ;;;
2076 (defvar *swank-debugger-condition* nil
2077 "The condition being debugged.")
2078
2079 (defvar *sldb-level* 0
2080 "The current level of recursive debugging.")
2081
2082 (defvar *sldb-initial-frames* 20
2083 "The initial number of backtrace frames to send to Emacs.")
2084
2085 (defvar *sldb-restarts* nil
2086 "The list of currenlty active restarts.")
2087
2088 (defvar *sldb-stepping-p* nil
2089 "True when during execution of a stepp command.")
2090
2091 (defun debug-in-emacs (condition)
2092 (let ((*swank-debugger-condition* condition)
2093 (*sldb-restarts* (compute-restarts condition))
2094 (*package* (or (and (boundp '*buffer-package*)
2095 (symbol-value '*buffer-package*))
2096 *package*))
2097 (*sldb-level* (1+ *sldb-level*))
2098 (*sldb-stepping-p* nil)
2099 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2100 (force-user-output)
2101 (with-bindings *sldb-printer-bindings*
2102 (call-with-debugging-environment
2103 (lambda () (sldb-loop *sldb-level*))))))
2104
2105 (defun sldb-loop (level)
2106 (unwind-protect
2107 (catch 'sldb-enter-default-debugger
2108 (send-to-emacs
2109 (list* :debug (current-thread) level
2110 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2111 (loop (catch 'sldb-loop-catcher
2112 (with-simple-restart (abort "Return to sldb level ~D." level)
2113 (send-to-emacs (list :debug-activate (current-thread)
2114 level))
2115 (handler-bind ((sldb-condition #'handle-sldb-condition))
2116 (read-from-emacs))))))
2117 (send-to-emacs `(:debug-return
2118 ,(current-thread) ,level ,*sldb-stepping-p*))))
2119
2120 (defun handle-sldb-condition (condition)
2121 "Handle an internal debugger condition.
2122 Rather than recursively debug the debugger (a dangerous idea!), these
2123 conditions are simply reported."
2124 (let ((real-condition (original-condition condition)))
2125 (send-to-emacs `(:debug-condition ,(current-thread)
2126 ,(princ-to-string real-condition))))
2127 (throw 'sldb-loop-catcher nil))
2128
2129 (defun safe-condition-message (condition)
2130 "Safely print condition to a string, handling any errors during
2131 printing."
2132 (let ((*print-pretty* t))
2133 (handler-case
2134 (format-sldb-condition condition)
2135 (error (cond)
2136 ;; Beware of recursive errors in printing, so only use the condition
2137 ;; if it is printable itself:
2138 (format nil "Unable to display error condition~@[: ~A~]"
2139 (ignore-errors (princ-to-string cond)))))))
2140
2141 (defun debugger-condition-for-emacs ()
2142 (list (safe-condition-message *swank-debugger-condition*)
2143 (format nil " [Condition of type ~S]"
2144 (type-of *swank-debugger-condition*))
2145 (condition-references *swank-debugger-condition*)
2146 (condition-extras *swank-debugger-condition*)))
2147
2148 (defun format-restarts-for-emacs ()
2149 "Return a list of restarts for *swank-debugger-condition* in a
2150 format suitable for Emacs."
2151 (loop for restart in *sldb-restarts*
2152 collect (list (princ-to-string (restart-name restart))
2153 (princ-to-string restart))))
2154
2155 (defun frame-for-emacs (n frame)
2156 (let* ((label (format nil " ~2D: " n))
2157 (string (with-output-to-string (stream)
2158 (princ label stream)
2159 (print-frame frame stream))))
2160 (subseq string (length label))))
2161
2162 ;;;;; SLDB entry points
2163
2164 (defslimefun sldb-break-with-default-debugger ()
2165 "Invoke the default debugger by returning from our debugger-loop."
2166 (throw 'sldb-enter-default-debugger nil))
2167
2168 (defslimefun backtrace (start end)
2169 "Return a list ((I FRAME) ...) of frames from START to END.
2170 I is an integer describing and FRAME a string."
2171 (loop for frame in (compute-backtrace start end)
2172 for i from start
2173 collect (list i (frame-for-emacs i frame))))
2174
2175 (defslimefun debugger-info-for-emacs (start end)
2176 "Return debugger state, with stack frames from START to END.
2177 The result is a list:
2178 (condition ({restart}*) ({stack-frame}*) (cont*))
2179 where
2180 condition ::= (description type [extra])
2181 restart ::= (name description)
2182 stack-frame ::= (number description)
2183 extra ::= (:references and other random things)
2184 cont ::= continutation
2185 condition---a pair of strings: message, and type. If show-source is
2186 not nil it is a frame number for which the source should be displayed.
2187
2188 restart---a pair of strings: restart name, and description.
2189
2190 stack-frame---a number from zero (the top), and a printed
2191 representation of the frame's call.
2192
2193 continutation---the id of a pending Emacs continuation.
2194
2195 Below is an example return value. In this case the condition was a
2196 division by zero (multi-line description), and only one frame is being
2197 fetched (start=0, end=1).
2198
2199 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2200 Operation was KERNEL::DIVISION, operands (1 0).\"
2201 \"[Condition of type DIVISION-BY-ZERO]\")
2202 ((\"ABORT\" \"Return to Slime toplevel.\")
2203 (\"ABORT\" \"Return to Top-Level.\"))
2204 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2205 (4))"
2206 (list (debugger-condition-for-emacs)
2207 (format-restarts-for-emacs)
2208 (backtrace start end)
2209 *pending-continuations*))
2210
2211 (defun nth-restart (index)
2212 (nth index *sldb-restarts*))
2213
2214 (defslimefun invoke-nth-restart (index)
2215 (invoke-restart-interactively (nth-restart index)))
2216
2217 (defslimefun sldb-abort ()
2218 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2219
2220 (defslimefun sldb-continue ()
2221 (continue))
2222
2223 (defslimefun throw-to-toplevel ()
2224 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2225 If we are not evaluating an RPC then ABORT instead."
2226 (let ((restart (find-restart 'abort-request)))
2227 (cond (restart (invoke-restart restart))
2228 (t
2229 ;; If we get here then there was no catch. Try aborting as
2230 ;; a fallback. That makes the 'q' command in SLDB safer to
2231 ;; use with threads.
2232 (abort)))))
2233
2234 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2235 "Invoke the Nth available restart.
2236 SLDB-LEVEL is the debug level when the request was made. If this
2237 has changed, ignore the request."
2238 (when (= sldb-level *sldb-level*)
2239 (invoke-nth-restart n)))
2240
2241 (defun wrap-sldb-vars (form)
2242 `(let ((*sldb-level* ,*sldb-level*))
2243 ,form))
2244
2245 (defslimefun eval-string-in-frame (string index)
2246 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
2247 index)))
2248
2249 (defslimefun pprint-eval-string-in-frame (string index)
2250 (swank-pprint
2251 (multiple-value-list
2252 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
2253
2254 (defslimefun frame-locals-for-emacs (index)
2255 "Return a property list ((&key NAME ID VALUE) ...) describing
2256 the local variables in the frame INDEX."
2257 (mapcar (lambda (frame-locals)
2258 (destructuring-bind (&key name id value) frame-locals
2259 (list :name (prin1-to-string name) :id id
2260 :value (to-string value))))
2261 (frame-locals index)))
2262
2263 (defslimefun frame-catch-tags-for-emacs (frame-index)
2264 (mapcar #'to-string (frame-catch-tags frame-index)))
2265
2266 (defslimefun sldb-disassemble (index)
2267 (with-output-to-string (*standard-output*)
2268 (disassemble-frame index)))
2269
2270 (defslimefun sldb-return-from-frame (index string)
2271 (let ((form (from-string string)))
2272 (to-string (multiple-value-list (return-from-frame index form)))))
2273
2274 (defslimefun sldb-break (name)
2275 (with-buffer-syntax ()
2276 (sldb-break-at-start (read-from-string name))))
2277
2278 (defslimefun sldb-step (frame)
2279 (cond ((find-restart 'continue)
2280 (activate-stepping frame)
2281 (setq *sldb-stepping-p* t)
2282 (continue))
2283 (t
2284 (error "No continue restart."))))
2285
2286
2287 ;;;; Compilation Commands.
2288
2289 (defvar *compiler-notes* '()
2290 "List of compiler notes for the last compilation unit.")
2291
2292 (defun clear-compiler-notes ()
2293 (setf *compiler-notes* '()))
2294
2295 (defun canonicalize-filename (filename)
2296 (namestring (truename filename)))
2297
2298 (defslimefun compiler-notes-for-emacs ()
2299 "Return the list of compiler notes for the last compilation unit."
2300 (reverse *compiler-notes*))
2301
2302 (defun measure-time-interval (fn)
2303 "Call FN and return the first return value and the elapsed time.
2304 The time is measured in microseconds."
2305 (declare (type function fn))
2306 (let ((before (get-internal-real-time)))
2307 (values
2308 (funcall fn)
2309 (* (- (get-internal-real-time) before)
2310 (/ 1000000 internal-time-units-per-second)))))
2311
2312 (defun record-note-for-condition (condition)
2313 "Record a note for a compiler-condition."
2314 (push (make-compiler-note condition) *compiler-notes*))
2315
2316 (defun make-compiler-note (condition)
2317 "Make a compiler note data structure from a compiler-condition."
2318 (declare (type compiler-condition condition))
2319 (list* :message (message condition)
2320 :severity (severity condition)
2321 :location (location condition)
2322 :references (references condition)
2323 (let ((s (short-message condition)))
2324 (if s (list :short-message s)))))
2325
2326 (defun swank-compiler (function)
2327 (clear-compiler-notes)
2328 (with-simple-restart (abort "Abort SLIME compilation.")
2329 (multiple-value-bind (result usecs)
2330 (handler-bind ((compiler-condition #'record-note-for-condition))
2331 (measure-time-interval function))
2332 (list (to-string result)
2333 (format nil "~,2F" (/ usecs 1000000.0))))))
2334
2335 (defslimefun compile-file-for-emacs (filename load-p &optional external-format)
2336 "Compile FILENAME and, when LOAD-P, load the result.
2337 Record compiler notes signalled as `compiler-condition's."
2338 (with-buffer-syntax ()
2339 (let ((*compile-print* nil))
2340 (swank-compiler (lambda () (swank-compile-file filename load-p
2341 external-format))))))
2342
2343 (defslimefun compile-string-for-emacs (string buffer position directory)
2344 "Compile STRING (exerpted from BUFFER at POSITION).
2345 Record compiler notes signalled as `compiler-condition's."
2346 (with-buffer-syntax ()
2347 (swank-compiler
2348 (lambda ()
2349 (let ((*compile-print* nil) (*compile-verbose* t))
2350 (swank-compile-string string :buffer buffer :position position
2351 :directory directory))))))
2352
2353 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
2354 "Compile and load SYSTEM using ASDF.
2355 Record compiler notes signalled as `compiler-condition's."
2356 (swank-compiler
2357 (lambda ()
2358 (apply #'operate-on-system system-name operation keywords))))
2359
2360 (defun asdf-central-registry ()
2361 (when (find-package :asdf)
2362 (symbol-value (find-symbol (string :*central-registry*) :asdf))))
2363
2364 (defslimefun list-all-systems-in-central-registry ()
2365 "Returns a list of all systems in ASDF's central registry."
2366 (delete-duplicates
2367 (loop for dir in (asdf-central-registry)
2368 for defaults = (eval dir)
2369 when defaults
2370 nconc (mapcar #'file-namestring
2371 (directory
2372 (make-pathname :defaults defaults
2373 :version :newest
2374 :type "asd"
2375 :name :wild
2376 :case :local))))
2377 :test #'string=))
2378
2379 (defun file-newer-p (new-file old-file)
2380 "Returns true if NEW-FILE is newer than OLD-FILE."
2381 (> (file-write-date new-file) (file-write-date old-file)))
2382
2383 (defun requires-compile-p (source-file)
2384 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
2385 (or (not fasl-file)
2386 (file-newer-p source-file fasl-file))))
2387
2388 (defslimefun compile-file-if-needed (filename loadp)
2389 (cond ((requires-compile-p filename)
2390 (compile-file-for-emacs filename loadp))
2391 (loadp
2392 (load (compile-file-pathname filename))
2393 nil)))
2394
2395
2396 ;;;; Loading
2397
2398 (defslimefun load-file (filename)
2399 (to-string (load filename)))
2400
2401 (defslimefun load-file-set-package (filename &optional package)
2402 (load-file filename)
2403 (if package
2404 (set-package package)))
2405
2406
2407 ;;;; Macroexpansion
2408
2409 (defvar *macroexpand-printer-bindings*
2410 '((*print-circle* . nil)
2411 (*print-pretty* . t)
2412 (*print-escape* . t)
2413 (*print-level* . nil)
2414 (*print-length* . nil)))
2415
2416 (defun apply-macro-expander (expander string)
2417 (declare (type function expander))
2418 (with-buffer-syntax ()
2419 (with-bindings *macroexpand-printer-bindings*
2420 (prin1-to-string (funcall expander (from-string string))))))
2421
2422 (defslimefun swank-macroexpand-1 (string)
2423 (apply-macro-expander #'macroexpand-1 string))
2424
2425 (defslimefun swank-macroexpand (string)
2426 (apply-macro-expander #'macroexpand string))
2427
2428 (defslimefun swank-macroexpand-all (string)
2429 (apply-macro-expander #'macroexpand-all string))
2430
2431 (defslimefun disassemble-symbol (name)
2432 (with-buffer-syntax ()
2433 (with-output-to-string (*standard-output*)
2434 (let ((*print-readably* nil))
2435 (disassemble (fdefinition (from-string name)))))))
2436
2437
2438 ;;;; Basic completion
2439
2440 (defslimefun completions (string default-package-name)
2441 "Return a list of completions for a symbol designator STRING.
2442
2443 The result is the list (COMPLETION-SET
2444 COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
2445 completions, and COMPLETED-PREFIX is the best (partial)
2446 completion of the input string.
2447
2448 If STRING is package qualified the result list will also be
2449 qualified. If string is non-qualified the result strings are
2450 also not qualified and are considered relative to
2451 DEFAULT-PACKAGE-NAME.
2452
2453 The way symbols are matched depends on the symbol designator's
2454 format. The cases are as follows:
2455 FOO - Symbols with matching prefix and accessible in the buffer package.
2456 PKG:FOO - Symbols with matching prefix and external in package PKG.
2457 PKG::FOO - Symbols with matching prefix and accessible in package PKG."
2458 (let ((completion-set (completion-set string default-package-name
2459 #'compound-prefix-match)))
2460 (list completion-set (longest-completion completion-set))))
2461
2462 (defslimefun simple-completions (string default-package-name)
2463 "Return a list of completions for a symbol designator STRING."
2464 (let ((completion-set (completion-set string default-package-name
2465 #'prefix-match-p)))
2466 (list completion-set (longest-common-prefix completion-set))))
2467
2468 ;;;;; Find completion set
2469
2470 (defun completion-set (string default-package-name matchp)
2471 "Return the set of completion-candidates as strings."
2472 (multiple-value-bind (name package-name package internal-p)
2473 (parse-completion-arguments string default-package-name)
2474 (let* ((symbols (and package
2475 (find-matching-symbols name
2476 package
2477 (and (not internal-p)
2478 package-name)
2479 matchp)))
2480 (packs (and (not package-name)
2481 (find-matching-packages name matchp)))
2482 (converter (output-case-converter name))
2483 (strings
2484 (mapcar converter
2485 (nconc (mapcar #'symbol-name symbols) packs))))
2486 (format-completion-set strings internal-p package-name))))
2487
2488 (defun find-matching-symbols (string package external test)
2489 "Return a list of symbols in PACKAGE matching STRING.
2490 TEST is called with two strings. If EXTERNAL is true, only external
2491 symbols are returned."
2492 (let ((completions '())
2493 (converter (output-case-converter string)))
2494 (flet ((symbol-matches-p (symbol)
2495 (and (or (not external)
2496 (symbol-external-p symbol package))
2497 (funcall test string
2498 (funcall converter (symbol-name symbol))))))
2499 (do-symbols (symbol package)
2500 (when (symbol-matches-p symbol)
2501 (push symbol completions))))
2502 (remove-duplicates completions)))
2503
2504 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
2505 "True if SYMBOL is external in PACKAGE.
2506 If PACKAGE is not specified, the home package of SYMBOL is used."
2507 (and package
2508 (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
2509 :external)))
2510
2511 (defun find-matching-packages (name matcher)
2512 "Return a list of package names matching NAME with MATCHER.
2513 MATCHER is a two-argument predicate."
2514 (let ((to-match (string-upcase name)))
2515 (remove-if-not (lambda (x) (funcall matcher to-match x))
2516 (mapcar (lambda (pkgname)
2517 (concatenate 'string pkgname ":"))
2518 (loop for package in (list-all-packages)
2519 collect (package-name package)
2520 append (package-nicknames package))))))
2521
2522 (defun parse-completion-arguments (string default-package-name)
2523 "Parse STRING as a symbol designator.
2524 Return these values:
2525 SYMBOL-NAME
2526 PACKAGE-NAME, or nil if the designator does not include an explicit package.
2527 PACKAGE, the package to complete in
2528 INTERNAL-P, if the symbol is qualified with `::'."
2529 (multiple-value-bind (name package-name internal-p)
2530 (tokenize-symbol string)
2531 (let ((package (carefully-find-package package-name default-package-name)))
2532 (values name package-name package internal-p))))
2533
2534 (defun carefully-find-package (name default-package-name)
2535 "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
2536 *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
2537 (let ((string (cond ((equal name "") "KEYWORD")
2538 (t (or name default-package-name)))))
2539 (if string
2540 (guess-package-from-string string nil)
2541 *buffer-package*)))
2542
2543 ;;;;; Format completion results
2544 ;;;
2545 ;;; We try to format results in the case as inputs. If you complete
2546 ;;; `FOO' then your result should include `FOOBAR' rather than
2547 ;;; `foobar'.
2548
2549 (defun format-completion-set (strings internal-p package-name)
2550 "Format a set of completion strings.
2551 Returns a list of completions with package qualifiers if needed."
2552 (mapcar (lambda (string)
2553 (format-completion-result string internal-p package-name))
2554 (sort strings #'string<)))
2555
2556 (defun format-completion-result (string internal-p package-name)
2557 (let ((prefix (cond (internal-p (format nil "~A::" package-name))
2558 (package-name (format nil "~A:" package-name))
2559 (t ""))))
2560 (values (concatenate 'string prefix string)
2561 (length prefix))))
2562
2563 (defun output-case-converter (input)
2564 "Return a function to case convert strings for output.
2565 INPUT is used to guess the preferred case."
2566 (ecase (readtable-case *readtable*)
2567 (:upcase (if (some #'lower-case-p input) #'string-downcase #'identity))
2568 (:invert (lambda (output)
2569 (multiple-value-bind (lower upper) (determine-case output)
2570 (cond ((and lower upper) output)
2571 (lower (string-upcase output))
2572 (upper (string-downcase output))
2573 (t output)))))
2574 (:downcase (if (some #'upper-case-p input) #'string-upcase #'identity))
2575 (:preserve #'identity)))
2576
2577 (defun determine-case (string)
2578 "Return two booleans LOWER and UPPER indicating whether STRING
2579 contains lower or upper case characters."
2580 (values (some #'lower-case-p string)
2581 (some #'upper-case-p string)))
2582
2583
2584 ;;;;; Compound-prefix matching
2585
2586 (defun compound-prefix-match (prefix target)
2587 "Return true if PREFIX is a compound-prefix of TARGET.
2588 Viewing each of PREFIX and TARGET as a series of substrings delimited
2589 by hyphens, if each substring of PREFIX is a prefix of the
2590 corresponding substring in TARGET then we call PREFIX a
2591 compound-prefix of TARGET.
2592
2593 Examples:
2594 \(compound-prefix-match \"foo\" \"foobar\") => t
2595 \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
2596 \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
2597 (declare (type simple-string prefix target))
2598 (loop for ch across prefix
2599 with tpos = 0
2600 always (and (< tpos (length target))
2601 (if (char= ch #\-)
2602 (setf tpos (position #\- target :start tpos))
2603 (char= ch (aref target tpos))))
2604 do (incf tpos)))
2605
2606 (defun prefix-match-p (prefix string)
2607 "Return true if PREFIX is a prefix of STRING."
2608 (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
2609
2610
2611 ;;;;; Extending the input string by completion
2612
2613 (defun longest-completion (completions)
2614 "Return the longest prefix for all COMPLETIONS.
2615 COMPLETIONS is a list of strings."
2616 (untokenize-completion
2617 (mapcar #'longest-common-prefix
2618 (transpose-lists (mapcar #'tokenize-completion completions)))))
2619
2620 (defun tokenize-completion (string)
2621 "Return all substrings of STRING delimited by #\-."
2622 (loop with end
2623 for start = 0 then (1+ end)
2624 until (> start (length string))
2625 do (setq end (or (position #\- string :start start) (length string)))
2626 collect (subseq string start end)))
2627
2628 (defun untokenize-completion (tokens)
2629 (format nil "~{~A~^-~}" tokens))
2630
2631 (defun longest-common-prefix (strings)
2632 "Return the longest string that is a common prefix of STRINGS."
2633 (if (null strings)
2634 ""
2635 (flet ((common-prefix (s1 s2)
2636 (let ((diff-pos (mismatch s1 s2)))
2637 (if diff-pos (subseq s1 0 diff-pos) s1))))
2638 (reduce #'common-prefix strings))))
2639
2640 (defun transpose-lists (lists)
2641 "Turn a list-of-lists on its side.
2642 If the rows are of unequal length, truncate uniformly to the shortest.
2643
2644 For example:
2645 \(transpose-lists '((ONE TWO THREE) (1 2)))
2646 => ((ONE 1) (TWO 2))"
2647 (cond ((null lists) '())
2648 ((some #'null lists) '())
2649 (t (cons (mapcar #'car lists)
2650 (transpose-lists (mapcar #'cdr lists))))))
2651
2652
2653 ;;;;; Completion Tests
2654
2655 (defpackage :swank-completion-test
2656 (:use))
2657
2658 (let ((*readtable* (copy-readtable *readtable*))
2659 (p (find-package :swank-completion-test)))
2660 (intern "foo" p)
2661 (intern "Foo" p)
2662 (intern "FOO" p)
2663 (setf (readtable-case *readtable*) :invert)
2664 (flet ((names (prefix)
2665 (sort (mapcar #'symbol-name
2666 (find-matching-symbols prefix p nil #'prefix-match-p))
2667 #'string<)))
2668 (assert (equal '("FOO") (names "f")))
2669 (assert (equal '("Foo" "foo") (names "F")))
2670 (assert (equal '("Foo") (names "Fo")))
2671 (assert (equal '("foo") (names "FO")))))
2672
2673 ;;;; Fuzzy completion
2674
2675 (defslimefun fuzzy-completions (string default-package-name &optional limit)
2676 "Return an (optionally limited to LIMIT best results) list of
2677 fuzzy completions for a symbol designator STRING. The list will
2678 be sorted by score, most likely match first.
2679
2680 The result is a list of completion objects, where a completion
2681 object is:
2682 (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
2683 where a CHUNK is a description of a matched string of characters:
2684 (OFFSET STRING)
2685 and FLAGS is a list of keywords describing properties of the symbol.
2686 For example, the top result for completing \"mvb\" in a package
2687 that uses COMMON-LISP would be something like:
2688 (\"multiple-value-bind\" 42.391666 ((0 \"mul\") (9 \"v\") (15 \"b\"))
2689 (:FBOUNDP :MACRO))
2690
2691 If STRING is package qualified the result list will also be
2692 qualified. If string is non-qualified the result strings are
2693 also not qualified and are considered relative to
2694 DEFAULT-PACKAGE-NAME.
2695
2696 Which symbols are candidates for matching depends on the symbol
2697 designator's format. The cases are as follows:
2698 FOO - Symbols accessible in the buffer package.
2699 PKG:FOO - Symbols external in package PKG.
2700 PKG::FOO - Symbols accessible in package PKG."
2701 (fuzzy-completion-set string default-package-name limit))
2702
2703 (defun convert-fuzzy-completion-result (result converter
2704 internal-p package-name)
2705 "Converts a result from the fuzzy completion core into
2706 something that emacs is expecting. Converts symbols to strings,
2707 fixes case issues, and adds information describing if the symbol
2708 is :bound, :fbound, a :class, a :macro, a :generic-function,
2709 a :special-operator, or a :package."
2710 (destructuring-bind (symbol-or-name score chunks) result
2711 (multiple-value-bind (name added-length)
2712 (format-completion-result
2713 (funcall converter
2714 (if (symbolp symbol-or-name)
2715 (symbol-name symbol-or-name)
2716 symbol-or-name))
2717 internal-p package-name)
2718 (list name score
2719 (mapcar
2720 #'(lambda (chunk)
2721 ;; fix up chunk positions to account for possible
2722 ;; added package identifier
2723 (list (+ added-length (first chunk))
2724 (second chunk)))
2725 chunks)
2726 (loop for flag in '(:boundp :fboundp :generic-function
2727 :class :macro :special-operator
2728 :package)
2729 if (if (symbolp symbol-or-name)
2730 (case flag
2731 (:boundp (boundp symbol-or-name))
2732 (:fboundp (fboundp symbol-or-name))
2733 (:class (find-class symbol-or-name nil))
2734 (:macro (macro-function symbol-or-name))
2735 (:special-operator
2736 (special-operator-p symbol-or-name))
2737 (:generic-function
2738 (typep (ignore-errors (fdefinition symbol-or-name))
2739 'generic-function)))
2740 (case flag
2741 (:package (stringp symbol-or-name)
2742 ;; KLUDGE: depends on internal
2743 ;; knowledge that packages are
2744 ;; brought up from the bowels of
2745 ;; the completion algorithm as
2746 ;; strings!
2747 )))
2748 collect flag)))))
2749
2750 (defun fuzzy-completion-set (string default-package-name &optional limit)
2751 "Prepares list of completion obajects, sorted by SCORE, of fuzzy
2752 completions of STRING in DEFAULT-PACKAGE-NAME. If LIMIT is set,
2753 only the top LIMIT results will be returned."
2754 (multiple-value-bind (name package-name package internal-p)
2755 (parse-completion-arguments string default-package-name)
2756 (let* ((symbols (and package
2757 (fuzzy-find-matching-symbols name
2758 package
2759 (and (not internal-p)
2760 package-name))))
2761 (packs (and (not package-name)
2762 (fuzzy-find-matching-packages name)))
2763 (converter (output-case-converter name))
2764 (results
2765 (sort (mapcar #'(lambda (result)
2766 (convert-fuzzy-completion-result
2767 result converter internal-p package-name))
2768 (nconc symbols packs))
2769 #'> :key #'second)))
2770 (when (and limit
2771 (> limit 0)
2772 (< limit (length results)))
2773 (setf (cdr (nthcdr (1- limit) results)) nil))
2774 results)))
2775
2776 (defun fuzzy-find-matching-symbols (string package external)
2777 "Return a list of symbols in PACKAGE matching STRING using the
2778 fuzzy completion algorithm. If EXTERNAL is true, only external
2779 symbols are returned."
2780 (let ((completions '())
2781 (converter (output-case-converter string)))
2782 (flet ((symbol-match (symbol)
2783 (and (or (not external)
2784 (symbol-external-p symbol package))
2785 (compute-highest-scoring-completion
2786 string (funcall converter (symbol-name symbol)) #'char=))))
2787 (do-symbols (symbol package)
2788 (if (string= "" string)
2789 (when (or (and external (symbol-external-p symbol package))
2790 (not external))
2791 (push (list symbol 0.0 (list (list 0 ""))) completions))
2792 (multiple-value-bind (result score) (symbol-match symbol)
2793 (when result
2794 (push (list symbol score result) completions))))))
2795 (remove-duplicates completions :key #'first)))
2796
2797 (defun fuzzy-find-matching-packages (name)
2798 "Return a list of package names matching NAME using the fuzzy
2799 completion algorithm."
2800 (let ((converter (output-case-converter name)))
2801 (loop for package in (list-all-packages)
2802 for package-name = (concatenate 'string
2803 (funcall converter
2804 (package-name package))
2805 ":")
2806 for (result score) = (multiple-value-list
2807 (compute-highest-scoring-completion
2808 name package-name #'char=))
2809 if result collect (list package-name score result))))
2810
2811 (defslimefun fuzzy-completion-selected (original-string completion)
2812 "This function is called by Slime when a fuzzy completion is
2813 selected by the user. It is for future expansion to make
2814 testing, say, a machine learning algorithm for completion scoring
2815 easier.
2816
2817 ORIGINAL-STRING is the string the user completed from, and
2818 COMPLETION is the completion object (see docstring for
2819 SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
2820 user selected."
2821 (declare (ignore original-string completion))
2822 nil)
2823
2824 ;;;;; Fuzzy completion core
2825
2826 (defparameter *fuzzy-recursion-soft-limit* 30
2827 "This is a soft limit for recursion in
2828 RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
2829 completing a string such as \"ZZZZZZ\" with a symbol named
2830 \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
2831 find all the ways it can match.
2832
2833 Most natural language searches and symbols do not have this
2834 problem -- this is only here as a safeguard.")
2835
2836 (defun compute-highest-scoring-completion (short full test)
2837 "Finds the highest scoring way to complete the abbreviation
2838 SHORT onto the string FULL, using TEST as a equality function for
2839 letters. Returns two values: The first being the completion
2840 chunks of the high scorer, and the second being the score."
2841 (let* ((scored-results
2842 (mapcar #'(lambda (result)
2843 (cons (score-completion result short full) result))
2844 (compute-most-completions short full test)))
2845 (winner (first (sort scored-results #'> :key #'first))))
2846 (values (rest winner) (first winner))))
2847
2848 (defun compute-most-completions (short full test)
2849 "Finds most possible ways to complete FULL with the letters in SHORT.
2850 Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
2851 a list of (&rest CHUNKS), where each CHUNKS is a description of
2852 how a completion matches."
2853 (let ((*all-chunks* nil))
2854 (declare (special *all-chunks*))
2855 (recursively-compute-most-completions short full test 0 0 nil nil nil t)
2856 *all-chunks*))
2857
2858 (defun recursively-compute-most-completions
2859 (short full test
2860 short-index initial-full-index
2861 chunks current-chunk current-chunk-pos
2862 recurse-p)
2863 "Recursively (if RECURSE-P is true) find /most/ possible ways
2864 to fuzzily map the letters in SHORT onto FULL, with TEST being a
2865 function to determine if two letters match.
2866
2867 A chunk is a list of elements that have matched consecutively.
2868 When consecutive matches stop, it is coerced into a string,
2869 paired with the starting position of the chunk, and pushed onto
2870 CHUNKS.
2871
2872 Whenever a letter matches, if RECURSE-P is true,
2873 RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
2874 one index ahead, to find other possibly higher scoring
2875 possibilities. If there are less than
2876 *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
2877 this call will also recurse.
2878
2879 Once a word has been completely matched, the chunks are pushed
2880 onto the special variable *ALL-CHUNKS* and the function returns."
2881 (declare (special *all-chunks*))
2882 (flet ((short-cur ()
2883 "Returns the next letter from the abbreviation, or NIL
2884 if all have been used."
2885 (if (= short-index (length short))
2886 nil
2887 (aref short short-index)))
2888 (add-to-chunk (char pos)
2889 "Adds the CHAR at POS in FULL to the current chunk,
2890 marking the start position if it is empty."
2891 (unless current-chunk
2892 (setf current-chunk-pos pos))
2893 (push char current-chunk))
2894 (collect-chunk ()
2895 "Collects the current chunk to CHUNKS and prepares for
2896 a new chunk."
2897 (when current-chunk
2898 (push (list current-chunk-pos
2899 (coerce (reverse current-chunk) 'string)) chunks)
2900 (setf current-chunk nil
2901 current-chunk-pos nil))))
2902 ;; If there's an outstanding chunk coming in collect it. Since
2903 ;; we're recursively called on skipping an input character, the
2904 ;; chunk can't possibly continue on.
2905 (when current-chunk (collect-chunk))
2906 (do ((pos initial-full-index (1+ pos)))
2907 ((= pos (length full)))
2908 (let ((cur-char (aref full pos)))
2909 (if (and (short-cur)
2910 (funcall test cur-char (short-cur)))
2911 (progn
2912 (when recurse-p
2913 ;; Try other possibilities, limiting insanely deep
2914 ;; recursion somewhat.
2915 (recursively-compute-most-completions
2916 short full test short-index (1+ pos)
2917 chunks current-chunk current-chunk-pos
2918 (not (> (length *all-chunks*)
2919 *fuzzy-recursion-soft-limit*))))
2920 (incf short-index)
2921 (add-to-chunk cur-char pos))
2922 (collect-chunk))))
2923 (collect-chunk)
2924 ;; If we've exhausted the short characters we have a match.
2925 (if (short-cur)
2926 nil
2927 (let ((rev-chunks (reverse chunks)))
2928 (push rev-chunks *all-chunks*)
2929 rev-chunks))))
2930
2931 ;;;;; Fuzzy completion scoring
2932
2933 (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
2934 "Letters that are likely to be at the beginning of a symbol.
2935 Letters found after one of these prefixes will be scored as if
2936 they were at the beginning of ths symbol.")
2937 (defparameter *fuzzy-completion-symbol-suffixes* "*+->"
2938 "Letters that are likely to be at the end of a symbol.
2939 Letters found before one of these suffixes will be scored as if
2940 they were at the end of the symbol.")
2941 (defparameter *fuzzy-completion-word-separators* "-/."
2942 "Letters that separate different words in symbols. Letters
2943 after one of these symbols will be scores more highly than other
2944 letters.")
2945
2946 (defun score-completion (completion short full)
2947 "Scores the completion chunks COMPLETION as a completion from
2948 the abbreviation SHORT to the full string FULL. COMPLETION is a
2949 list like:
2950 ((0 \"mul\") (9 \"v\") (15 \"b\"))
2951 Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
2952 would indicate that it completed as such (completed letters
2953 capitalized):
2954 MULtiple-Value-Bind
2955
2956 Letters are given scores based on their position in the string.
2957 Letters at the beginning of a string or after a prefix letter at
2958 the beginning of a string are scored highest. Letters after a
2959 word separator such as #\- are scored next highest. Letters at
2960 the end of a string or before a suffix letter at the end of a
2961 string are scored medium, and letters anywhere else are scored
2962 low.
2963
2964 If a letter is directly after another matched letter, and its
2965 intrinsic value in that position is less than a percentage of the
2966 previous letter's value, it will use that percentage instead.
2967
2968 Finally, a small scaling factor is applied to favor shorter
2969 matches, all other things being equal."
2970 (labels ((at-beginning-p (pos)
2971 (= pos 0))
2972 (after-prefix-p (pos)
2973 (and (= pos 1)
2974 (find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
2975 (word-separator-p (pos)
2976 (find (aref full pos) *fuzzy-completion-word-separators*))
2977 (after-word-separator-p (pos)
2978 (find (aref full (1- pos)) *fuzzy-completion-word-separators*))
2979 (at-end-p (pos)
2980 (= pos (1- (length full))))
2981 (before-suffix-p (pos)
2982 (and (= pos (- (length full) 2))
2983 (find (aref full (1- (length full)))
2984 *fuzzy-completion-symbol-suffixes*)))
2985 (score-or-percentage-of-previous (base-score pos chunk-pos)
2986 (if (zerop chunk-pos)
2987 base-score
2988 (max base-score
2989 (* (score-char (1- pos) (1- chunk-pos)) 0.85))))
2990 (score-char (pos chunk-pos)
2991 (score-or-percentage-of-previous
2992 (cond ((at-beginning-p pos) 10)
2993 ((after-prefix-p pos) 10)
2994 ((word-separator-p pos) 1)
2995 ((after-word-separator-p pos) 8)
2996 ((at-end-p pos) 6)
2997 ((before-suffix-p pos) 6)
2998 (t 1))
2999 pos chunk-pos))
3000 (score-chunk (chunk)
3001 (loop for chunk-pos below (length (second chunk))
3002 for pos from (first chunk)
3003 summing (score-char pos chunk-pos))))
3004 (let* ((chunk-scores (mapcar #'score-chunk completion))
3005 (length-score (/ 10.0 (1+ (- (length full) (length short))))))
3006 (values
3007 (+ (reduce #'+ chunk-scores) length-score)
3008 (list (mapcar #'list chunk-scores completion) length-score)))))
3009
3010 (defun highlight-completion (completion full)
3011 "Given a chunk definition COMPLETION and the string FULL,
3012 HIGHLIGHT-COMPLETION will create a string that demonstrates where
3013 the completion matched in the string. Matches will be
3014 capitalized, while the rest of the string will be lower-case."
3015 (let ((highlit (nstring-downcase (copy-seq full))))
3016 (dolist (chunk completion)
3017 (setf highlit (nstring-upcase highlit
3018 :start (first chunk)
3019 :end (+ (first chunk)
3020 (length (second chunk))))))
3021 highlit))
3022
3023 (defun format-fuzzy-completions (winners)
3024 "Given a list of completion objects such as on returned by
3025 FUZZY-COMPLETIONS, format the list into user-readable output."
3026 (let ((max-len
3027 (loop for winner in winners maximizing (length (first winner)))))
3028 (loop for (sym score result) in winners do
3029 (format t "~&~VA score ~8,2F ~A"
3030 max-len (highlight-completion result sym) score result))))
3031
3032
3033 ;;;; Documentation
3034
3035 (defslimefun apropos-list-for-emacs (name &optional external-only
3036 case-sensitive package)
3037 "Make an apropos search for Emacs.
3038 The result is a list of property lists."
3039 (let ((package (if package
3040 (or (find-package (string-to-package-designator package))
3041 (error "No such package: ~S" package)))))
3042 (mapcan (listify #'briefly-describe-symbol-for-emacs)
3043 (sort (remove-duplicates
3044 (apropos-symbols name external-only case-sensitive package))
3045 #'present-symbol-before-p))))
3046
3047 (defun string-to-package-designator (string)
3048 "Return a package designator made from STRING.
3049 Uses READ to case-convert STRING."
3050 (let ((*package* *swank-io-package*))
3051 (read-from-string string)))
3052
3053 (defun briefly-describe-symbol-for-emacs (symbol)
3054 "Return a property list describing SYMBOL.
3055 Like `describe-symbol-for-emacs' but with at most one line per item."
3056 (flet ((first-line (string)
3057 (let ((pos (position #\newline string)))
3058 (if (null pos) string (subseq string 0 pos)))))
3059 (let ((desc (map-if #'stringp #'first-line
3060 (describe-symbol-for-emacs symbol))))
3061 (if desc
3062 (list* :designator (to-string symbol) desc)))))
3063
3064 (defun map-if (test fn &rest lists)
3065 "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
3066 Example:
3067 \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
3068 (declare (type function test fn))
3069 (apply #'mapcar
3070 (lambda (x) (if (funcall test x) (funcall fn x) x))
3071 lists))
3072
3073 (defun listify (f)
3074 "Return a function like F, but which returns any non-null value
3075 wrapped in a list."
3076 (declare (type function f))
3077 (lambda (x)
3078 (let ((y (funcall f x)))
3079 (and y (list y)))))
3080
3081 (defun present-symbol-before-p (x y)
3082 "Return true if X belongs before Y in a printed summary of symbols.
3083 Sorted alphabetically by package name and then symbol name, except
3084 that symbols accessible in the current package go first."
3085 (declare (type symbol x y))
3086 (flet ((accessible (s)
3087 ;; Test breaks on NIL for package that does not inherit it
3088 (eq (find-symbol (symbol-name s) *buffer-package*) s)))
3089 (let ((ax (accessible x)) (ay (accessible y)))
3090 (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
3091 (ax t)
3092 (ay nil)
3093 (t (let ((px (symbol-package x)) (py (symbol-package y)))
3094 (if (eq px py)
3095 (string< (symbol-name x) (symbol-name y))
3096 (string< (package-name px) (package-name py)))))))))
3097
3098 (let ((regex-hash (make-hash-table :test #'equal)))
3099 (defun compiled-regex (regex-string)
3100 (or (gethash regex-string regex-hash)
3101 (setf (gethash regex-string regex-hash)
3102 (if (zerop (length regex-string))
3103 (lambda (s) (check-type s string) t)
3104 (compile nil (slime-nregex:regex-compile regex-string)))))))
3105
3106 (defun apropos-matcher (string case-sensitive package external-only)
3107 (let* ((case-modifier (if case-sensitive #'string #'string-upcase))
3108 (regex (compiled-regex (funcall case-modifier string))))
3109 (lambda (symbol)
3110 (and (not (keywordp symbol))
3111 (if package (eq (symbol-package symbol) package) t)
3112 (if external-only (symbol-external-p symbol) t)
3113 (funcall regex (funcall case-modifier symbol))))))
3114
3115 (defun apropos-symbols (string external-only case-sensitive package)
3116 (let ((result '())
3117 (matchp (apropos-matcher string case-sensitive package external-only)))
3118 (with-package-iterator (next (or package (list-all-packages))
3119 :external :internal)
3120 (loop
3121 (multiple-value-bind (morep symbol) (next)
3122 (cond ((not morep)
3123 (return))
3124 ((funcall matchp symbol)
3125 (push symbol result))))))
3126 result))
3127
3128 (defun call-with-describe-settings (fn)
3129 (let ((*print-readably* nil))
3130 (funcall fn)))
3131
3132 (defmacro with-describe-settings ((&rest _) &body body)
3133 (declare (ignore _))
3134 `(call-with-describe-settings (lambda () ,@body)))
3135
3136 (defun describe-to-string (object)
3137 (with-describe-settings ()
3138 (with-output-to-string (*standard-output*)
3139 (describe object))))
3140
3141 (defslimefun describe-symbol (symbol-name)
3142 (with-buffer-syntax ()
3143 (describe-to-string (parse-symbol-or-lose symbol-name))))
3144
3145 (defslimefun describe-function (name)
3146 (with-buffer-syntax ()
3147 (let ((symbol (parse-symbol-or-lose name)))
3148 (describe-to-string (or (macro-function symbol)
3149 (symbol-function symbol))))))
3150
3151 (defslimefun describe-definition-for-emacs (name kind)
3152 (with-buffer-syntax ()
3153 (with-describe-settings ()
3154 (with-output-to-string (*standard-output*)
3155 (describe-definition (parse-symbol-or-lose name) kind)))))
3156
3157 (defslimefun documentation-symbol (symbol-name &optional default)
3158 (with-buffer-syntax ()
3159 (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
3160 (if foundp
3161 (let ((vdoc (documentation sym 'variable))
3162 (fdoc (documentation sym 'function)))
3163 (or (and (or vdoc fdoc)
3164 (concatenate 'string
3165 fdoc
3166 (and vdoc fdoc '(#\Newline #\Newline))
3167 vdoc))
3168 default))
3169 default))))
3170
3171
3172 ;;;; Package Commands
3173
3174 (defslimefun list-all-package-names (&optional include-nicknames)
3175 "Return a list of all package names.
3176 Include the nicknames if INCLUDE-NICKNAMES is true."
3177 (loop for package in (list-all-packages)
3178 collect (package-name package)
3179 when include-nicknames append (package-nicknames package)))
3180
3181
3182 ;;;; Tracing
3183
3184 ;; Use eval for the sake of portability...
3185 (defun tracedp (fspec)
3186 (member fspec (eval '(trace))))
3187
3188 (defslimefun swank-toggle-trace (spec-string)
3189 (let ((spec (from-string spec-string)))
3190 (cond ((consp spec) ; handle complicated cases in the backend
3191 (toggle-trace spec))
3192 ((tracedp spec)
3193 (eval `(untrace ,spec))
3194 (format nil "~S is now untraced." spec))
3195 (t
3196 (eval `(trace ,spec))
3197 (format nil "~S is now traced." spec)))))
3198
3199 (defslimefun untrace-all ()
3200 (untrace))
3201
3202
3203 ;;;; Undefing
3204
3205 (defslimefun undefine-function (fname-string)
3206 (let ((fname (from-string fname-string)))
3207 (format nil "~S" (fmakunbound fname))))
3208
3209
3210 ;;;; Profiling
3211
3212 (defun profiledp (fspec)
3213 (member fspec (profiled-functions)))
3214
3215 (defslimefun toggle-profile-fdefinition (fname-string)
3216 (let ((fname (from-string fname-string)))
3217 (cond ((profiledp fname)
3218 (unprofile fname)
3219 (format nil "~S is now unprofiled." fname))
3220 (t
3221 (profile fname)
3222 (format nil "~S is now profiled." fname)))))
3223
3224
3225 ;;;; Source Locations
3226
3227 (defslimefun find-definitions-for-emacs (name)
3228 "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
3229 DSPEC is a string and LOCATION a source location. NAME is a string."
3230 (multiple-value-bind (sexp error)
3231 (ignore-errors (values (from-string name)))
3232 (cond (error '())
3233 (t (loop for (dspec loc) in (find-definitions sexp)
3234 collect (list (to-string dspec) loc))))))
3235
3236 (defun alistify (list key test)
3237 "Partition the elements of LIST into an alist. KEY extracts the key
3238 from an element and TEST is used to compare keys."
3239 (declare (type function key))
3240 (let ((alist '()))
3241 (dolist (e list)
3242 (let* ((k (funcall key e))
3243 (probe (assoc k alist :test test)))
3244 (if probe
3245 (push e (cdr probe))
3246 (push (cons k (list e)) alist))))
3247 alist))
3248
3249 (defun location-position< (pos1 pos2)
3250 (cond ((and (position-p pos1) (position-p pos2))
3251 (< (position-pos pos1)
3252 (position-pos pos2)))
3253 (t nil)))
3254
3255 (defun partition (list test key)
3256 (declare (type function test key))
3257 (loop for e in list
3258 if (funcall test (funcall key e)) collect e into yes
3259 else collect e into no
3260 finally (return (values yes no))))
3261
3262 (defstruct (xref (:conc-name xref.)
3263 (:type list))
3264 dspec location)
3265
3266 (defun location-valid-p (location)
3267 (eq (car location) :location))
3268
3269 (defun xref-buffer (xref)
3270 (location-buffer (xref.location xref)))
3271
3272 (defun xref-position (xref)
3273 (location-buffer (xref.location xref)))
3274
3275 (defun group-xrefs (xrefs)
3276 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
3277 The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
3278 (multiple-value-bind (resolved errors)
3279 (partition xrefs #'location-valid-p #'xref.location)
3280 (let ((alist (alistify resolved #'xref-buffer #'equal)))
3281 (append
3282 (loop for (buffer . list) in alist
3283 collect (cons (second buffer)
3284 (mapcar (lambda (xref)
3285 (cons (to-string (xref.dspec xref))
3286 (xref.location xref)))
3287 (sort list #'location-position<
3288 :key #'xref-position))))
3289 (if errors
3290 (list (cons "Unresolved"
3291 (mapcar (lambda (xref)
3292 (cons (to-string (xref.dspec xref))
3293 (xref.location xref)))
3294 errors))))))))
3295
3296 (defslimefun xref (type symbol-name)
3297 (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
3298 (group-xrefs
3299 (ecase type
3300 (:calls (who-calls symbol))
3301 (:calls-who (calls-who symbol))
3302 (:references (who-references symbol))
3303 (:binds (who-binds symbol))
3304 (:sets (who-sets symbol))
3305 (:macroexpands (who-macroexpands symbol))
3306 (:specializes (who-specializes symbol))
3307 (:callers (list-callers symbol))
3308 (:callees (list-callees symbol))))))
3309
3310
3311 ;;;; Inspecting
3312
3313 (defun common-seperated-spec (list &optional (callback (lambda (v)
3314 `(:value ,v))))
3315 (butlast
3316 (loop
3317 for i in list
3318 collect (funcall callback i)
3319 collect ", ")))
3320
3321 (defun inspector-princ (list)
3322 "Like princ-to-string, but don't rewrite (function foo) as #'foo.
3323 Do NOT pass circular lists to this function."
3324 (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
3325 (set-pprint-dispatch '(cons (member function)) nil)
3326 (princ-to-string list)))
3327
3328 (defmethod inspect-for-emacs ((object cons) inspector)
3329 (declare (ignore inspector))
3330 (if (consp (cdr object))
3331 (inspect-for-emacs-list object)
3332 (inspect-for-emacs-simple-cons object)))
3333
3334 (defun inspect-for-emacs-simple-cons (cons)
3335 (values "A cons cell."
3336 (label-value-line*
3337 ('car (car cons))
3338 ('cdr (cdr cons)))))
3339
3340 (defun inspect-for-emacs-list (list)
3341 (let ((maxlen 40))
3342 (multiple-value-bind (length tail) (safe-length list)
3343 (flet ((frob (title list)
3344 (let ((lines
3345 (do ((i 0 (1+ i))
3346 (l list (cdr l))
3347 (a '() (cons (label-value-line i (car l)) a)))
3348 ((not (consp l))
3349 (let ((a (if (null l)
3350 a
3351 (cons (label-value-line :tail l) a))))
3352 (reduce #'append (reverse a) :from-end t))))))
3353 (values title (append '("Elements:" (:newline)) lines)))))
3354
3355 (cond ((not length) ; circular
3356 (frob "A circular list."
3357 (cons (car list)
3358 (ldiff (cdr list) list))))
3359 ((and (<= length maxlen) (not tail))
3360 (frob "A proper list." list))
3361 (tail
3362 (frob "An improper list." list))
3363 (t
3364 (frob "A proper list." list)))))))
3365
3366 ;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
3367
3368 (defun safe-length (list)
3369 "Similar to `list-length', but avoid errors on improper lists.
3370 Return two values: the length of the list and the last cdr.
3371 NIL is returned if the list is circular."
3372 (do ((n 0 (+ n 2)) ;Counter.
3373 (fast list (cddr fast)) ;Fast pointer: leaps by 2.
3374 (slow list (cdr slow))) ;Slow pointer: leaps by 1.
3375 (nil)
3376 (cond ((null fast) (return (values n nil)))
3377 ((not (consp fast)) (return (values n fast)))
3378 ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
3379 ((and (eq fast slow) (> n 0)) (return nil))
3380 ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
3381
3382 (defvar *slime-inspect-contents-limit* nil "How many elements of
3383 a hash table or array to show by default. If table has more than
3384 this then offer actions to view more. Set to nil for no limit." )
3385
3386 (defmethod inspect-for-emacs ((ht hash-table) inspector)
3387 (declare (ignore inspector))
3388 (values (prin1-to-string ht)
3389 (append
3390 (label-value-line*
3391 ("Count" (hash-table-count ht))
3392 ("Size" (hash-table-size ht))
3393 ("Test" (hash-table-test ht))
3394 ("Rehash size" (hash-table-rehash-size ht))
3395 ("Rehash threshold" (hash-table-rehash-threshold ht)))
3396 '("Contents: " (:newline))
3397 (if (and *slime-inspect-contents-limit*
3398 (>= (hash-table-count ht) *slime-inspect-contents-limit*))
3399 (inspect-bigger-piece-actions ht (hash-table-count ht))
3400 nil)
3401 (loop for key being the hash-keys of ht
3402 for value being the hash-values of ht
3403 repeat (or *slime-inspect-contents-limit* most-positive-fixnum)
3404 append `((:value ,key) " = " (:value ,value) (:newline))
3405 )
3406
3407 )))
3408
3409 (defmethod inspect-bigger-piece-actions (thing size)
3410 (append
3411 (if (> size *slime-inspect-contents-limit*)
3412 (list (inspect-show-more-action thing)
3413 '(:newline))
3414 nil)
3415 (list (inspect-whole-thing-action thing size)
3416 '(:newline))))
3417
3418 (defmethod inspect-whole-thing-action (thing size)
3419 `(:action ,(format nil "Inspect all ~a elements."
3420 size)
3421 ,(lambda()
3422 (let ((*slime-inspect-contents-limit* nil))
3423 (values
3424 (swank::inspect-object thing)
3425 :replace)
3426 ))))
3427
3428 (defmethod inspect-show-more-action (thing)
3429 `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..."
3430 *slime-inspect-contents-limit* )
3431 ,(lambda()
3432 (let ((*slime-inspect-contents-limit*
3433 (progn (format t "How many elements should be shown? ") (read))))
3434 (values
3435 (swank::inspect-object thing)
3436 :replace)
3437 ))
3438 ))
3439
3440 (defmethod inspect-for-emacs ((array array) inspector)
3441 (declare (ignore inspector))
3442 (values "An array."
3443 (append
3444 (label-value-line*
3445 ("Dimensions" (array-dimensions array))
3446 ("Its element type is" (array-element-type array))
3447 ("Total size" (array-total-size array))
3448 ("Adjustable" (adjustable-array-p array)))
3449 (when (array-has-fill-pointer-p array)
3450 (label-value-line "Fill pointer" (fill-pointer array)))
3451 '("Contents:" (:newline))
3452 (if (and *slime-inspect-contents-limit*
3453 (>= (array-total-size array) *slime-inspect-contents-limit*))
3454 (inspect-bigger-piece-actions array (length array))
3455 nil)
3456 (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
3457 append (label-value-line i (row-major-aref array i))))))
3458
3459 (defmethod inspect-for-emacs ((char character) inspector)
3460 (declare (ignore inspector))
3461 (values "A character."
3462 (append
3463 (label-value-line*
3464 ("Char code" (char-code char))
3465 ("Lower cased" (char-downcase char))
3466 ("Upper cased" (char-upcase char)))
3467 (if (get-macro-character char)
3468 `("In the current readtable ("
3469 (:value ,*readtable*) ") it is a macro character: "
3470 (:value ,(get-macro-character char)))))))
3471
3472 (defun docstring-ispec (label object kind)
3473 "Return a inspector spec if OBJECT has a docstring of of kind KIND."
3474 (let ((docstring (documentation object kind)))
3475 (cond ((not docstring) nil)
3476 ((< (+ (length label) (length docstring))
3477 75)
3478 (list label ": " docstring '(:newline)))
3479 (t
3480 (list label ": " '(:newline) " " docstring '(:newline))))))
3481
3482 (defmethod inspect-for-emacs ((symbol symbol) inspector)
3483 (declare (ignore inspector))
3484 (let ((package (symbol-package symbol)))
3485 (multiple-value-bind (_symbol status)
3486 (and package (find-symbol (string symbol) package))
3487 (declare (ignore _symbol))
3488 (values
3489 "A symbol."
3490 (append
3491 (label-value-line "Its name is" (symbol-name symbol))
3492 ;;
3493 ;; Value
3494 (cond ((boundp symbol)
3495 (label-value-line (if (constantp symbol)
3496 "It is a constant of value"
3497 "It is a global variable bound to")
3498 (symbol-value symbol)))
3499 (t '("It is unbound." (:newline))))
3500 (docstring-ispec "Documentation" symbol 'variable)
3501 (multiple-value-bind (expansion definedp) (macroexpand symbol)
3502 (if definedp
3503 (label-value-line "It is a symbol macro with expansion"
3504 expansion)))
3505 ;;
3506 ;; Function
3507 (if (fboundp symbol)
3508 (append (if (macro-function symbol)
3509 `("It a macro with macro-function: "
3510 (:value ,(macro-function symbol)))
3511 `("It is a function: "
3512 (:value ,(symbol-function symbol))))
3513 `(" " (:action "[make funbound]"
3514 ,(lambda () (fmakunbound symbol))))
3515 `((:newline)))
3516 `("It has no function value." (:newline)))
3517 (docstring-ispec "Function Documentation" symbol 'function)
3518 (if (compiler-macro-function symbol)
3519 (label-value-line "It also names the compiler macro"
3520 (compiler-macro-function symbol)))
3521 (docstring-ispec "Compiler Macro Documentation"
3522 symbol 'compiler-macro)
3523 ;;
3524 ;; Package
3525 (if package
3526 `("It is " ,(string-downcase (string status))
3527 " to the package: "
3528 (:value ,package ,(package-name package))
3529 ,@(if (eq :internal status)
3530 `(" "
3531 (:action "[export it]"
3532 ,(lambda () (export symbol package)))))
3533 " "
3534 (:action "[unintern it]"
3535 ,(lambda () (unintern symbol package)))
3536 (:newline))
3537 '("It is a non-interned symbol." (:newline)))
3538 ;;
3539 ;; Plist
3540 (label-value-line "Property list" (symbol-plist symbol))
3541 ;;
3542 ;; Class
3543 (if (find-class symbol nil)
3544 `("It names the class "
3545 (:value ,(find-class symbol) ,(string symbol))
3546 " "
3547 (:action "[remove]"
3548 ,(lambda () (setf (find-class symbol) nil)))
3549 (:newline)))
3550 ;;
3551 ;; More package
3552 (if (find-package symbol)
3553 (label-value-line "It names the package" (find-package symbol)))
3554 )))))
3555
3556 (defmethod inspect-for-emacs ((f function) inspector)
3557 (declare (ignore inspector))
3558 (values "A function."
3559 (append
3560 (label-value-line "Name" (function-name f))
3561 `("Its argument list is: "
3562 ,(inspector-princ (arglist f)) (:newline))
3563 (docstring-ispec "Documentation" f t)
3564 (if (function-lambda-expression f)
3565 (label-value-line "Lambda Expression"
3566 (function-lambda-expression f))))))
3567
3568 (defun method-specializers-for-inspect (method)
3569 "Return a \"pretty\" list of the method's specializers. Normal
3570 specializers are replaced by the name of the class, eql
3571 specializers are replaced by `(eql ,object)."
3572 (mapcar (lambda (spec)
3573 (typecase spec
3574 (swank-mop:eql-specializer
3575 `(eql ,(swank-mop:eql-specializer-object spec)))
3576 (t (swank-mop:class-name spec))))
3577 (swank-mop:method-specializers method)))
3578
3579 (defun method-for-inspect-value (method)
3580 "Returns a \"pretty\" list describing METHOD. The first element
3581 of the list is the name of generic-function method is
3582 specialiazed on, the second element is the method qualifiers,
3583 the rest of the list is the method's specialiazers (as per
3584 method-specializers-for-inspect)."
3585 (append (list (swank-mop:generic-function-name
3586 (swank-mop:method-generic-function method)))
3587 (swank-mop:method-qualifiers method)
3588 (method-specializers-for-inspect method)))
3589
3590 (defmethod inspect-for-emacs ((o standard-object) inspector)
3591 (declare (ignore inspector))
3592 (values "An object."
3593 `("Class: " (:value ,(class-of o))
3594 (:newline)
3595 "Slots:" (:newline)
3596 ,@(loop
3597 with direct-slots = (swank-mop:class-direct-slots (class-of o))
3598 for slot in (swank-mop:class-slots (class-of o))
3599 for slot-def = (or (find-if (lambda (a)
3600 ;; find the direct slot
3601 ;; with the same name
3602 ;; as SLOT (an
3603 ;; effective slot).
3604 (eql (swank-mop:slot-definition-name a)
3605 (swank-mop:slot-definition-name slot)))
3606 direct-slots)
3607 slot)
3608 collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
3609 collect " = "
3610 if (slot-boundp o (swank-mop:slot-definition-name slot-def))
3611 collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
3612 else
3613 collect "#<unbound>"
3614 collect '(:newline)))))
3615
3616 (defvar *gf-method-getter* 'methods-by-applicability
3617 "This function is called to get the methods of a generic function.
3618 The default returns the method sorted by applicability.
3619 See `methods-by-applicability'.")
3620
3621 (defun specializer< (specializer1 specializer2)
3622 "Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
3623 (let ((s1 specializer1) (s2 specializer2) )
3624 (cond ((typep s1 'swank-mop:eql-specializer)
3625 (not (typep s2 'swank-mop:eql-specializer)))
3626 (t
3627 (flet ((cpl (class)
3628 (and (swank-mop:class-finalized-p class)
3629 (swank-mop:class-precedence-list class))))
3630 (member s2 (cpl s1)))))))
3631
3632 (defun methods-by-applicability (gf)
3633 "Return methods ordered by most specific argument types.
3634
3635 `method-specializer<' is used for sorting."
3636 ;; FIXME: argument-precedence-order and qualifiers are ignored.
3637 (let ((methods (copy-list (swank-mop:generic-function-methods gf))))
3638 (labels ((method< (meth1 meth2)
3639 (loop for s1 in (swank-mop:method-specializers meth1)
3640 for s2 in (swank-mop:method-specializers meth2)
3641 do (cond ((specializer< s2 s1) (return nil))
3642 ((specializer< s1 s2) (return t))))))
3643 (stable-sort methods #'method<))))
3644
3645 (defun abbrev-doc (doc &optional (maxlen 80))
3646 "Return the first sentence of DOC, but not more than MAXLAN characters."
3647 (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
3648 maxlen
3649 (length doc))))
3650
3651 (defmethod inspect-for-emacs ((gf standard-generic-function) inspector)
3652 (declare (ignore inspector))
3653 (flet ((lv (label value) (label-value-line label value)))
3654 (values
3655 "A generic function."
3656 (append
3657 (lv "Name" (swank-mop:generic-function-name gf))
3658 (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
3659 (docstring-ispec "Documentation" gf t)
3660 (lv "Method class" (swank-mop:generic-function-method-class gf))
3661 (lv "Method combination"
3662 (swank-mop:generic-function-method-combination gf))
3663 `("Methods: " (:newline))
3664 (loop for method in (funcall *gf-method-getter* gf) append
3665 `((:value ,method ,(inspector-princ
3666 ;; drop the name of the GF
3667 (cdr (method-for-inspect-value method))))
3668 " "
3669 (:action "[remove method]"
3670 ,(let ((m method)) ; LOOP reassigns method
3671 (lambda ()
3672 (remove-method gf m))))
3673 (:newline)))))))
3674
3675 (defmethod inspect-for-emacs ((method standard-method) inspector)
3676 (declare (ignore inspector))
3677 (values "A method."
3678 `("Method defined on the generic function "
3679 (:value ,(swank-mop:method-generic-function method)
3680 ,(inspector-princ
3681 (swank-mop:generic-function-name
3682 (swank-mop:method-generic-function method))))
3683 (:newline)
3684 ,@(docstring-ispec "Documentation" method t)
3685 "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
3686 (:newline)
3687 "Specializers: " (:value ,(swank-mop:method-specializers method)
3688 ,(inspector-princ (method-specializers-for-inspect method)))
3689 (:newline)
3690 "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
3691 (:newline)
3692 "Method function: " (:value ,(swank-mop:method-function method)))))
3693
3694 (defmethod inspect-for-emacs ((class standard-class) inspector)
3695 (declare (ignore inspector))
3696 (values "A class."
3697 `("Name: " (:value ,(class-name class))
3698 (:newline)
3699 "Super classes: "
3700 ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
3701 (:newline)
3702 "Direct Slots: "
3703 ,@(common-seperated-spec
3704 (swank-mop:class-direct-slots class)
3705 (lambda (slot)
3706 `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
3707 (:newline)
3708 "Effective Slots: "
3709 ,@(if (swank-mop:class-finalized-p class)
3710 (common-seperated-spec
3711 (swank-mop:class-slots class)
3712 (lambda (slot)
3713 `(:value ,slot ,(inspector-princ
3714 (swank-mop:slot-definition-name slot)))))
3715 '("#<N/A (class not finalized)>"))
3716 (:newline)
3717 ,@(when (documentation class t)
3718 `("Documentation:" (:newline) ,(documentation class t) (:newline)))
3719 "Sub classes: "
3720 ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
3721 (lambda (sub)
3722 `(:value ,sub ,(inspector-princ (class-name sub)))))
3723 (:newline)
3724 "Precedence List: "
3725 ,@(if (swank-mop:class-finalized-p class)
3726 (common-seperated-spec (swank-mop:class-precedence-list class)
3727 (lambda (class)
3728 `(:value ,class ,(inspector-princ (class-name class)))))
3729 '("#<N/A (class not finalized)>"))
3730 (:newline)
3731 ,@(when (swank-mop:specializer-direct-methods class)
3732 `("It is used as a direct specializer in the following methods:" (:newline)
3733 ,@(loop
3734 for method in (sort (copy-list (swank-mop:specializer-direct-methods class))
3735 #'string< :key (lambda (x)
3736 (symbol-name
3737 (let ((name (swank-mop::generic-function-name
3738 (swank-mop::method-generic-function x))))
3739 (if (symbolp name) name (second name))))))
3740 collect " "
3741 collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
3742 collect '(:newline)
3743 if (documentation method t)
3744 collect " Documentation: " and
3745 collect (abbrev-doc (documentation method t)) and
3746 collect '(:newline))))
3747 "Prototype: " ,(if (swank-mop:class-finalized-p class)
3748 `(:value ,(swank-mop:class-prototype class))
3749 '"#<N/A (class not finalized)>")
3750 (:newline)
3751 "------------------------------" (:newline)
3752 "All Slots:" (:newline)
3753 ,@(loop
3754 with direct-slots = (swank-mop:class-direct-slots (class-of class))
3755 for slot in (swank-mop:class-slots (class-of class))
3756 for slot-def = (or (find-if (lambda (a)
3757 ;; find the direct slot
3758 ;; with the same name
3759 ;; as SLOT (an
3760 ;; effective slot).
3761 (eql (swank-mop:slot-definition-name a)
3762 (swank-mop:slot-definition-name slot)))
3763 direct-slots)
3764 slot)
3765 collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
3766 collect " = "
3767 if (slot-boundp class (swank-mop:slot-definition-name slot-def))
3768 collect `(:value ,(slot-value class (swank-mop:slot-definition-name slot-def)))
3769 else
3770 collect "#<unbound>"
3771 collect '(:newline)))))
3772
3773 (defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) inspector)
3774 (declare (ignore inspector))
3775 (values "A slot."
3776 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
3777 (:newline)
3778 ,@(when (swank-mop:slot-definition-documentation slot)
3779 `("Documentation:" (:newline)
3780 (:value ,(swank-mop:slot-definition-documentation slot))
3781 (:newline)))
3782 "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
3783 "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
3784 `(:value ,(swank-mop:slot-definition-initform slot))
3785 "#<unspecified>") (:newline)
3786 "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
3787 (:newline))))
3788
3789 (defmethod inspect-for-emacs ((package package) inspector)
3790 (declare (ignore inspector))
3791 (let ((internal-symbols '())
3792 (external-symbols '()))
3793 (do-symbols (sym package)
3794 (when (eq package (symbol-package sym))
3795 (push sym internal-symbols)
3796 (multiple-value-bind (symbol status)
3797 (find-symbol (symbol-name sym) package)
3798 (declare (ignore symbol))
3799 (when (eql :external status)
3800 (push sym external-symbols)))))
3801 (setf internal-symbols (sort internal-symbols #'string-lessp)
3802 external-symbols (sort external-symbols #'string-lessp))
3803 (values "A package."
3804 `("Name: " (:value ,(package-name package))
3805 (:newline)
3806 "Nick names: " ,@(common-seperated-spec (sort (package-nicknames package) #'string-lessp))
3807 (:newline)
3808 ,@(when (documentation package t)
3809 `("Documentation:" (:newline)
3810 ,(documentation package t) (:newline)))
3811 "Use list: " ,@(common-seperated-spec (sort (package-use-list package) #'string-lessp :key #'package-name)
3812 (lambda (pack)
3813 `(:value ,pack ,(inspector-princ (package-name pack)))))
3814 (:newline)
3815 "Used by list: " ,@(common-seperated-spec (sort (package-used-by-list package) #'string-lessp :key #'package-name)
3816 (lambda (pack)
3817 `(:value ,pack ,(inspector-princ (package-name pack)))))
3818 (:newline)
3819 ,(if (null external-symbols)
3820 "0 external symbols."
3821 `(:value ,external-symbols ,(format nil "~D external symbol~:P." (length external-symbols))))
3822 (:newline)
3823 ,(if (null internal-symbols)
3824 "0 internal symbols."
3825 `(:value ,internal-symbols ,(format nil "~D internal symbol~:P." (length internal-symbols))))
3826 (:newline)
3827 ,(if (null (package-shadowing-symbols package))
3828 "0 shadowed symbols."
3829 `(:value ,(package-shadowing-symbols package)
3830 ,(format nil "~D shadowed symbol~:P." (length (package-shadowing-symbols package)))))))))
3831
3832 (defmethod inspect-for-emacs ((pathname pathname) inspector)
3833 (declare (ignore inspector))
3834 (values (if (wild-pathname-p pathname)
3835 "A wild pathname."
3836 "A pathname.")
3837 (append (label-value-line*
3838 ("Namestring" (namestring pathname))
3839 ("Host" (pathname-host pathname))
3840 ("Device" (pathname-device pathname))
3841 ("Directory" (pathname-directory pathname))
3842 ("Name" (pathname-name pathname))
3843 ("Type" (pathname-type pathname))
3844 ("Version" (pathname-version pathname)))
3845 (unless (or (wild-pathname-p pathname)
3846 (not (probe-file pathname)))
3847 (label-value-line "Truename" (truename pathname))))))
3848
3849 (defmethod inspect-for-emacs ((pathname logical-pathname) inspector)
3850 (declare (ignore inspector))
3851 (values "A logical pathname."
3852 (append
3853 (label-value-line*
3854 ("Namestring" (namestring pathname))
3855 ("Physical pathname: " (translate-logical-pathname pathname)))
3856 `("Host: " (pathname-host pathname)
3857 " (" (:value ,(logical-pathname-translations
3858 (pathname-host pathname)))
3859 "other translations)"
3860 (:newline))
3861 (label-value-line*
3862 ("Directory" (pathname-directory pathname))
3863 ("Name" (pathname-name pathname))
3864 ("Type" (pathname-type pathname))
3865 ("Version" (pathname-version pathname))
3866 ("Truename" (if (not (wild-pathname-p pathname))
3867 (probe-file pathname)))))))
3868
3869 (defmethod inspect-for-emacs ((n number) inspector)
3870 (declare (ignore inspector))
3871 (values "A number." `("Value: " ,(princ-to-string n))))
3872
3873 (defun format-iso8601-time (time-value &optional include-timezone-p)
3874 "Formats a universal time TIME-VALUE in ISO 8601 format, with
3875 the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
3876 ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
3877 ;; Thanks, Nikolai Sandved and Thomas Russ!
3878 (flet ((format-iso8601-timezone (zone)
3879 (if (zerop zone)
3880 "Z"
3881 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3882 ;; Tricky. Sign of time zone is reversed in ISO 8601
3883 ;; relative to Common Lisp convention!
3884 (format nil "~:[+~;-~]~2,'0D:~2,'0D"
3885 (> zone 0) h (round m))))))
3886 (multiple-value-bind (second minute hour day month year dow dst zone)
3887 (decode-universal-time time-value)
3888 (declare (ignore dow dst))
3889 (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
3890 year month day hour minute second
3891 include-timezone-p (format-iso8601-timezone zone)))))
3892
3893 (defmethod inspect-for-emacs ((i integer) inspector)
3894 (declare (ignore inspector))
3895 (values "A number."
3896 (append
3897 `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8:B = ~E"
3898 i i i i i)
3899 (:newline))
3900 (if (< -1 i char-code-limit)
3901 (label-value-line "Corresponding character" (code-char i)))
3902 (label-value-line "Length" (integer-length i))
3903 (ignore-errors
3904 (list "As time: "
3905 (format-iso8601-time i t))))))
3906
3907 (defmethod inspect-for-emacs ((c complex) inspector)
3908 (declare (ignore inspector))
3909 (values "A complex number."
3910 (label-value-line*
3911 ("Real part" (realpart c))
3912 ("Imaginary part" (imagpart c)))))
3913
3914 (defmethod inspect-for-emacs ((r ratio) inspector)
3915 (declare (ignore inspector))
3916 (values "A non-integer ratio."
3917 (label-value-line*
3918 ("Numerator" (numerator r))
3919 ("Denominator" (denominator r))
3920 ("As float" (float r)))))
3921
3922 (defmethod inspect-for-emacs ((f float) inspector)
3923 (declare (ignore inspector))
3924 (multiple-value-bind (significand exponent sign) (decode-float f)
3925 (values "A floating point number."
3926 (append
3927 `("Scientific: " ,(format nil "~E" f) (:newline)
3928 "Decoded: "
3929 (:value ,sign) " * "
3930 (:value ,significand) " * "
3931 (:value ,(float-radix f)) "^" (:value ,exponent) (:newline))
3932 (label-value-line "Digits" (float-digits f))
3933 (label-value-line "Precision" (float-precision f))))))
3934
3935 (defvar *inspectee*)
3936 (defvar *inspectee-parts*)
3937 (defvar *inspectee-actions*)
3938 (defvar *inspector-stack* '())
3939 (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
3940 (declaim (type vector *inspector-history*))
3941 (defvar *inspect-length* 30)
3942
3943 (defun reset-inspector ()
3944 (setq *inspectee* nil
3945 *inspector-stack* nil
3946 *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
3947 *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
3948 *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
3949
3950 (defslimefun init-inspector (string)
3951 (with-buffer-syntax ()
3952 (reset-inspector)
3953 (inspect-object (eval (read-from-string string)))))
3954
3955 (defun print-part-to-string (value)
3956 (let ((string (to-string value))
3957 (pos (position value *inspector-history*)))
3958 (if pos
3959 (format nil "#~D=~A" pos string)
3960 string)))
3961
3962 (defun inspector-content-for-emacs (specs)
3963 (loop for part in specs collect
3964 (etypecase part
3965 (null ; XXX encourages sloppy programming
3966 nil)
3967 (string part)
3968 (cons (destructure-case part
3969 ((:newline)
3970 (string #\newline))
3971 ((:value obj &optional str)
3972 (value-part-for-emacs obj str))
3973 ((:action label lambda)
3974 (action-part-for-emacs label lambda)))))))
3975
3976 (defun assign-index (object vector)
3977 (let ((index (fill-pointer vector)))
3978 (vector-push-extend object vector)
3979 index))
3980
3981 (defun value-part-for-emacs (object string)
3982 (list :value
3983 (or string (print-part-to-string object))
3984 (assign-index object *inspectee-parts*)))
3985
3986 (defun action-part-for-emacs (label lambda)
3987 (list :action label (assign-index lambda *inspectee-actions*)))
3988
3989 (defun inspect-object (object &optional (inspector (make-default-inspector)))
3990 (push (setq *inspectee* object) *inspector-stack*)
3991 (unless (find object *inspector-history*)
3992 (vector-push-extend object *inspector-history*))
3993 (let ((*print-pretty* nil) ; print everything in the same line
3994 (*print-circle* t)
3995 (*print-readably* nil))
3996 (multiple-value-bind (title content)
3997 (inspect-for-emacs object inspector)
3998 (list :title title
3999 :type (to-string (type-of object))
4000 :content (inspector-content-for-emacs content)))))
4001
4002 (defslimefun inspector-nth-part (index)
4003 (aref *inspectee-parts* index))
4004
4005 (defslimefun inspect-nth-part (index)
4006 (with-buffer-syntax ()
4007 (inspect-object (inspector-nth-part index))))
4008
4009 (defslimefun inspector-call-nth-action (index &rest args)
4010 (multiple-value-bind (value replace) (apply (aref *inspectee-actions* index) args)
4011 (if (eq replace :replace)
4012 value
4013 (inspect-object (pop *inspector-stack*)))))
4014
4015 (defslimefun inspector-pop ()
4016 "Drop the inspector stack and inspect the second element. Return
4017 nil if there's no second element."
4018 (with-buffer-syntax ()
4019 (cond ((cdr *inspector-stack*)
4020 (pop *inspector-stack*)
4021 (inspect-object (pop *inspector-stack*)))
4022 (t nil))))
4023
4024 (defslimefun inspector-next ()
4025 "Inspect the next element in the *inspector-history*."
4026 (with-buffer-syntax ()
4027 (let ((position (position *inspectee* *inspector-history*)))
4028 (cond ((= (1+ position) (length *inspector-history*))
4029 nil)
4030 (t (inspect-object (aref *inspector-history* (1+ position))))))))
4031
4032 (defslimefun inspector-reinspect ()
4033 (inspect-object *inspectee*))
4034
4035 (defslimefun quit-inspector ()
4036 (reset-inspector)
4037 nil)
4038
4039 (defslimefun describe-inspectee ()
4040 "Describe the currently inspected object."
4041 (with-buffer-syntax ()
4042 (describe-to-string *inspectee*)))
4043
4044 (defslimefun inspect-in-frame (string index)
4045 (with-buffer-syntax ()
4046 (reset-inspector)
4047 (inspect-object (eval-in-frame (from-string string) index))))
4048
4049 (defslimefun inspect-current-condition ()
4050 (with-buffer-syntax ()
4051 (reset-inspector)
4052 (inspect-object *swank-debugger-condition*)))
4053
4054 (defslimefun inspect-frame-var (frame var)
4055 (with-buffer-syntax ()
4056 (reset-inspector)
4057 (inspect-object (frame-var-value frame var))))
4058
4059
4060 ;;;; Thread listing
4061
4062 (defvar *thread-list* ()
4063 "List of threads displayed in Emacs. We don't care a about
4064 synchronization issues (yet). There can only be one thread listing at
4065 a time.")
4066
4067 (defslimefun list-threads ()
4068 "Return a list ((NAME DESCRIPTION) ...) of all threads."
4069 (setq *thread-list* (all-threads))
4070 (loop for thread in *thread-list*
4071 for name = (thread-name thread)
4072 collect (list (if (symbolp name) (symbol-name name) name)
4073 (thread-status thread)
4074 (thread-id thread))))
4075
4076 (defslimefun quit-thread-browser ()
4077 (setq *thread-list* nil))
4078
4079 (defun nth-thread (index)
4080 (nth index *thread-list*))
4081
4082 (defslimefun debug-nth-thread (index)
4083 (let ((connection *emacs-connection*))
4084 (interrupt-thread (nth-thread index)
4085 (lambda ()
4086 (with-connection (connection)
4087 (simple-break))))))
4088
4089 (defslimefun kill-nth-thread (index)
4090 (kill-thread (nth-thread index)))
4091
4092 (defslimefun start-swank-server-in-thread (index port-file-name)
4093 "Interrupt the INDEXth thread and make it start a swank server.
4094 The server port is written to PORT-FILE-NAME."
4095 (interrupt-thread (nth-thread index)
4096 (lambda ()
4097 (start-server port-file-name :style nil))))
4098
4099 ;;;; Class browser
4100
4101 (defun mop-helper (class-name fn)
4102 (let ((class (find-class class-name nil)))
4103 (if class
4104 (mapcar (lambda (x) (to-string (class-name x)))
4105 (funcall fn class)))))
4106
4107 (defslimefun mop (type symbol-name)
4108 "Return info about classes using mop.
4109
4110 When type is:
4111 :subclasses - return the list of subclasses of class.
4112 :superclasses - return the list of superclasses of class."
4113 (let ((symbol (parse-symbol symbol-name *buffer-package*)))
4114 (ecase type
4115 (:subclasses
4116 (mop-helper symbol #'swank-mop:class-direct-subclasses))
4117 (:superclasses
4118 (mop-helper symbol #'swank-mop:class-direct-superclasses)))))
4119
4120
4121 ;;;; Automatically synchronized state
4122 ;;;
4123 ;;; Here we add hooks to push updates of relevant information to
4124 ;;; Emacs.
4125
4126 ;;;;; *FEATURES*
4127
4128 (defun sync-features-to-emacs ()
4129 "Update Emacs if any relevant Lisp state has changed."
4130 ;; FIXME: *slime-features* should be connection-local
4131 (unless (eq *slime-features* *features*)
4132 (setq *slime-features* *features*)
4133 (send-to-emacs (list :new-features (features-for-emacs)))))
4134
4135 (defun features-for-emacs ()
4136 "Return `*slime-features*' in a format suitable to send it to Emacs."
4137 *slime-features*)
4138
4139 (add-hook *pre-reply-hook* 'sync-features-to-emacs)
4140
4141
4142 ;;;;; Indentation of macros
4143 ;;;
4144 ;;; This code decides how macros should be indented (based on their
4145 ;;; arglists) and tells Emacs. A per-connection cache is used to avoid
4146 ;;; sending redundant information to Emacs -- we just say what's
4147 ;;; changed since last time.
4148 ;;;
4149 ;;; The strategy is to scan all symbols, pick out the macros, and look
4150 ;;; for &body-arguments.
4151
4152 (defvar *configure-emacs-indentation* t
4153 "When true, automatically send indentation information to Emacs
4154 after each command.")
4155
4156 (defslimefun update-indentation-information ()
4157 (perform-indentation-update *emacs-connection* t))
4158
4159 ;; This function is for *PRE-REPLY-HOOK*.
4160 (defun sync-indentation-to-emacs ()
4161 "Send any indentation updates to Emacs via CONNECTION."
4162 (when *configure-emacs-indentation*
4163 (let ((fullp (need-full-indentation-update-p *emacs-connection*)))
4164 (perform-indentation-update *emacs-connection* fullp))))
4165
4166 (defun need-full-indentation-update-p (connection)
4167 "Return true if the whole indentation cache should be updated.
4168 This is a heuristic to avoid scanning all symbols all the time:
4169 instead, we only do a full scan if the set of packages has changed."
4170 (set-difference (list-all-packages)
4171 (connection.indentation-cache-packages connection)))
4172
4173 (defun perform-indentation-update (connection force)
4174 "Update the indentation cache in CONNECTION and update Emacs.
4175 If FORCE is true then start again without considering the old cache."
4176 (let ((cache (connection.indentation-cache connection)))
4177 (when force (clrhash cache))
4178 (let ((delta (update-indentation/delta-for-emacs cache force)))
4179 (setf (connection.indentation-cache-packages connection)
4180 (list-all-packages))
4181 (unless (null delta)
4182 (send-to-emacs (list :indentation-update delta))))))
4183
4184 (defun update-indentation/delta-for-emacs (cache &optional force)
4185 "Update the cache and return the changes in a (SYMBOL . INDENT) list.
4186 If FORCE is true then check all symbols, otherwise only check symbols
4187 belonging to the buffer package."
4188 (let ((alist '()))
4189 (flet ((consider (symbol)
4190 (let ((indent (symbol-indentation symbol)))
4191 (when indent
4192 (unless (equal (gethash symbol cache) indent)
4193 (setf (gethash symbol cache) indent)
4194 (push (cons (string-downcase symbol) indent) alist))))))
4195 (if force
4196 (do-all-symbols (symbol)
4197 (consider symbol))
4198 (do-symbols (symbol *buffer-package*)
4199 (when (eq (symbol-package symbol) *buffer-package*)
4200 (consider symbol)))))
4201 alist))
4202
4203 (defun package-names (package)
4204 "Return the name and all nicknames of PACKAGE in a list."
4205 (cons (package-name package) (package-nicknames package)))
4206
4207 (defun cl-symbol-p (symbol)
4208 "Is SYMBOL a symbol in the COMMON-LISP package?"
4209 (eq (symbol-package symbol) cl-package))
4210
4211 (defun known-to-emacs-p (symbol)
4212 "Return true if Emacs has special rules for indenting SYMBOL."
4213 (cl-symbol-p symbol))
4214
4215 (defun symbol-indentation (symbol)
4216 "Return a form describing the indentation of SYMBOL.
4217 The form is to be used as the `common-lisp-indent-function' property
4218 in Emacs."
4219 (if (and (macro-function symbol)
4220 (not (known-to-emacs-p symbol)))
4221 (let ((arglist (arglist symbol)))
4222 (etypecase arglist
4223 ((member :not-available)
4224 nil)
4225 (list
4226 (macro-indentation arglist))))
4227 nil))
4228
4229 (defun macro-indentation (arglist)
4230 (if (well-formed-list-p arglist)
4231 (position '&body (clean-arglist arglist))
4232 nil))
4233
4234 (defun well-formed-list-p (list)
4235 "Is LIST a proper list terminated by NIL?"
4236 (typecase list
4237 (null t)
4238