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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.291 - (show annotations)
Fri Apr 1 19:55:18 2005 UTC (9 years ago) by heller
Branch: MAIN
Changes since 1.290: +24 -15 lines
(spawn-repl-thread): Use *default-worker-thread-bindings* just like
spawn-worker-thread.

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

  ViewVC Help
Powered by ViewVC 1.1.5