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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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