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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5