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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.356 - (show annotations)
Tue Dec 27 15:12:22 2005 UTC (8 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.355: +55 -4 lines
(log-event): Record the event in the history buffer.
(*event-history*, *event-history-index*, *enable-event-history*): Ring
buffer for events.
(dump-event-history, dump-event, escape-non-ascii, ascii-string-p)
(ascii-char-p): New functions.

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