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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.388 - (show annotations)
Wed Aug 9 16:46:10 2006 UTC (7 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.387: +27 -18 lines
(test-print-arglist): Print a message instead of signalling an
error. This should avoid startup problems (in particular with
CormanLisp).

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