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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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