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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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