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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.298 - (show annotations)
Thu May 12 19:04:41 2005 UTC (8 years, 11 months ago) by aruttenberg
Branch: MAIN
Changes since 1.297: +53 -8 lines
2005-05-12  Alan Ruttenberg  <alanr-l@mumble.net>

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

  ViewVC Help
Powered by ViewVC 1.1.5