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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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