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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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