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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.315 - (show annotations)
Thu Aug 4 19:23:13 2005 UTC (8 years, 8 months ago) by mkoeppe
Branch: MAIN
Changes since 1.314: +4 -3 lines
(encode-message): Don't use the pretty printer for printing the
message length.

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

  ViewVC Help
Powered by ViewVC 1.1.5