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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.358 - (show annotations)
Mon Jan 30 19:07:43 2006 UTC (8 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.357: +36 -2 lines
Patch from Luís Oliveira.

Extend slime-echo-arglist to display initargs and initforms when
make-instance is detected.

* slime.el (slime-enclosing-operator-names): detect make-instance
forms and collect the class-name argument if it exists and is a
quoted symbol.

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