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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.288 - (show annotations)
Wed Mar 16 22:03:18 2005 UTC (9 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.287: +40 -31 lines
(*macroexpand-printer-bindings*): New user variable.
(apply-macro-expander): Use it.

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

  ViewVC Help
Powered by ViewVC 1.1.5