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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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