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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.339 - (show annotations)
Wed Sep 21 11:41:51 2005 UTC (8 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.338: +20 -17 lines
(make-output-function): Rename :read-output to :write-string.

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