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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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