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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.445 - (show annotations)
Sun Dec 31 12:28:28 2006 UTC (7 years, 3 months ago) by mkoeppe
Branch: MAIN
Changes since 1.444: +21 -5 lines
(connection): New slot repl-results (a stream).
(make-output-function-for-target): New.
(open-streams): Use it here to also create a stream for REPL results.
(initialize-streams-for-connection): Store the stream.
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-nome
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 (string-downcase (symbol-name form)))
1219 (number (let ((*print-base* 10))
1220 (princ-to-string form)))))
1221
1222 (defun eval-in-emacs (form &optional nowait)
1223 "Eval FORM in Emacs."
1224 (cond (nowait
1225 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1226 (t
1227 (force-output)
1228 (let* ((tag (incf *read-input-catch-tag*))
1229 (value (catch (intern-catch-tag tag)
1230 (send-to-emacs
1231 `(:eval ,(current-thread) ,tag
1232 ,(process-form-for-emacs form)))
1233 (loop (read-from-emacs)))))
1234 (destructure-case value
1235 ((:ok value) value)
1236 ((:abort) (abort)))))))
1237
1238 (defun present-in-emacs (value-or-values &key (separated-by " "))
1239 "Present VALUE in the Emacs repl buffer of the current thread."
1240 (unless (consp value-or-values)
1241 (setf value-or-values (list value-or-values)))
1242 (flet ((present (value)
1243 (if (stringp value)
1244 (send-to-emacs `(:write-string ,value))
1245 (let ((id (save-presented-object value)))
1246 (send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
1247 (map nil (let ((first-time-p t))
1248 (lambda (value)
1249 (when (and (not first-time-p)
1250 separated-by)
1251 (present separated-by))
1252 (present value)
1253 (setf first-time-p nil)))
1254 value-or-values))
1255 (values))
1256
1257 (defvar *swank-wire-protocol-version* nil
1258 "The version of the swank/slime communication protocol.")
1259
1260 (defslimefun connection-info ()
1261 "Return a key-value list of the form:
1262 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1263 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1264 STYLE: the communication style
1265 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1266 FEATURES: a list of keywords
1267 PACKAGE: a list (&key NAME PROMPT)
1268 VERSION: the protocol version"
1269 (setq *slime-features* *features*)
1270 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1271 :lisp-implementation (:type ,(lisp-implementation-type)
1272 :name ,(lisp-implementation-type-name)
1273 :version ,(lisp-implementation-version))
1274 :machine (:instance ,(machine-instance)
1275 :type ,(machine-type)
1276 :version ,(machine-version))
1277 :features ,(features-for-emacs)
1278 :package (:name ,(package-name *package*)
1279 :prompt ,(package-string-for-prompt *package*))
1280 :version ,*swank-wire-protocol-version*))
1281
1282 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1283 (let* ((s *standard-output*)
1284 (*trace-output* (make-broadcast-stream s *log-output*)))
1285 (time (progn
1286 (dotimes (i n)
1287 (format s "~D abcdefghijklm~%" i)
1288 (when (zerop (mod n m))
1289 (force-output s)))
1290 (finish-output s)
1291 (when *emacs-connection*
1292 (eval-in-emacs '(message "done.")))))
1293 (terpri *trace-output*)
1294 (finish-output *trace-output*)
1295 nil))
1296
1297
1298 ;;;; Reading and printing
1299
1300 (defmacro define-special (name doc)
1301 "Define a special variable NAME with doc string DOC.
1302 This is like defvar, but NAME will not be initialized."
1303 `(progn
1304 (defvar ,name)
1305 (setf (documentation ',name 'variable) ,doc)))
1306
1307 (define-special *buffer-package*
1308 "Package corresponding to slime-buffer-package.
1309
1310 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1311 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1312
1313 (define-special *buffer-readtable*
1314 "Readtable associated with the current buffer")
1315
1316 (defmacro with-buffer-syntax ((&rest _) &body body)
1317 "Execute BODY with appropriate *package* and *readtable* bindings.
1318
1319 This should be used for code that is conceptionally executed in an
1320 Emacs buffer."
1321 (destructuring-bind () _
1322 `(call-with-buffer-syntax (lambda () ,@body))))
1323
1324 (defun call-with-buffer-syntax (fun)
1325 (let ((*package* *buffer-package*))
1326 ;; Don't shadow *readtable* unnecessarily because that prevents
1327 ;; the user from assigning to it.
1328 (if (eq *readtable* *buffer-readtable*)
1329 (call-with-syntax-hooks fun)
1330 (let ((*readtable* *buffer-readtable*))
1331 (call-with-syntax-hooks fun)))))
1332
1333 (defun to-string (object)
1334 "Write OBJECT in the *BUFFER-PACKAGE*.
1335 The result may not be readable. Handles problems with PRINT-OBJECT methods
1336 gracefully."
1337 (with-buffer-syntax ()
1338 (let ((*print-readably* nil))
1339 (handler-case
1340 (prin1-to-string object)
1341 (error ()
1342 (with-output-to-string (s)
1343 (print-unreadable-object (object s :type t :identity t)
1344 (princ "<<error printing object>>" s))))))))
1345
1346 (defun from-string (string)
1347 "Read string in the *BUFFER-PACKAGE*"
1348 (with-buffer-syntax ()
1349 (let ((*read-suppress* nil))
1350 (read-from-string string))))
1351
1352 ;; FIXME: deal with #\| etc. hard to do portably.
1353 (defun tokenize-symbol (string)
1354 (let ((package (let ((pos (position #\: string)))
1355 (if pos (subseq string 0 pos) nil)))
1356 (symbol (let ((pos (position #\: string :from-end t)))
1357 (if pos (subseq string (1+ pos)) string)))
1358 (internp (search "::" string)))
1359 (values symbol package internp)))
1360
1361 (defun tokenize-symbol-thoroughly (string)
1362 "This version of tokenize-symbol handles escape characters."
1363 (let ((package nil)
1364 (token (make-array (length string) :element-type 'character
1365 :fill-pointer 0))
1366 (backslash nil)
1367 (vertical nil)
1368 (internp nil))
1369 (loop for char across string
1370 do (cond
1371 (backslash
1372 (vector-push-extend char token)
1373 (setq backslash nil))
1374 ((char= char #\\) ; Quotes next character, even within |...|
1375 (setq backslash t))
1376 ((char= char #\|)
1377 (setq vertical t))
1378 (vertical
1379 (vector-push-extend char token))
1380 ((char= char #\:)
1381 (if package
1382 (setq internp t)
1383 (setq package token
1384 token (make-array (length string)
1385 :element-type 'character
1386 :fill-pointer 0))))
1387 (t
1388 (vector-push-extend (casify-char char) token))))
1389 (values token package internp)))
1390
1391 (defun casify-char (char)
1392 "Convert CHAR accoring to readtable-case."
1393 (ecase (readtable-case *readtable*)
1394 (:preserve char)
1395 (:upcase (char-upcase char))
1396 (:downcase (char-downcase char))
1397 (:invert (if (upper-case-p char)
1398 (char-downcase char)
1399 (char-upcase char)))))
1400
1401 (defun parse-symbol (string &optional (package *package*))
1402 "Find the symbol named STRING.
1403 Return the symbol and a flag indicating whether the symbols was found."
1404 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1405 (let ((package (cond ((string= pname "") keyword-package)
1406 (pname (find-package pname))
1407 (t package))))
1408 (if package
1409 (find-symbol sname package)
1410 (values nil nil)))))
1411
1412 (defun parse-symbol-or-lose (string &optional (package *package*))
1413 (multiple-value-bind (symbol status) (parse-symbol string package)
1414 (if status
1415 (values symbol status)
1416 (error "Unknown symbol: ~A [in ~A]" string package))))
1417
1418 ;; FIXME: interns the name
1419 (defun parse-package (string)
1420 "Find the package named STRING.
1421 Return the package or nil."
1422 (multiple-value-bind (name pos)
1423 (if (zerop (length string))
1424 (values :|| 0)
1425 (let ((*package* *swank-io-package*))
1426 (ignore-errors (read-from-string string))))
1427 (and name
1428 (or (symbolp name)
1429 (stringp name))
1430 (= (length string) pos)
1431 (find-package name))))
1432
1433 (defun guess-package-from-string (name &optional (default-package *package*))
1434 (or (and name
1435 (or (parse-package name)
1436 (find-package (string-upcase name))
1437 (parse-package (substitute #\- #\! name))))
1438 default-package))
1439
1440 (defvar *readtable-alist* (default-readtable-alist)
1441 "An alist mapping package names to readtables.")
1442
1443 (defun guess-buffer-readtable (package-name &optional (default *readtable*))
1444 (let ((package (guess-package-from-string package-name)))
1445 (if package
1446 (or (cdr (assoc (package-name package) *readtable-alist*
1447 :test #'string=))
1448 default)
1449 default)))
1450
1451 (defun valid-operator-symbol-p (symbol)
1452 "Test if SYMBOL names a function, macro, or special-operator."
1453 (or (fboundp symbol)
1454 (macro-function symbol)
1455 (special-operator-p symbol)))
1456
1457 (defun valid-operator-name-p (string)
1458 "Test if STRING names a function, macro, or special-operator."
1459 (let ((symbol (parse-symbol string)))
1460 (valid-operator-symbol-p symbol)))
1461
1462
1463 ;;;; Arglists
1464
1465 (defun find-valid-operator-name (names)
1466 "As a secondary result, returns its index."
1467 (let ((index
1468 (position-if (lambda (name)
1469 (or (consp name)
1470 (valid-operator-name-p name)))
1471 names)))
1472 (if index
1473 (values (elt names index) index)
1474 (values nil nil))))
1475
1476 (defslimefun arglist-for-echo-area (names &key print-right-margin
1477 print-lines arg-indices)
1478 "Return the arglist for the first function, macro, or special-op in NAMES."
1479 (handler-case
1480 (with-buffer-syntax ()
1481 (multiple-value-bind (name which)
1482 (find-valid-operator-name names)
1483 (when which
1484 (let ((arg-index (and arg-indices (elt arg-indices which))))
1485 (multiple-value-bind (form operator-name)
1486 (operator-designator-to-form name)
1487 (let ((*print-right-margin* print-right-margin))
1488 (format-arglist-for-echo-area
1489 form operator-name
1490 :print-right-margin print-right-margin
1491 :print-lines print-lines
1492 :highlight (and arg-index
1493 (not (zerop arg-index))
1494 ;; don't highlight the operator
1495 arg-index))))))))
1496 (error (cond)
1497 (format nil "ARGLIST: ~A" cond))))
1498
1499 (defun operator-designator-to-form (name)
1500 (etypecase name
1501 (cons
1502 (destructure-case name
1503 ((:make-instance class-name operator-name &rest args)
1504 (let ((parsed-operator-name (parse-symbol operator-name)))
1505 (values `(,parsed-operator-name ,@args ',(parse-symbol class-name))
1506 operator-name)))
1507 ((:defmethod generic-name)
1508 (values `(defmethod ,(parse-symbol generic-name))
1509 'defmethod))))
1510 (string
1511 (values `(,(parse-symbol name))
1512 name))))
1513
1514 (defun clean-arglist (arglist)
1515 "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1516 (cond ((null arglist) '())
1517 ((member (car arglist) '(&whole &environment))
1518 (clean-arglist (cddr arglist)))
1519 ((eq (car arglist) '&aux)
1520 '())
1521 (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1522
1523 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1524 provided-args ; list of the provided actual arguments
1525 required-args ; list of the required arguments
1526 optional-args ; list of the optional arguments
1527 key-p ; whether &key appeared
1528 keyword-args ; list of the keywords
1529 rest ; name of the &rest or &body argument (if any)
1530 body-p ; whether the rest argument is a &body
1531 allow-other-keys-p ; whether &allow-other-keys appeared
1532 aux-args ; list of &aux variables
1533 known-junk ; &whole, &environment
1534 unknown-junk) ; unparsed stuff
1535
1536 (defun print-arglist (arglist &key operator highlight)
1537 (let ((index 0)
1538 (need-space nil))
1539 (labels ((print-arg (arg)
1540 (typecase arg
1541 (arglist ; destructuring pattern
1542 (print-arglist arg))
1543 (optional-arg
1544 (princ (encode-optional-arg arg)))
1545 (keyword-arg
1546 (let ((enc-arg (encode-keyword-arg arg)))
1547 (etypecase enc-arg
1548 (symbol (princ enc-arg))
1549 ((cons symbol)
1550 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1551 (princ (car enc-arg))
1552 (write-char #\space)
1553 (pprint-fill *standard-output* (cdr enc-arg) nil)))
1554 ((cons cons)
1555 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1556 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1557 (prin1 (caar enc-arg))
1558 (write-char #\space)
1559 (print-arg (keyword-arg.arg-name arg)))
1560 (unless (null (cdr enc-arg))
1561 (write-char #\space))
1562 (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1563 (t ; required formal or provided actual arg
1564 (princ arg))))
1565 (print-space ()
1566 (ecase need-space
1567 ((nil))
1568 ((:miser)
1569 (write-char #\space)
1570 (pprint-newline :miser))
1571 ((t)
1572 (write-char #\space)
1573 (pprint-newline :fill)))
1574 (setq need-space t))
1575 (print-with-space (obj)
1576 (print-space)
1577 (print-arg obj))
1578 (print-with-highlight (arg &optional (index-ok-p #'=))
1579 (print-space)
1580 (cond
1581 ((and highlight (funcall index-ok-p index highlight))
1582 (princ "===> ")
1583 (print-arg arg)
1584 (princ " <==="))
1585 (t
1586 (print-arg arg)))
1587 (incf index)))
1588 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1589 (when operator
1590 (print-with-highlight operator)
1591 (setq need-space :miser))
1592 (mapc #'print-with-highlight
1593 (arglist.provided-args arglist))
1594 (mapc #'print-with-highlight
1595 (arglist.required-args arglist))
1596 (when (arglist.optional-args arglist)
1597 (print-with-space '&optional)
1598 (mapc #'print-with-highlight
1599 (arglist.optional-args arglist)))
1600 (when (arglist.key-p arglist)
1601 (print-with-space '&key)
1602 (mapc #'print-with-space
1603 (arglist.keyword-args arglist)))
1604 (when (arglist.allow-other-keys-p arglist)
1605 (print-with-space '&allow-other-keys))
1606 (cond ((not (arglist.rest arglist)))
1607 ((arglist.body-p arglist)
1608 (print-with-space '&body)
1609 (print-with-highlight (arglist.rest arglist) #'<=))
1610 (t
1611 (print-with-space '&rest)
1612 (print-with-highlight (arglist.rest arglist) #'<=)))
1613 (mapc #'print-with-space
1614 (arglist.unknown-junk arglist))))))
1615
1616 (defun decoded-arglist-to-string (arglist package
1617 &key operator print-right-margin
1618 print-lines highlight)
1619 "Print the decoded ARGLIST for display in the echo area. The
1620 argument name are printed without package qualifiers and pretty
1621 printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
1622 non-nil, it must be the index of an argument; highlight this argument.
1623 If OPERATOR is non-nil, put it in front of the arglist."
1624 (with-output-to-string (*standard-output*)
1625 (with-standard-io-syntax
1626 (let ((*package* package) (*print-case* :downcase)
1627 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1628 (*print-level* 10) (*print-length* 20)
1629 (*print-right-margin* print-right-margin)
1630 (*print-lines* print-lines))
1631 (print-arglist arglist :operator operator :highlight highlight)))))
1632
1633 (defslimefun variable-desc-for-echo-area (variable-name)
1634 "Return a short description of VARIABLE-NAME, or NIL."
1635 (with-buffer-syntax ()
1636 (let ((sym (parse-symbol variable-name)))
1637 (if (and sym (boundp sym))
1638 (let ((*print-pretty* nil) (*print-level* 4)
1639 (*print-length* 10) (*print-circle* t))
1640 (format nil "~A => ~A" sym (symbol-value sym)))))))
1641
1642 (defun decode-required-arg (arg)
1643 "ARG can be a symbol or a destructuring pattern."
1644 (etypecase arg
1645 (symbol arg)
1646 (list (decode-arglist arg))))
1647
1648 (defun encode-required-arg (arg)
1649 (etypecase arg
1650 (symbol arg)
1651 (arglist (encode-arglist arg))))
1652
1653 (defstruct (keyword-arg
1654 (:conc-name keyword-arg.)
1655 (:constructor make-keyword-arg (keyword arg-name default-arg)))
1656 keyword
1657 arg-name
1658 default-arg)
1659
1660 (defun decode-keyword-arg (arg)
1661 "Decode a keyword item of formal argument list.
1662 Return three values: keyword, argument name, default arg."
1663 (cond ((symbolp arg)
1664 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1665 arg
1666 nil))
1667 ((and (consp arg)
1668 (consp (car arg)))
1669 (make-keyword-arg (caar arg)
1670 (decode-required-arg (cadar arg))
1671 (cadr arg)))
1672 ((consp arg)
1673 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1674 (car arg)
1675 (cadr arg)))
1676 (t
1677 (abort-request "Bad keyword item of formal argument list"))))
1678
1679 (defun encode-keyword-arg (arg)
1680 (cond
1681 ((arglist-p (keyword-arg.arg-name arg))
1682 ;; Destructuring pattern
1683 (let ((keyword/name (list (keyword-arg.keyword arg)
1684 (encode-required-arg
1685 (keyword-arg.arg-name arg)))))
1686 (if (keyword-arg.default-arg arg)
1687 (list keyword/name
1688 (keyword-arg.default-arg arg))
1689 (list keyword/name))))
1690 ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1691 keyword-package)
1692 (keyword-arg.keyword arg))
1693 (if (keyword-arg.default-arg arg)
1694 (list (keyword-arg.arg-name arg)
1695 (keyword-arg.default-arg arg))
1696 (keyword-arg.arg-name arg)))
1697 (t
1698 (let ((keyword/name (list (keyword-arg.keyword arg)
1699 (keyword-arg.arg-name arg))))
1700 (if (keyword-arg.default-arg arg)
1701 (list keyword/name
1702 (keyword-arg.default-arg arg))
1703 (list keyword/name))))))
1704
1705 (progn
1706 (assert (equalp (decode-keyword-arg 'x)
1707 (make-keyword-arg :x 'x nil)))
1708 (assert (equalp (decode-keyword-arg '(x t))
1709 (make-keyword-arg :x 'x t)))
1710 (assert (equalp (decode-keyword-arg '((:x y)))
1711 (make-keyword-arg :x 'y nil)))
1712 (assert (equalp (decode-keyword-arg '((:x y) t))
1713 (make-keyword-arg :x 'y t))))
1714
1715 (defstruct (optional-arg
1716 (:conc-name optional-arg.)
1717 (:constructor make-optional-arg (arg-name default-arg)))
1718 arg-name
1719 default-arg)
1720
1721 (defun decode-optional-arg (arg)
1722 "Decode an optional item of a formal argument list.
1723 Return an OPTIONAL-ARG structure."
1724 (etypecase arg
1725 (symbol (make-optional-arg arg nil))
1726 (list (make-optional-arg (decode-required-arg (car arg))
1727 (cadr arg)))))
1728
1729 (defun encode-optional-arg (optional-arg)
1730 (if (or (optional-arg.default-arg optional-arg)
1731 (arglist-p (optional-arg.arg-name optional-arg)))
1732 (list (encode-required-arg
1733 (optional-arg.arg-name optional-arg))
1734 (optional-arg.default-arg optional-arg))
1735 (optional-arg.arg-name optional-arg)))
1736
1737 (progn
1738 (assert (equalp (decode-optional-arg 'x)
1739 (make-optional-arg 'x nil)))
1740 (assert (equalp (decode-optional-arg '(x t))
1741 (make-optional-arg 'x t))))
1742
1743 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1744
1745 (defun decode-arglist (arglist)
1746 "Parse the list ARGLIST and return an ARGLIST structure."
1747 (let ((mode nil)
1748 (result (make-arglist)))
1749 (dolist (arg arglist)
1750 (cond
1751 ((eql mode '&unknown-junk)
1752 ;; don't leave this mode -- we don't know how the arglist
1753 ;; after unknown lambda-list keywords is interpreted
1754 (push arg (arglist.unknown-junk result)))
1755 ((eql arg '&allow-other-keys)
1756 (setf (arglist.allow-other-keys-p result) t))
1757 ((eql arg '&key)
1758 (setf (arglist.key-p result) t
1759 mode arg))
1760 ((member arg '(&optional &rest &body &aux))
1761 (setq mode arg))
1762 ((member arg '(&whole &environment))
1763 (setq mode arg)
1764 (push arg (arglist.known-junk result)))
1765 ((member arg lambda-list-keywords)
1766 (setq mode '&unknown-junk)
1767 (push arg (arglist.unknown-junk result)))
1768 (t
1769 (ecase mode
1770 (&key
1771 (push (decode-keyword-arg arg)
1772 (arglist.keyword-args result)))
1773 (&optional
1774 (push (decode-optional-arg arg)
1775 (arglist.optional-args result)))
1776 (&body
1777 (setf (arglist.body-p result) t
1778 (arglist.rest result) arg))
1779 (&rest
1780 (setf (arglist.rest result) arg))
1781 (&aux
1782 (push (decode-optional-arg arg)
1783 (arglist.aux-args result)))
1784 ((nil)
1785 (push (decode-required-arg arg)
1786 (arglist.required-args result)))
1787 ((&whole &environment)
1788 (setf mode nil)
1789 (push arg (arglist.known-junk result)))))))
1790 (nreversef (arglist.required-args result))
1791 (nreversef (arglist.optional-args result))
1792 (nreversef (arglist.keyword-args result))
1793 (nreversef (arglist.aux-args result))
1794 (nreversef (arglist.known-junk result))
1795 (nreversef (arglist.unknown-junk result))
1796 result))
1797
1798 (defun encode-arglist (decoded-arglist)
1799 (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
1800 (when (arglist.optional-args decoded-arglist)
1801 '(&optional))
1802 (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1803 (when (arglist.key-p decoded-arglist)
1804 '(&key))
1805 (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1806 (when (arglist.allow-other-keys-p decoded-arglist)
1807 '(&allow-other-keys))
1808 (cond ((not (arglist.rest decoded-arglist))
1809 '())
1810 ((arglist.body-p decoded-arglist)
1811 `(&body ,(arglist.rest decoded-arglist)))
1812 (t
1813 `(&rest ,(arglist.rest decoded-arglist))))
1814 (when (arglist.aux-args decoded-arglist)
1815 `(&aux ,(arglist.aux-args decoded-arglist)))
1816 (arglist.known-junk decoded-arglist)
1817 (arglist.unknown-junk decoded-arglist)))
1818
1819 (defun arglist-keywords (arglist)
1820 "Return the list of keywords in ARGLIST.
1821 As a secondary value, return whether &allow-other-keys appears."
1822 (let ((decoded-arglist (decode-arglist arglist)))
1823 (values (arglist.keyword-args decoded-arglist)
1824 (arglist.allow-other-keys-p decoded-arglist))))
1825
1826 (defun methods-keywords (methods)
1827 "Collect all keywords in the arglists of METHODS.
1828 As a secondary value, return whether &allow-other-keys appears somewhere."
1829 (let ((keywords '())
1830 (allow-other-keys nil))
1831 (dolist (method methods)
1832 (multiple-value-bind (kw aok)
1833 (arglist-keywords
1834 (swank-mop:method-lambda-list method))
1835 (setq keywords (remove-duplicates (append keywords kw)
1836 :key #'keyword-arg.keyword)
1837 allow-other-keys (or allow-other-keys aok))))
1838 (values keywords allow-other-keys)))
1839
1840 (defun generic-function-keywords (generic-function)
1841 "Collect all keywords in the methods of GENERIC-FUNCTION.
1842 As a secondary value, return whether &allow-other-keys appears somewhere."
1843 (methods-keywords
1844 (swank-mop:generic-function-methods generic-function)))
1845
1846 (defun applicable-methods-keywords (generic-function arguments)
1847 "Collect all keywords in the methods of GENERIC-FUNCTION that are
1848 applicable for argument of CLASSES. As a secondary value, return
1849 whether &allow-other-keys appears somewhere."
1850 (methods-keywords
1851 (multiple-value-bind (amuc okp)
1852 (swank-mop:compute-applicable-methods-using-classes
1853 generic-function (mapcar #'class-of arguments))
1854 (if okp
1855 amuc
1856 (compute-applicable-methods generic-function arguments)))))
1857
1858 (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1859 (with-output-to-string (*standard-output*)
1860 (with-standard-io-syntax
1861 (let ((*package* package) (*print-case* :downcase)
1862 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1863 (*print-level* 10) (*print-length* 20))
1864 (print-decoded-arglist-as-template decoded-arglist
1865 :prefix prefix
1866 :suffix suffix)))))
1867
1868 (defun print-decoded-arglist-as-template (decoded-arglist &key
1869 (prefix "(") (suffix ")"))
1870 (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1871 (let ((first-p t))
1872 (flet ((space ()
1873 (unless first-p
1874 (write-char #\space)
1875 (pprint-newline :fill))
1876 (setq first-p nil))
1877 (print-arg-or-pattern (arg)
1878 (etypecase arg
1879 (symbol (princ arg))
1880 (string (princ arg))
1881 (list (princ arg))
1882 (arglist (print-decoded-arglist-as-template arg)))))
1883 (dolist (arg (arglist.required-args decoded-arglist))
1884 (space)
1885 (print-arg-or-pattern arg))
1886 (dolist (arg (arglist.optional-args decoded-arglist))
1887 (space)
1888 (princ "[")
1889 (print-arg-or-pattern (optional-arg.arg-name arg))
1890 (princ "]"))
1891 (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1892 (space)
1893 (let ((arg-name (keyword-arg.arg-name keyword-arg))
1894 (keyword (keyword-arg.keyword keyword-arg)))
1895 (format t "~W "
1896 (if (keywordp keyword) keyword `',keyword))
1897 (print-arg-or-pattern arg-name)))
1898 (when (and (arglist.rest decoded-arglist)
1899 (or (not (arglist.keyword-args decoded-arglist))
1900 (arglist.allow-other-keys-p decoded-arglist)))
1901 (if (arglist.body-p decoded-arglist)
1902 (pprint-newline :mandatory)
1903 (space))
1904 (format t "~A..." (arglist.rest decoded-arglist)))))
1905 (pprint-newline :fill)))
1906
1907 (defgeneric extra-keywords (operator &rest args)
1908 (:documentation "Return a list of extra keywords of OPERATOR (a
1909 symbol) when applied to the (unevaluated) ARGS.
1910 As a secondary value, return whether other keys are allowed.
1911 As a tertiary value, return the initial sublist of ARGS that was needed
1912 to determine the extra keywords."))
1913
1914 (defmethod extra-keywords (operator &rest args)
1915 ;; default method
1916 (declare (ignore args))
1917 (let ((symbol-function (symbol-function operator)))
1918 (if (typep symbol-function 'generic-function)
1919 (generic-function-keywords symbol-function)
1920 nil)))
1921
1922 (defun class-from-class-name-form (class-name-form)
1923 (when (and (listp class-name-form)
1924 (= (length class-name-form) 2)
1925 (eq (car class-name-form) 'quote))
1926 (let* ((class-name (cadr class-name-form))
1927 (class (find-class class-name nil)))
1928 (when (and class
1929 (not (swank-mop:class-finalized-p class)))
1930 ;; Try to finalize the class, which can fail if
1931 ;; superclasses are not defined yet
1932 (handler-case (swank-mop:finalize-inheritance class)
1933 (program-error (c)
1934 (declare (ignore c)))))
1935 class)))
1936
1937 (defun extra-keywords/slots (class)
1938 (multiple-value-bind (slots allow-other-keys-p)
1939 (if (swank-mop:class-finalized-p class)
1940 (values (swank-mop:class-slots class) nil)
1941 (values (swank-mop:class-direct-slots class) t))
1942 (let ((slot-init-keywords
1943 (loop for slot in slots append
1944 (mapcar (lambda (initarg)
1945 (make-keyword-arg
1946 initarg
1947 (swank-mop:slot-definition-name slot)
1948 (swank-mop:slot-definition-initform slot)))
1949 (swank-mop:slot-definition-initargs slot)))))
1950 (values slot-init-keywords allow-other-keys-p))))
1951
1952 (defun extra-keywords/make-instance (operator &rest args)
1953 (declare (ignore operator))
1954 (unless (null args)
1955 (let* ((class-name-form (car args))
1956 (class (class-from-class-name-form class-name-form)))
1957 (when class
1958 (multiple-value-bind (slot-init-keywords class-aokp)
1959 (extra-keywords/slots class)
1960 (multiple-value-bind (allocate-instance-keywords ai-aokp)
1961 (applicable-methods-keywords
1962 #'allocate-instance (list class))
1963 (multiple-value-bind (initialize-instance-keywords ii-aokp)
1964 (applicable-methods-keywords
1965 #'initialize-instance (list (swank-mop:class-prototype class)))
1966 (multiple-value-bind (shared-initialize-keywords si-aokp)
1967 (applicable-methods-keywords
1968 #'shared-initialize (list (swank-mop:class-prototype class) t))
1969 (values (append slot-init-keywords
1970 allocate-instance-keywords
1971 initialize-instance-keywords
1972 shared-initialize-keywords)
1973 (or class-aokp ai-aokp ii-aokp si-aokp)
1974 (list class-name-form))))))))))
1975
1976 (defun extra-keywords/change-class (operator &rest args)
1977 (declare (ignore operator))
1978 (unless (null args)
1979 (let* ((class-name-form (car args))
1980 (class (class-from-class-name-form class-name-form)))
1981 (when class
1982 (multiple-value-bind (slot-init-keywords class-aokp)
1983 (extra-keywords/slots class)
1984 (declare (ignore class-aokp))
1985 (multiple-value-bind (shared-initialize-keywords si-aokp)
1986 (applicable-methods-keywords
1987 #'shared-initialize (list (swank-mop:class-prototype class) t))
1988 ;; FIXME: much as it would be nice to include the
1989 ;; applicable keywords from
1990 ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
1991 ;; how to do it: so we punt, always declaring
1992 ;; &ALLOW-OTHER-KEYS.
1993 (declare (ignore si-aokp))
1994 (values (append slot-init-keywords shared-initialize-keywords)
1995 t
1996 (list class-name-form))))))))
1997
1998 (defmacro multiple-value-or (&rest forms)
1999 (if (null forms)
2000 nil
2001 (let ((first (first forms))
2002 (rest (rest forms)))
2003 `(let* ((values (multiple-value-list ,first))
2004 (primary-value (first values)))
2005 (if primary-value
2006 (values-list values)
2007 (multiple-value-or ,@rest))))))
2008
2009 (defmethod extra-keywords ((operator (eql 'make-instance))
2010 &rest args)
2011 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2012 (call-next-method)))
2013
2014 (defmethod extra-keywords ((operator (eql 'make-condition))
2015 &rest args)
2016 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2017 (call-next-method)))
2018
2019 (defmethod extra-keywords ((operator (eql 'error))
2020 &rest args)
2021 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2022 (call-next-method)))
2023
2024 (defmethod extra-keywords ((operator (eql 'signal))
2025 &rest args)
2026 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2027 (call-next-method)))
2028
2029 (defmethod extra-keywords ((operator (eql 'warn))
2030 &rest args)
2031 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2032 (call-next-method)))
2033
2034 (defmethod extra-keywords ((operator (eql 'cerror))
2035 &rest args)
2036 (multiple-value-bind (keywords aok determiners)
2037 (apply #'extra-keywords/make-instance operator
2038 (cdr args))
2039 (if keywords
2040 (values keywords aok
2041 (cons (car args) determiners))
2042 (call-next-method))))
2043
2044 (defmethod extra-keywords ((operator (eql 'change-class))
2045 &rest args)
2046 (multiple-value-bind (keywords aok determiners)
2047 (apply #'extra-keywords/change-class operator (cdr args))
2048 (if keywords
2049 (values keywords aok
2050 (cons (car args) determiners))
2051 (call-next-method))))
2052
2053 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
2054 "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
2055 (when keywords
2056 (setf (arglist.key-p decoded-arglist) t)
2057 (setf (arglist.keyword-args decoded-arglist)
2058 (remove-duplicates
2059 (append (arglist.keyword-args decoded-arglist)
2060 keywords)
2061 :key #'keyword-arg.keyword)))
2062 (setf (arglist.allow-other-keys-p decoded-arglist)
2063 (or (arglist.allow-other-keys-p decoded-arglist)
2064 allow-other-keys-p)))
2065
2066 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
2067 "Determine extra keywords from the function call FORM, and modify
2068 DECODED-ARGLIST to include them. As a secondary return value, return
2069 the initial sublist of ARGS that was needed to determine the extra
2070 keywords. As a tertiary return value, return whether any enrichment
2071 was done."
2072 (multiple-value-bind (extra-keywords extra-aok determining-args)
2073 (apply #'extra-keywords form)
2074 ;; enrich the list of keywords with the extra keywords
2075 (enrich-decoded-arglist-with-keywords decoded-arglist
2076 extra-keywords extra-aok)
2077 (values decoded-arglist
2078 determining-args
2079 (or extra-keywords extra-aok))))
2080
2081 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
2082 (:documentation
2083 "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2084 ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2085 If the arglist is not available, return :NOT-AVAILABLE."))
2086
2087 (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2088 (let ((arglist (arglist operator-form)))
2089 (etypecase arglist
2090 ((member :not-available)
2091 :not-available)
2092 (list
2093 (let ((decoded-arglist (decode-arglist arglist)))
2094 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2095 (cons operator-form
2096 argument-forms)))))))
2097
2098 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2099 argument-forms)
2100 (declare (ignore argument-forms))
2101 (multiple-value-bind (decoded-arglist determining-args)
2102 (call-next-method)
2103 (let ((first-arg (first (arglist.required-args decoded-arglist)))
2104 (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2105 (when (and (arglist-p first-arg) (arglist-p open-arglist))
2106 (enrich-decoded-arglist-with-keywords
2107 first-arg
2108 (arglist.keyword-args open-arglist)
2109 nil)))
2110 (values decoded-arglist determining-args t)))
2111
2112 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
2113 argument-forms)
2114 (let ((function-name-form (car argument-forms)))
2115 (when (and (listp function-name-form)
2116 (= (length function-name-form) 2)
2117 (member (car function-name-form) '(quote function)))
2118 (let ((function-name (cadr function-name-form)))
2119 (when (valid-operator-symbol-p function-name)
2120 (let ((function-arglist
2121 (compute-enriched-decoded-arglist function-name
2122 (cdr argument-forms))))
2123 (return-from compute-enriched-decoded-arglist
2124 (values (make-arglist :required-args
2125 (list 'function)
2126 :optional-args
2127 (append
2128 (mapcar #'(lambda (arg)
2129 (make-optional-arg arg nil))
2130 (arglist.required-args function-arglist))
2131 (arglist.optional-args function-arglist))
2132 :key-p
2133 (arglist.key-p function-arglist)
2134 :keyword-args
2135 (arglist.keyword-args function-arglist)
2136 :rest
2137 'args
2138 :allow-other-keys-p
2139 (arglist.allow-other-keys-p function-arglist))
2140 (list function-name-form)
2141 t)))))))
2142 (call-next-method))
2143
2144 (defslimefun arglist-for-insertion (name)
2145 (with-buffer-syntax ()
2146 (let ((symbol (parse-symbol name)))
2147 (cond
2148 ((and symbol
2149 (valid-operator-name-p name))
2150 (let ((decoded-arglist
2151 (compute-enriched-decoded-arglist symbol nil)))
2152 (if (eql decoded-arglist :not-available)
2153 :not-available
2154 (decoded-arglist-to-template-string decoded-arglist
2155 *buffer-package*))))
2156 (t
2157 :not-available)))))
2158
2159 (defvar *remove-keywords-alist*
2160 '((:test :test-not)
2161 (:test-not :test)))
2162
2163 (defun remove-actual-args (decoded-arglist actual-arglist)
2164 "Remove from DECODED-ARGLIST the arguments that have already been
2165 provided in ACTUAL-ARGLIST."
2166 (loop while (and actual-arglist
2167 (arglist.required-args decoded-arglist))
2168 do (progn (pop actual-arglist)
2169 (pop (arglist.required-args decoded-arglist))))
2170 (loop while (and actual-arglist
2171 (arglist.optional-args decoded-arglist))
2172 do (progn (pop actual-arglist)
2173 (pop (arglist.optional-args decoded-arglist))))
2174 (loop for keyword in actual-arglist by #'cddr
2175 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
2176 do (setf (arglist.keyword-args decoded-arglist)
2177 (remove-if (lambda (kw)
2178 (or (eql kw keyword)
2179 (member kw keywords-to-remove)))
2180 (arglist.keyword-args decoded-arglist)
2181 :key #'keyword-arg.keyword))))
2182
2183 (defgeneric form-completion (operator-form argument-forms &key remove-args))
2184
2185 (defmethod form-completion (operator-form argument-forms &key (remove-args t))
2186 (when (and (symbolp operator-form)
2187 (valid-operator-symbol-p operator-form))
2188 (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2189 (compute-enriched-decoded-arglist operator-form argument-forms)
2190 (etypecase decoded-arglist
2191 ((member :not-available)
2192 :not-available)
2193 (arglist
2194 (cond
2195 (remove-args
2196 ;; get rid of formal args already provided
2197 (remove-actual-args decoded-arglist argument-forms))
2198 (t
2199 ;; replace some formal args by determining actual args
2200 (remove-actual-args decoded-arglist determining-args)
2201 (setf (arglist.provided-args decoded-arglist)
2202 determining-args)))
2203 (return-from form-completion
2204 (values decoded-arglist any-enrichment))))))
2205 :not-available)
2206
2207 (defmethod form-completion ((operator-form (eql 'defmethod))
2208 argument-forms &key (remove-args t))
2209 (when (and (listp argument-forms)
2210 (not (null argument-forms)) ;have generic function name
2211 (notany #'listp (rest argument-forms))) ;don't have arglist yet
2212 (let* ((gf-name (first argument-forms))
2213 (gf (and (or (symbolp gf-name)
2214 (and (listp gf-name)
2215 (eql (first gf-name) 'setf)))
2216 (fboundp gf-name)
2217 (fdefinition gf-name))))
2218 (when (typep gf 'generic-function)
2219 (let ((arglist (arglist gf)))
2220 (etypecase arglist
2221 ((member :not-available))
2222 (list
2223 (return-from form-completion
2224 (values (make-arglist :provided-args (if remove-args
2225 nil
2226 (list gf-name))
2227 :required-args (list arglist)
2228 :rest "body" :body-p t)
2229 t))))))))
2230 (call-next-method))
2231
2232 (defun read-incomplete-form-from-string (form-string)
2233 (with-buffer-syntax ()
2234 (handler-case
2235 (read-from-string form-string)
2236 (reader-error (c)
2237 (declare (ignore c))
2238 nil)
2239 (stream-error (c)
2240 (declare (ignore c))
2241 nil))))
2242
2243 (defslimefun complete-form (form-string)
2244 "Read FORM-STRING in the current buffer package, then complete it
2245 by adding a template for the missing arguments."
2246 (let ((form (read-incomplete-form-from-string form-string)))
2247 (when (consp form)
2248 (let ((operator-form (first form))
2249 (argument-forms (rest form)))
2250 (let ((form-completion
2251 (form-completion operator-form argument-forms)))
2252 (unless (eql form-completion :not-available)
2253 (return-from complete-form
2254 (decoded-arglist-to-template-string form-completion
2255 *buffer-package*
2256 :prefix ""))))))
2257 :not-available))
2258
2259 (defun format-arglist-for-echo-area (form operator-name
2260 &key print-right-margin print-lines
2261 highlight)
2262 "Return the arglist for FORM as a string."
2263 (when (consp form)
2264 (destructuring-bind (operator-form &rest argument-forms)
2265 form
2266 (let ((form-completion
2267 (form-completion operator-form argument-forms
2268 :remove-args nil)))
2269 (unless (eql form-completion :not-available)
2270 (return-from format-arglist-for-echo-area
2271 (decoded-arglist-to-string
2272 form-completion
2273 *package*
2274 :operator operator-name
2275 :print-right-margin print-right-margin
2276 :print-lines print-lines
2277 :highlight highlight))))))
2278 nil)
2279
2280 (defun keywords-of-operator (operator)
2281 "Return a list of KEYWORD-ARGs that OPERATOR accepts.
2282 This function is useful for writing EXTRA-KEYWORDS methods for
2283 user-defined functions which are declared &ALLOW-OTHER-KEYS and which
2284 forward keywords to OPERATOR."
2285 (let ((arglist (form-completion operator nil
2286 :remove-args nil)))
2287 (unless (eql arglist :not-available)
2288 (values
2289 (arglist.keyword-args arglist)
2290 (arglist.allow-other-keys-p arglist)))))
2291
2292 (defun arglist-ref (decoded-arglist operator &rest indices)
2293 (cond
2294 ((null indices) decoded-arglist)
2295 ((not (arglist-p decoded-arglist)) nil)
2296 (t
2297 (let ((index (first indices))
2298 (args (append (and operator
2299 (list operator))
2300 (arglist.required-args decoded-arglist)
2301 (arglist.optional-args decoded-arglist))))
2302 (when (< index (length args))
2303 (let ((arg (elt args index)))
2304 (apply #'arglist-ref arg nil (rest indices))))))))
2305
2306 (defslimefun completions-for-keyword (names keyword-string arg-indices)
2307 (with-buffer-syntax ()
2308 (multiple-value-bind (name index)
2309 (find-valid-operator-name names)
2310 (when name
2311 (let* ((form (operator-designator-to-form name))
2312 (operator-form (first form))
2313 (argument-forms (rest form))
2314 (arglist
2315 (form-completion operator-form argument-forms
2316 :remove-args nil)))
2317 (unless (eql arglist :not-available)
2318 (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2319 (arglist (apply #'arglist-ref arglist operator-form indices)))
2320 (when (and arglist (arglist-p arglist))
2321 ;; It would be possible to complete keywords only if we
2322 ;; are in a keyword position, but it is not clear if we
2323 ;; want that.
2324 (let* ((keywords
2325 (mapcar #'keyword-arg.keyword
2326 (arglist.keyword-args arglist)))
2327 (keyword-name
2328 (tokenize-symbol keyword-string))
2329 (matching-keywords
2330 (find-matching-symbols-in-list keyword-name keywords
2331 #'compound-prefix-match))
2332 (converter (completion-output-symbol-converter keyword-string))
2333 (strings
2334 (mapcar converter
2335 (mapcar #'symbol-name matching-keywords)))
2336 (completion-set
2337 (format-completion-set strings nil "")))
2338 (list completion-set
2339 (longest-completion completion-set)))))))))))
2340
2341
2342 (defun arglist-to-string (arglist package &key print-right-margin highlight)
2343 (decoded-arglist-to-string (decode-arglist arglist)
2344 package
2345 :print-right-margin print-right-margin
2346 :highlight highlight))
2347
2348 (defun test-print-arglist ()
2349 (flet ((test (list string)
2350 (let* ((p (find-package :swank))
2351 (actual (arglist-to-string list p)))
2352 (unless (string= actual string)
2353 (warn "Test failed: ~S => ~S~% Expected: ~S"
2354 list actual string)))))
2355 (test '(function cons) "(function cons)")
2356 (test '(quote cons) "(quote cons)")
2357 (test '(&key (function #'+)) "(&key (function #'+))")
2358 (test '(&whole x y z) "(y z)")
2359 (test '(x &aux y z) "(x)")
2360 (test '(x &environment env y) "(x y)")
2361 (test '(&key ((function f))) "(&key ((function f)))")))
2362
2363 (test-print-arglist)
2364
2365
2366 ;;;; Recording and accessing results of computations
2367
2368 (defvar *record-repl-results* t
2369 "Non-nil means that REPL results are saved for later lookup.")
2370
2371 (defvar *object-to-presentation-id*
2372 (make-weak-key-hash-table :test 'eq)
2373 "Store the mapping of objects to numeric identifiers")
2374
2375 (defvar *presentation-id-to-object*
2376 (make-weak-value-hash-table :test 'eql)
2377 "Store the mapping of numeric identifiers to objects")
2378
2379 (defun clear-presentation-tables ()
2380 (clrhash *object-to-presentation-id*)
2381 (clrhash *presentation-id-to-object*))
2382
2383 (defvar *presentation-counter* 0 "identifier counter")
2384
2385 (defvar *nil-surrogate* (make-symbol "nil-surrogate"))
2386
2387 ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
2388 ;; rest of slime isn't thread safe either), do we really care?
2389 (defun save-presented-object (object)
2390 "Save OBJECT and return the assigned id.
2391 If OBJECT was saved previously return the old id."
2392 (let ((object (if (null object) *nil-surrogate* object)))
2393 ;; We store *nil-surrogate* instead of nil, to distinguish it from
2394 ;; an object that was garbage collected.
2395 (or (gethash object *object-to-presentation-id*)
2396 (let ((id (incf *presentation-counter*)))
2397 (setf (gethash id *presentation-id-to-object*) object)
2398 (setf (gethash object *object-to-presentation-id*) id)
2399 id))))
2400
2401 (defun lookup-presented-object (id)
2402 "Retrieve the object corresponding to ID.
2403 The secondary value indicates the absence of an entry."
2404 (etypecase id
2405 (integer
2406 ;;
2407 (multiple-value-bind (object foundp)
2408 (gethash id *presentation-id-to-object*)
2409 (cond
2410 ((eql object *nil-surrogate*)
2411 ;; A stored nil object
2412 (values nil t))
2413 ((null object)
2414 ;; Object that was replaced by nil in the weak hash table
2415 ;; when the object was garbage collected.
2416 (values nil nil))
2417 (t
2418 (values object foundp)))))
2419 (cons
2420 (destructure-case id
2421 ((:frame-var frame index)
2422 (handler-case
2423 (frame-var-value frame index)
2424 (t (condition)
2425 (declare (ignore condition))
2426 (values nil nil))
2427 (:no-error (value)
2428 (values value t))))
2429 ((:inspected-part part-index)
2430 (declare (special *inspectee-parts*))
2431 (if (< part-index (length *inspectee-parts*))
2432 (values (inspector-nth-part part-index) t)
2433 (values nil nil)))))))
2434
2435 (defslimefun get-repl-result (id)
2436 "Get the result of the previous REPL evaluation with ID."
2437 (multiple-value-bind (object foundp) (lookup-presented-object id)
2438 (cond (foundp object)
2439 (t (abort-request "Attempt to access unrecorded object (id ~D)." id)))))
2440
2441 (defslimefun clear-repl-results ()
2442 "Forget the results of all previous REPL evaluations."
2443 (clear-presentation-tables)
2444 t)
2445
2446
2447 ;;;; Evaluation
2448
2449 (defvar *pending-continuations* '()
2450 "List of continuations for Emacs. (thread local)")
2451
2452 (defun guess-buffer-package (string)
2453 "Return a package for STRING.
2454 Fall back to the the current if no such package exists."
2455 (or (guess-package-from-string string nil)
2456 *package*))
2457
2458 (defun eval-for-emacs (form buffer-package id)
2459 "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
2460 Return the result to the continuation ID.
2461 Errors are trapped and invoke our debugger."
2462 (call-with-debugger-hook
2463 #'swank-debugger-hook
2464 (lambda ()
2465 (let (ok result reason)
2466 (unwind-protect
2467 (let ((*buffer-package* (guess-buffer-package buffer-package))
2468 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2469 (*pending-continuations* (cons id *pending-continuations*)))
2470 (check-type *buffer-package* package)
2471 (check-type *buffer-readtable* readtable)
2472 ;; APPLY would be cleaner than EVAL.
2473 ;;(setq result (apply (car form) (cdr form)))
2474 (handler-case
2475 (progn
2476 (setq result (eval form))
2477 (run-hook *pre-reply-hook*)
2478 (finish-output)
2479 (setq ok t))
2480 (request-abort (c)
2481 (setf ok nil
2482 reason (list (slot-value c 'swank-backend::reason))))))
2483 (force-user-output)
2484 (send-to-emacs `(:return ,(current-thread)
2485 ,(if ok
2486 `(:ok ,result)
2487 `(:abort ,@reason))
2488 ,id)))))))
2489
2490 (defvar *echo-area-prefix* "=> "
2491 "A prefix that `format-values-for-echo-area' should use.")
2492
2493 (defun format-values-for-echo-area (values)
2494 (with-buffer-syntax ()
2495 (let ((*print-readably* nil))
2496 (cond ((null values) "; No value")
2497 ((and (null (cdr values)) (integerp (car values)))
2498 (let ((i (car values)))
2499 (format nil "~A~D (#x~X, #o~O, #b~B)"
2500 *echo-area-prefix* i i i i)))
2501 (t (format nil "~A~{~S~^, ~}" *echo-area-prefix* values))))))
2502
2503 (defslimefun interactive-eval (string)
2504 (with-buffer-syntax ()
2505 (let ((values (multiple-value-list (eval (from-string string)))))
2506 (fresh-line)
2507 (finish-output)
2508 (format-values-for-echo-area values))))
2509
2510 (defslimefun eval-and-grab-output (string)
2511 (with-buffer-syntax ()
2512 (let* ((s (make-string-output-stream))
2513 (*standard-output* s)
2514 (values (multiple-value-list (eval (from-string string)))))
2515 (list (get-output-stream-string s)
2516 (format nil "~{~S~^~%~}" values)))))
2517
2518 ;;; XXX do we need this stuff? What is it good for?
2519 (defvar *slime-repl-advance-history* nil
2520 "In the dynamic scope of a single form typed at the repl, is set to nil to
2521 prevent the repl from advancing the history - * ** *** etc.")
2522
2523 (defvar *slime-repl-suppress-output* nil
2524 "In the dynamic scope of a single form typed at the repl, is set to nil to
2525 prevent the repl from printing the result of the evalation.")
2526
2527 (defvar *slime-repl-eval-hook-pass* (gensym "PASS")
2528 "Token to indicate that a repl hook declines to evaluate the form")
2529
2530 (defvar *slime-repl-eval-hooks* nil
2531 "A list of functions. When the repl is about to eval a form, first try running each of
2532 these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
2533 is considered a replacement for calling eval. If there are no hooks, or all
2534 pass, then eval is used.")
2535
2536 (defslimefun repl-eval-hook-pass ()
2537 "call when repl hook declines to evaluate the form"
2538 (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
2539
2540 (defslimefun repl-suppress-output ()
2541 "In the dynamic scope of a single form typed at the repl, call to
2542 prevent the repl from printing the result of the evalation."
2543 (setq *slime-repl-suppress-output* t))
2544
2545 (defslimefun repl-suppress-advance-history ()
2546 "In the dynamic scope of a single form typed at the repl, call to
2547 prevent the repl from advancing the history - * ** *** etc."
2548 (setq *slime-repl-advance-history* nil))
2549
2550 (defun eval-region (string &optional package-update-p)
2551 "Evaluate STRING and return the result.
2552 If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
2553 change, then send Emacs an update."
2554 (unwind-protect
2555 (with-input-from-string (stream string)
2556 (let (- values)
2557 (loop
2558 (let ((form (read stream nil stream)))
2559 (when (eq form stream)
2560 (fresh-line)
2561 (finish-output)
2562 (return (values values -)))
2563 (setq - form)
2564 (if *slime-repl-eval-hooks*
2565 (setq values (run-repl-eval-hooks form))
2566 (setq values (multiple-value-list (eval form))))
2567 (finish-output)))))
2568 (when (and package-update-p (not (eq *package* *buffer-package*)))
2569 (send-to-emacs
2570 (list :new-package (package-name *package*)
2571 (package-string-for-prompt *package*))))))
2572
2573 (defun run-repl-eval-hooks (form)
2574 (loop for hook in *slime-repl-eval-hooks*
2575 for res = (catch *slime-repl-eval-hook-pass*
2576 (multiple-value-list (funcall hook form)))
2577 until (not (eq res *slime-repl-eval-hook-pass*))
2578 finally (return
2579 (if (eq res *slime-repl-eval-hook-pass*)
2580 (multiple-value-list (eval form))
2581 res))))
2582
2583 (defun package-string-for-prompt (package)
2584 "Return the shortest nickname (or canonical name) of PACKAGE."
2585 (princ-to-string
2586 (make-symbol
2587 (or (canonical-package-nickname package)
2588 (auto-abbreviated-package-name package)
2589 (shortest-package-nickname package)))))
2590
2591 (defun canonical-package-nickname (package)
2592 "Return the canonical package nickname, if any, of PACKAGE."
2593 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2594 :test #'string=))))
2595 (and name (string name))))
2596
2597 (defun auto-abbreviated-package-name (package)
2598 "Return an abbreviated 'name' for PACKAGE.
2599
2600 N.B. this is not an actual package name or nickname."
2601 (when *auto-abbreviate-dotted-packages*
2602 (let ((last-dot (position #\. (package-name package) :from-end t)))
2603 (when last-dot (subseq (package-name package) (1+ last-dot))))))
2604
2605 (defun shortest-package-nickname (package)
2606 "Return the shortest nickname (or canonical name) of PACKAGE."
2607 (loop for name in (cons (package-name package) (package-nicknames package))
2608 for shortest = name then (if (< (length name) (length shortest))
2609 name
2610 shortest)
2611 finally (return shortest)))
2612
2613 (defslimefun interactive-eval-region (string)
2614 (with-buffer-syntax ()
2615 (format-values-for-echo-area (eval-region string))))
2616
2617 (defslimefun re-evaluate-defvar (form)
2618 (with-buffer-syntax ()
2619 (let ((form (read-from-string form)))
2620 (destructuring-bind (dv name &optional value doc) form
2621 (declare (ignore value doc))
2622 (assert (eq dv 'defvar))
2623 (makunbound name)
2624 (prin1-to-string (eval form))))))
2625
2626 (defvar *swank-pprint-bindings*
2627 `((*print-pretty* . t)
2628 (*print-level* . nil)
2629 (*print-length* . nil)
2630 (*print-circle* . t)
2631 (*print-gensym* . t)
2632 (*print-readably* . nil))
2633 "A list of variables bindings during pretty printing.
2634 Used by pprint-eval.")
2635
2636 (defun swank-pprint (list)
2637 "Bind some printer variables and pretty print each object in LIST."
2638 (with-buffer-syntax ()
2639 (with-bindings *swank-pprint-bindings*
2640 (cond ((null list) "; No value")
2641 (t (with-output-to-string (*standard-output*)
2642 (dolist (o list)
2643 (pprint o)
2644 (terpri))))))))
2645
2646 (defslimefun pprint-eval (string)
2647 (with-buffer-syntax ()
2648 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
2649
2650 (defslimefun set-package (package)
2651 "Set *package* to PACKAGE.
2652 Return its name and the string to use in the prompt."
2653 (let ((p (setq *package* (guess-package-from-string package))))
2654 (list (package-name p) (package-string-for-prompt p))))
2655
2656 (defun send-repl-results-to-emacs (values)
2657 (flet ((send (value)
2658 (let ((id (and *record-repl-results*
2659 (save-presented-object value))))
2660 (send-to-emacs `(:write-string ,(prin1-to-string value)
2661 ,id :repl-result))
2662 (send-to-emacs `(:write-string ,(string #\Newline)
2663 nil :repl-result)))))
2664 (if (null values)
2665 (send-to-emacs `(:write-string "; No value" nil :repl-result))
2666 (mapc #'send values))))
2667
2668 (defslimefun listener-eval (string)
2669 (clear-user-input)
2670 (with-buffer-syntax ()
2671 (let ((*slime-repl-suppress-output* :unset)
2672 (*slime-repl-advance-history* :unset))
2673 (multiple-value-bind (values last-form) (eval-region string t)
2674 (unless (or (and (eq values nil) (eq last-form nil))
2675 (eq *slime-repl-advance-history* nil))
2676 (setq *** ** ** * * (car values)
2677 /// // // / / values))
2678 (setq +++ ++ ++ + + last-form)
2679 (unless (eq *slime-repl-suppress-output* t)
2680 (send-repl-results-to-emacs values)))))
2681 nil)
2682
2683 (defslimefun ed-in-emacs (&optional what)
2684 "Edit WHAT in Emacs.
2685
2686 WHAT can be:
2687 A pathname or a string,
2688 A list (PATHNAME-OR-STRING LINE [COLUMN]),
2689 A function name (symbol or cons),
2690 NIL.
2691
2692 Returns true if it actually called emacs, or NIL if not."
2693 (flet ((pathname-or-string-p (thing)
2694 (or (pathnamep thing) (typep thing 'string))))
2695 (let ((target
2696 (cond ((and (listp what) (pathname-or-string-p (first what)))
2697 (cons (canonicalize-filename (car what)) (cdr what)))
2698 ((pathname-or-string-p what)
2699 (canonicalize-filename what))
2700 ((symbolp what) what)
2701 ((consp what) what)
2702 (t (return-from ed-in-emacs nil)))))
2703 (cond
2704 (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2705 ((default-connection)
2706 (with-connection ((default-connection))
2707 (send-oob-to-emacs `(:ed ,target))))
2708 (t nil)))))
2709
2710 (defslimefun inspect-in-emacs (what)
2711 "Inspect WHAT in Emacs."
2712 (flet ((send-it ()
2713 (with-buffer-syntax ()
2714 (reset-inspector)
2715 (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
2716 (cond
2717 (*emacs-connection*
2718 (send-it))
2719 ((default-connection)
2720 (with-connection ((default-connection))
2721 (send-it))))
2722 what))
2723
2724 (defslimefun value-for-editing (form)
2725 "Return a readable value of FORM for editing in Emacs.
2726 FORM is expected, but not required, to be SETF'able."
2727 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2728 (with-buffer-syntax ()
2729 (prin1-to-string (eval (read-from-string form)))))
2730
2731 (defslimefun commit-edited-value (form value)
2732 "Set the value of a setf'able FORM to VALUE.
2733 FORM and VALUE are both strings from Emacs."
2734 (with-buffer-syntax ()
2735 (eval `(setf ,(read-from-string form)
2736 ,(read-from-string (concatenate 'string "`" value))))
2737 t))
2738
2739 (defun background-message (format-string &rest args)
2740 "Display a message in Emacs' echo area.
2741
2742 Use this function for informative messages only. The message may even
2743 be dropped, if we are too busy with other things."
2744 (when *emacs-connection*
2745 (send-to-emacs `(:background-message
2746 ,(apply #'format nil format-string args)))))
2747
2748
2749 ;;;; Debugger
2750
2751 (defun swank-debugger-hook (condition hook)
2752 "Debugger function for binding *DEBUGGER-HOOK*.
2753 Sends a message to Emacs declaring that the debugger has been entered,
2754 then waits to handle further requests from Emacs. Eventually returns
2755 after Emacs causes a restart to be invoked."
2756 (declare (ignore hook))
2757 (cond (*emacs-connection*
2758 (debug-in-emacs condition))
2759 ((default-connection)
2760 (with-connection ((default-connection))
2761 (debug-in-emacs condition)))))
2762
2763 (defvar *global-debugger* t
2764 "Non-nil means the Swank debugger hook will be installed globally.")
2765
2766 (add-hook *new-connection-hook* 'install-debugger)
2767 (defun install-debugger (connection)
2768 (declare (ignore connection))
2769 (when *global-debugger*
2770 (install-debugger-globally #'swank-debugger-hook)))
2771
2772 ;;;;; Debugger loop
2773 ;;;
2774 ;;; These variables are dynamically bound during debugging.
2775 ;;;
2776 (defvar *swank-debugger-condition* nil
2777 "The condition being debugged.")
2778
2779 (defvar *sldb-level* 0
2780 "The current level of recursive debugging.")
2781
2782 (defvar *sldb-initial-frames* 20
2783 "The initial number of backtrace frames to send to Emacs.")
2784
2785 (defvar *sldb-restarts* nil
2786 "The list of currenlty active restarts.")
2787
2788 (defvar *sldb-stepping-p* nil
2789 "True during execution of a step command.")
2790
2791 (defvar *sldb-quit-restart* 'abort-request
2792 "What restart should swank attempt to invoke when the user sldb-quits.")
2793
2794 (defun debug-in-emacs (condition)
2795 (let ((*swank-debugger-condition* condition)
2796 (*sldb-restarts* (compute-restarts condition))
2797 (*package* (or (and (boundp '*buffer-package*)
2798 (symbol-value '*buffer-package*))
2799 *package*))
2800 (*sldb-level* (1+ *sldb-level*))
2801 (*sldb-stepping-p* nil)
2802 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2803 (force-user-output)
2804 (call-with-debugging-environment
2805 (lambda () (sldb-loop *sldb-level*)))))
2806
2807 (defun sldb-loop (level)
2808 (unwind-protect
2809 (catch 'sldb-enter-default-debugger
2810 (send-to-emacs
2811 (list* :debug (current-thread) level
2812 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2813 (loop (catch 'sldb-loop-catcher
2814 (with-simple-restart (abort "Return to sldb level ~D." level)
2815 (send-to-emacs (list :debug-activate (current-thread)
2816 level))
2817 (handler-bind ((sldb-condition #'handle-sldb-condition))
2818 (read-from-emacs))))))
2819 (send-to-emacs `(:debug-return
2820 ,(current-thread) ,level ,*sldb-stepping-p*))))
2821
2822 (defun handle-sldb-condition (condition)
2823 "Handle an internal debugger condition.
2824 Rather than recursively debug the debugger (a dangerous idea!), these
2825 conditions are simply reported."
2826 (let ((real-condition (original-condition condition)))
2827 (send-to-emacs `(:debug-condition ,(current-thread)
2828 ,(princ-to-string real-condition))))
2829 (throw 'sldb-loop-catcher nil))
2830
2831 (defun safe-condition-message (condition)
2832 "Safely print condition to a string, handling any errors during
2833 printing."
2834 (let ((*print-pretty* t))
2835 (handler-case
2836 (format-sldb-condition condition)
2837 (error (cond)
2838 ;; Beware of recursive errors in printing, so only use the condition
2839 ;; if it is printable itself:
2840 (format nil "Unable to display error condition~@[: ~A~]"
2841 (ignore-errors (princ-to-string cond)))))))
2842
2843 (defun debugger-condition-for-emacs ()
2844 (list (safe-condition-message *swank-debugger-condition*)
2845 (format nil " [Condition of type ~S]"
2846 (type-of *swank-debugger-condition*))
2847 (condition-references *swank-debugger-condition*)
2848 (condition-extras *swank-debugger-condition*)))
2849
2850 (defun format-restarts-for-emacs ()
2851 "Return a list of restarts for *swank-debugger-condition* in a
2852 format suitable for Emacs."
2853 (let ((*print-right-margin* most-positive-fixnum))
2854 (loop for restart in *sldb-restarts*
2855 collect (list (princ-to-string (restart-name restart))
2856 (princ-to-string restart)))))
2857
2858
2859 ;;;;; SLDB entry points
2860
2861 (defslimefun sldb-break-with-default-debugger ()
2862 "Invoke the default debugger by returning from our debugger-loop."
2863 (throw 'sldb-enter-default-debugger nil))
2864
2865 (defslimefun backtrace (start end)
2866 "Return a list ((I FRAME) ...) of frames from START to END.
2867 I is an integer describing and FRAME a string."
2868 (with-bindings *sldb-printer-bindings*
2869 ;; we don't want newlines in the backtrace, that makes it unreadable
2870 (let ((*print-right-margin* most-positive-fixnum))
2871 (loop for frame in (compute-backtrace start end)
2872 for i from start
2873 collect (list i (with-output-to-string (stream)
2874 (print-frame frame stream)))))))
2875
2876 (defslimefun debugger-info-for-emacs (start end)
2877 "Return debugger state, with stack frames from START to END.
2878 The result is a list:
2879 (condition ({restart}*) ({stack-frame}*) (cont*))
2880 where
2881 condition ::= (description type [extra])
2882 restart ::= (name description)
2883 stack-frame ::= (number description)
2884 extra ::= (:references and other random things)
2885 cont ::= continutation
2886 condition---a pair of strings: message, and type. If show-source is
2887 not nil it is a frame number for which the source should be displayed.
2888
2889 restart---a pair of strings: restart name, and description.
2890
2891 stack-frame---a number from zero (the top), and a printed
2892 representation of the frame's call.
2893
2894 continutation---the id of a pending Emacs continuation.
2895
2896 Below is an example return value. In this case the condition was a
2897 division by zero (multi-line description), and only one frame is being
2898 fetched (start=0, end=1).
2899
2900 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2901 Operation was KERNEL::DIVISION, operands (1 0).\"
2902 \"[Condition of type DIVISION-BY-ZERO]\")
2903 ((\"ABORT\" \"Return to Slime toplevel.\")
2904 (\"ABORT\" \"Return to Top-Level.\"))
2905 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2906 (4))"
2907 (with-bindings *sldb-printer-bindings*
2908 (list (debugger-condition-for-emacs)
2909 (format-restarts-for-emacs)
2910 (backtrace start end)
2911 *pending-continuations*)))
2912
2913 (defun nth-restart (index)
2914 (nth index *sldb-restarts*))
2915
2916 (defslimefun invoke-nth-restart (index)
2917 (invoke-restart-interactively (nth-restart index)))
2918
2919 (defslimefun sldb-abort ()
2920 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2921
2922 (defslimefun sldb-continue ()
2923 (continue))
2924
2925 (defslimefun throw-to-toplevel ()
2926 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2927 If we are not evaluating an RPC then ABORT instead."
2928 (let ((restart (find-restart *sldb-quit-restart*)))
2929 (cond (restart (invoke-restart restart))
2930 (t (format nil
2931 "Restart not found: ~a"
2932 *sldb-quit-restart*)))))
2933
2934 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2935 "Invoke the Nth available restart.
2936 SLDB-LEVEL is the debug level when the request was made. If this
2937 has changed, ignore the request."
2938 (when (= sldb-level *sldb-level*)
2939 (invoke-nth-restart n)))
2940
2941 (defun wrap-sldb-vars (form)
2942 `(let ((*sldb-level* ,*sldb-level*))
2943 ,form))
2944
2945 (defslimefun eval-string-in-frame (string index)
2946 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
2947 index)))
2948
2949 (defslimefun pprint-eval-string-in-frame (string index)
2950 (swank-pprint
2951 (multiple-value-list
2952 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
2953
2954 (defslimefun frame-locals-for-emacs (index)
2955 "Return a property list ((&key NAME ID VALUE) ...) describing
2956 the local variables in the frame INDEX."
2957 (mapcar (lambda (frame-locals)
2958 (destructuring-bind (&key name id value) frame-locals
2959 (list :name (prin1-to-string name) :id id
2960 :value (to-string value))))
2961 (frame-locals index)))
2962
2963 (defslimefun frame-catch-tags-for-emacs (frame-index)
2964 (mapcar #'to-string (frame-catch-tags frame-index)))
2965
2966 (defslimefun sldb-disassemble (index)
2967 (with-output-to-string (*standard-output*)
2968 (disassemble-frame index)))
2969
2970 (defslimefun sldb-return-from-frame (index string)
2971 (let ((form (from-string string)))
2972 (to-string (multiple-value-list (return-from-frame index form)))))
2973
2974 (defslimefun sldb-break (name)
2975 (with-buffer-syntax ()
2976 (sldb-break-at-start (read-from-string name))))
2977
2978 (defmacro define-stepper-function (name backend-function-name)
2979 `(defslimefun ,name (frame)
2980 (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
2981 (setq *sldb-stepping-p* t)
2982 (,backend-function-name))
2983 ((find-restart 'continue)
2984 (activate-stepping frame)
2985 (setq *sldb-stepping-p* t)
2986 (continue))
2987 (t
2988 (error "Not currently single-stepping, and no continue restart available.")))))
2989
2990 (define-stepper-function sldb-step sldb-step-into)
2991 (define-stepper-function sldb-next sldb-step-next)
2992 (define-stepper-function sldb-out sldb-step-out)
2993
2994
2995 ;;;; Compilation Commands.
2996
2997 (defvar *compiler-notes* '()
2998 "List of compiler notes for the last compilation unit.")
2999
3000 (defun clear-compiler-notes ()
3001 (setf *compiler-notes* '()))
3002
3003 (defun canonicalize-filename (filename)
3004 (namestring (truename filename)))
3005
3006 (defslimefun compiler-notes-for-emacs ()
3007 "Return the list of compiler notes for the last compilation unit."
3008 (reverse *compiler-notes*))
3009
3010 (defun measure-time-interval (fn)
3011 "Call FN and return the first return value and the elapsed time.
3012 The time is measured in microseconds."
3013 (declare (type function fn))
3014 (let ((before (get-internal-real-time)))
3015 (values
3016 (funcall fn)
3017 (* (- (get-internal-real-time) before)
3018 (/ 1000000 internal-time-units-per-second)))))
3019
3020 (defun record-note-for-condition (condition)
3021 "Record a note for a compiler-condition."
3022 (push (make-compiler-note condition) *compiler-notes*))
3023
3024 (defun make-compiler-note (condition)
3025 "Make a compiler note data structure from a compiler-condition."
3026 (declare (type compiler-condition condition))
3027 (list* :message (message condition)
3028 :severity (severity condition)
3029 :location (location condition)
3030 :references (references condition)
3031 (let ((s (short-message condition)))
3032 (if s (list :short-message s)))))
3033
3034 (defun swank-compiler (function)
3035 (clear-compiler-notes)
3036 (with-simple-restart (abort "Abort SLIME compilation.")
3037 (multiple-value-bind (result usecs)
3038 (handler-bind ((compiler-condition #'record-note-for-condition))
3039 (measure-time-interval function))
3040 (list (to-string result)
3041 (format nil "~,2F" (/ usecs 1000000.0))))))
3042
3043 (defslimefun compile-file-for-emacs (filename load-p)
3044 "Compile FILENAME and, when LOAD-P, load the result.
3045 Record compiler notes signalled as `compiler-condition's."
3046 (with-buffer-syntax ()
3047 (let ((*compile-print* nil))
3048 (swank-compiler
3049 (lambda ()
3050 (swank-compile-file filename load-p
3051 (or (guess-external-format filename)
3052 :default)))))))
3053
3054 (defslimefun compile-string-for-emacs (string buffer position directory)
3055 "Compile STRING (exerpted from BUFFER at POSITION).
3056 Record compiler notes signalled as `compiler-condition's."
3057 (with-buffer-syntax ()
3058 (swank-compiler
3059 (lambda ()
3060 (let ((*compile-print* nil) (*compile-verbose* t))
3061 (swank-compile-string string :buffer buffer :position position
3062 :directory directory))))))
3063
3064 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
3065 "Compile and load SYSTEM using ASDF.
3066 Record compiler notes signalled as `compiler-condition's."
3067 (swank-compiler
3068 (lambda ()
3069 (apply #'operate-on-system system-name operation keywords))))
3070
3071 (defun asdf-central-registry ()
3072 (when (find-package :asdf)
3073 (symbol-value (find-symbol (string :*central-registry*) :asdf))))
3074
3075 (defslimefun list-all-systems-in-central-registry ()
3076 "Returns a list of all systems in ASDF's central registry."
3077 (delete-duplicates
3078 (loop for dir in (asdf-central-registry)
3079 for defaults = (eval dir)
3080 when defaults
3081 nconc (mapcar #'file-namestring
3082 (directory
3083 (make-pathname :defaults defaults
3084 :version :newest
3085 :type "asd"
3086 :name :wild
3087 :case :local))))
3088 :test #'string=))
3089
3090 (defun file-newer-p (new-file old-file)
3091 "Returns true if NEW-FILE is newer than OLD-FILE."
3092 (> (file-write-date new-file) (file-write-date old-file)))
3093
3094 (defun requires-compile-p (source-file)
3095 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
3096 (or (not fasl-file)
3097 (file-newer-p source-file fasl-file))))
3098
3099 (defslimefun compile-file-if-needed (filename loadp)
3100 (cond ((requires-compile-p filename)
3101 (compile-file-for-emacs filename loadp))
3102 (loadp
3103 (load (compile-file-pathname filename))
3104 nil)))
3105
3106
3107 ;;;; Loading
3108
3109 (defslimefun load-file (filename)
3110 (to-string (load filename)))
3111
3112 (defslimefun load-file-set-package (filename &optional package)
3113 (load-file filename)
3114 (if package
3115 (set-package package)))
3116
3117
3118 ;;;; Macroexpansion
3119
3120 (defvar *macroexpand-printer-bindings*
3121 '((*print-circle* . nil)
3122 (*print-pretty* . t)
3123 (*print-escape* . t)
3124 (*print-level* . nil)
3125 (*print-length* . nil)))
3126
3127 (defun apply-macro-expander (expander string)
3128 (with-buffer-syntax ()
3129 (with-bindings *macroexpand-printer-bindings*
3130 (prin1-to-string (funcall expander (from-string string))))))
3131
3132 (defslimefun swank-macroexpand-1 (string)
3133 (apply-macro-expander #'macroexpand-1 string))
3134
3135 (defslimefun swank-macroexpand (string)
3136 (apply-macro-expander #'macroexpand string))
3137
3138 (defslimefun swank-macroexpand-all (string)
3139 (apply-macro-expander #'macroexpand-all string))
3140
3141 (defslimefun swank-compiler-macroexpand-1 (string)
3142 (apply-macro-expander #'compiler-macroexpand-1 string))
3143
3144 (defslimefun swank-compiler-macroexpand (string)
3145 (apply-macro-expander #'compiler-macroexpand string))
3146
3147 (defslimefun disassemble-symbol (name)
3148 (with-buffer-syntax ()
3149 (with-output-to-string (*standard-output*)
3150 (let ((*print-readably* nil))
3151 (disassemble (fdefinition (from-string name)))))))
3152
3153
3154 ;;;; Basic completion
3155
3156 (defslimefun completions (string default-package-name)
3157 "Return a list of completions for a symbol designator STRING.
3158
3159 The result is the list (COMPLETION-SET
3160 COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
3161 completions, and COMPLETED-PREFIX is the best (partial)
3162 completion of the input string.
3163
3164 If STRING is package qualified the result list will also be
3165 qualified. If string is non-qualified the result strings are
3166 also not qualified and are considered relative to
3167 DEFAULT-PACKAGE-NAME.
3168
3169 The way symbols are matched depends on the symbol designator's
3170 format. The cases are as follows:
3171 FOO - Symbols with matching prefix and accessible in the buffer package.
3172 PKG:FOO - Symbols with matching prefix and external in package PKG.
3173 PKG::FOO - Symbols with matching prefix and accessible in package PKG."
3174 (let ((completion-set (completion-set string default-package-name
3175 #'compound-prefix-match)))
3176 (list completion-set (longest-completion completion-set))))
3177
3178 (defslimefun simple-completions (string default-package-name)
3179 "Return a list of completions for a symbol designator STRING."
3180 (let ((completion-set (completion-set string default-package-name
3181 #'prefix-match-p)))
3182 (list completion-set (longest-common-prefix completion-set))))
3183
3184 ;;;;; Find completion set
3185
3186 (defun completion-set (string default-package-name matchp)
3187 "Return the set of completion-candidates as strings."
3188 (multiple-value-bind (name package-name package internal-p)
3189 (parse-completion-arguments string default-package-name)
3190 (let* ((symbols (mapcar (completion-output-symbol-converter name)
3191 (and package
3192 (mapcar #'symbol-name
3193 (find-matching-symbols name
3194 package
3195 (and (not internal-p)
3196 package-name)
3197 matchp)))))
3198 (packs (mapcar (completion-output-package-converter name)
3199 (and (not package-name)
3200 (find-matching-packages name matchp)))))
3201 (format-completion-set (nconc symbols packs) internal-p package-name))))
3202
3203 (defun find-matching-symbols (string package external test)
3204 "Return a list of symbols in PACKAGE matching STRING.
3205 TEST is called with two strings. If EXTERNAL is true, only external
3206 symbols are returned."
3207 (let ((completions '())
3208 (converter (completion-output-symbol-converter string)))
3209 (flet ((symbol-matches-p (symbol)
3210 (and (or (not external)
3211 (symbol-external-p symbol package))
3212 (funcall test string
3213 (funcall converter (symbol-name symbol))))))
3214 (do-symbols* (symbol package)
3215 (when (symbol-matches-p symbol)
3216 (push symbol completions))))
3217 completions))
3218
3219 (defun find-matching-symbols-in-list (string list test)
3220 "Return a list of symbols in LIST matching STRING.
3221 TEST is called with two strings."
3222 (let ((completions '())
3223 (converter (completion-output-symbol-converter string)))
3224 (flet ((symbol-matches-p (symbol)
3225 (funcall test string
3226 (funcall converter (symbol-name symbol)))))
3227 (dolist (symbol list)
3228 (when (symbol-matches-p symbol)
3229 (push symbol completions))))
3230 (remove-duplicates completions)))
3231
3232 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
3233 "True if SYMBOL is external in PACKAGE.
3234 If PACKAGE is not specified, the home package of SYMBOL is used."
3235 (and package
3236 (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
3237 :external)))
3238
3239 (defun find-matching-packages (name matcher)
3240 "Return a list of package names matching NAME with MATCHER.
3241 MATCHER is a two-argument predicate."
3242 (let ((to-match (string-upcase name)))
3243 (remove-if-not (lambda (x) (funcall matcher to-match x))
3244 (mapcar (lambda (pkgname)
3245 (concatenate 'string pkgname ":"))
3246 (loop for package in (list-all-packages)
3247 collect (package-name package)
3248 append (package-nicknames package))))))
3249
3250 (defun parse-completion-arguments (string default-package-name)
3251 "Parse STRING as a symbol designator.
3252 Return these values:
3253 SYMBOL-NAME
3254 PACKAGE-NAME, or nil if the designator does not include an explicit package.
3255 PACKAGE, the package to complete in
3256 INTERNAL-P, if the symbol is qualified with `::'."
3257 (multiple-value-bind (name package-name internal-p)
3258 (tokenize-symbol string)
3259 (let ((package (carefully-find-package package-name default-package-name)))
3260 (values name package-name package internal-p))))
3261
3262 (defun carefully-find-package (name default-package-name)
3263 "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
3264 *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
3265 (let ((string (cond ((equal name "") "KEYWORD")
3266 (t (or name default-package-name)))))
3267 (if string
3268 (guess-package-from-string string nil)
3269 *buffer-package*)))
3270
3271 ;;;;; Format completion results
3272 ;;;
3273 ;;; We try to format results in the case as inputs. If you complete
3274 ;;; `FOO' then your result should include `FOOBAR' rather than
3275 ;;; `foobar'.
3276
3277 (defun format-completion-set (strings internal-p package-name)
3278 "Format a set of completion strings.
3279 Returns a list of completions with package qualifiers if needed."
3280 (mapcar (lambda (string)
3281 (format-completion-result string internal-p package-name))
3282 (sort strings #'string<)))
3283
3284 (defun format-completion-result (string internal-p package-name)
3285 (let ((prefix (cond (internal-p (format nil "~A::" package-name))
3286 (package-name (format nil "~A:" package-name))
3287 (t ""))))
3288 (values (concatenate 'string prefix string)
3289 (length prefix))))
3290
3291 (defun completion-output-case-converter (input &optional with-escaping-p)
3292 "Return a function to convert strings for the completion output.
3293 INPUT is used to guess the preferred case."
3294 (ecase (readtable-case *readtable*)
3295 (:upcase (cond ((or with-escaping-p
3296 (not (some #'lower-case-p input)))
3297 #'identity)
3298 (t #'string-downcase)))
3299 (:invert (lambda (output)
3300 (multiple-value-bind (lower upper) (determine-case output)
3301 (cond ((and lower upper) output)
3302 (lower (string-upcase output))
3303 (upper (string-downcase output))
3304 (t output)))))
3305 (:downcase (cond ((or with-escaping-p
3306 (not (some #'upper-case-p input)))
3307 #'identity)
3308 (t #'string-upcase)))
3309 (:preserve #'identity)))
3310
3311 (defun completion-output-package-converter (input)
3312 "Return a function to convert strings for the completion output.
3313 INPUT is used to guess the preferred case."
3314 (completion-output-case-converter input))
3315
3316 (defun completion-output-symbol-converter (input)
3317 "Return a function to convert strings for the completion output.
3318 INPUT is used to guess the preferred case. Escape symbols when needed."
3319 (let ((case-converter (completion-output-case-converter input))
3320 (case-converter-with-escaping (completion-output-case-converter input t)))
3321 (lambda (str)
3322 (if (some (lambda (el)
3323 (member el '(#\: #\, #\ #\Newline #\Tab)))
3324 str)
3325 (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
3326 (funcall case-converter str)))))
3327
3328
3329 (defun determine-case (string)
3330 "Return two booleans LOWER and UPPER indicating whether STRING
3331 contains lower or upper case characters."
3332 (values (some #'lower-case-p string)
3333 (some #'upper-case-p string)))
3334
3335
3336 ;;;;; Compound-prefix matching
3337
3338 (defun compound-prefix-match (prefix target)
3339 "Return true if PREFIX is a compound-prefix of TARGET.
3340 Viewing each of PREFIX and TARGET as a series of substrings delimited
3341 by hyphens, if each substring of PREFIX is a prefix of the
3342 corresponding substring in TARGET then we call PREFIX a
3343 compound-prefix of TARGET.
3344
3345 Examples:
3346 \(compound-prefix-match \"foo\" \"foobar\") => t
3347 \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
3348 \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
3349 (declare (type simple-string prefix target))
3350 (loop for ch across prefix
3351 with tpos = 0
3352 always (and (< tpos (length target))
3353 (if (char= ch #\-)
3354 (setf tpos (position #\- target :start tpos))
3355 (char= ch (aref target tpos))))
3356 do (incf tpos)))
3357
3358 (defun prefix-match-p (prefix string)
3359 "Return true if PREFIX is a prefix of STRING."
3360 (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
3361
3362
3363 ;;;;; Extending the input string by completion
3364
3365 (defun longest-completion (completions)
3366 "Return the longest prefix for all COMPLETIONS.
3367 COMPLETIONS is a list of strings."
3368 (untokenize-completion
3369 (mapcar #'longest-common-prefix
3370 (transpose-lists (mapcar #'tokenize-completion completions)))))
3371
3372 (defun tokenize-completion (string)
3373 "Return all substrings of STRING delimited by #\-."
3374 (loop with end
3375 for start = 0 then (1+ end)
3376 until (> start (length string))
3377 do (setq end (or (position #\- string :start start) (length string)))
3378 collect (subseq string start end)))
3379
3380 (defun untokenize-completion (tokens)
3381 (format nil "~{~A~^-~}" tokens))
3382
3383 (defun longest-common-prefix (strings)
3384 "Return the longest string that is a common prefix of STRINGS."
3385 (if (null strings)
3386 ""
3387 (flet ((common-prefix (s1 s2)
3388 (let ((diff-pos (mismatch s1 s2)))
3389 (if diff-pos (subseq s1 0 diff-pos) s1))))
3390 (reduce #'common-prefix strings))))
3391
3392 (defun transpose-lists (lists)
3393 "Turn a list-of-lists on its side.
3394 If the rows are of unequal length, truncate uniformly to the shortest.
3395
3396 For example:
3397 \(transpose-lists '((ONE TWO THREE) (1 2)))
3398 => ((ONE 1) (TWO 2))"
3399 (cond ((null lists) '())
3400 ((some #'null lists) '())
3401 (t (cons (mapcar #'car lists)
3402 (transpose-lists (mapcar #'cdr lists))))))
3403
3404
3405 ;;;;; Completion Tests
3406
3407 (defpackage :swank-completion-test
3408 (:use))
3409
3410 (let ((*readtable* (copy-readtable *readtable*))
3411 (p (find-package :swank-completion-test)))
3412 (intern "foo" p)
3413 (intern "Foo" p)
3414 (intern "FOO" p)
3415 (setf (readtable-case *readtable*) :invert)
3416 (flet ((names (prefix)
3417 (sort (mapcar #'symbol-name
3418 (find-matching-symbols prefix p nil #'prefix-match-p))
3419 #'string<)))
3420 (assert (equal '("FOO") (names "f")))
3421 (assert (equal '("Foo" "foo") (names "F")))
3422 (assert (equal '("Foo") (names "Fo")))
3423 (assert (equal '("foo") (names "FO")))))
3424
3425 ;;;; Fuzzy completion
3426
3427 (defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
3428 "Return an (optionally limited to LIMIT best results) list of
3429 fuzzy completions for a symbol designator STRING. The list will
3430 be sorted by score, most likely match first.
3431
3432 The result is a list of completion objects, where a completion
3433 object is:
3434 (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
3435 where a CHUNK is a description of a matched string of characters:
3436 (OFFSET STRING)
3437 and FLAGS is a list of keywords describing properties of the symbol.
3438 For example, the top result for completing \"mvb\" in a package
3439 that uses COMMON-LISP would be something like:
3440 (\"multiple-value-bind\" 42.391666 ((0 \"mul\") (9 \"v\") (15 \"b\"))
3441 (:FBOUNDP :MACRO))
3442
3443 If STRING is package qualified the result list will also be
3444 qualified. If string is non-qualified the result strings are
3445 also not qualified and are considered relative to
3446 DEFAULT-PACKAGE-NAME.
3447
3448 Which symbols are candidates for matching depends on the symbol
3449 designator's format. The cases are as follows:
3450 FOO - Symbols accessible in the buffer package.
3451 PKG:FOO - Symbols external in package PKG.
3452 PKG::FOO - Symbols accessible in package PKG."
3453 ;; We may send this as elisp [] arrays to spare a coerce here,
3454 ;; but then the network serialization were slower by handling arrays.
3455 ;; Instead we limit the number of completions that is transferred
3456 ;; (the limit is set from emacs).
3457 (coerce (fuzzy-completion-set string default-package-name
3458 :limit limit :time-limit-in-msec time-limit-in-msec)
3459 'list))
3460
3461 (defun convert-fuzzy-completion-result (result converter
3462 internal-p package-name)
3463 "Converts a result from the fuzzy completion core into
3464 something that emacs is expecting. Converts symbols to strings,
3465 fixes case issues, and adds information describing if the symbol
3466 is :bound, :fbound, a :class, a :macro, a :generic-function,
3467 a :special-operator, or a :package."
3468 (destructuring-bind (symbol-or-name score chunks) result
3469 (multiple-value-bind (name added-length)
3470 (format-completion-result
3471 (if converter
3472 (funcall converter
3473 (if (symbolp symbol-or-name)
3474 (symbol-name symbol-or-name)
3475 symbol-or-name))
3476 symbol-or-name)
3477 internal-p package-name)
3478 (list name score
3479 (mapcar
3480 #'(lambda (chunk)
3481 ;; fix up chunk positions to account for possible
3482 ;; added package identifier
3483 (list (+ added-length (first chunk))
3484 (second chunk)))
3485 chunks)
3486 (loop for flag in '(:boundp :fboundp :generic-function
3487 :class :macro :special-operator
3488 :package)
3489 if (if (symbolp symbol-or-name)
3490 (case flag
3491 (:boundp (boundp symbol-or-name))
3492 (:fboundp (fboundp symbol-or-name))
3493 (:class (find-class symbol-or-name nil))
3494 (:macro (macro-function symbol-or-name))
3495 (:special-operator
3496 (special-operator-p symbol-or-name))
3497 (:generic-function
3498 (typep (ignore-errors (fdefinition symbol-or-name))
3499 'generic-function)))
3500 (case flag
3501 (:package (stringp symbol-or-name)
3502 ;; KLUDGE: depends on internal
3503 ;; knowledge that packages are
3504 ;; brought up from the bowels of
3505 ;; the completion algorithm as
3506 ;; strings!
3507 )))
3508 collect flag)))))
3509
3510 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
3511 "Prepares list of completion obajects, sorted by SCORE, of fuzzy
3512 completions of STRING in DEFAULT-PACKAGE-NAME. If LIMIT is set,
3513 only the top LIMIT results will be returned."
3514 (declare (type (or null (integer 0 #.(1- most-positive-fixnum))) limit time-limit-in-msec))
3515 (multiple-value-bind (name package-name package internal-p)
3516 (parse-completion-arguments string default-package-name)
3517 (flet ((convert (vector &optional converter)
3518 (when vector
3519 (loop for idx below (length vector)
3520 for el = (aref vector idx)
3521 do (setf (aref vector idx) (convert-fuzzy-completion-result
3522 el converter internal-p package-name))))))
3523 (let* ((symbols (and package
3524 (fuzzy-find-matching-symbols name
3525 package
3526 (and (not internal-p)
3527 package-name)
3528 :time-limit-in-msec time-limit-in-msec
3529 :return-converted-p nil)))
3530 (packs (and (not package-name)
3531 (fuzzy-find-matching-packages name)))
3532 (results))
3533 (convert symbols (completion-output-symbol-converter string))
3534 (convert packs)
3535 (setf results (sort (concatenate 'vector symbols packs) #'> :key #'second))
3536 (when (and limit
3537 (> limit 0)
3538 (< limit (length results)))
3539 (if (array-has-fill-pointer-p results)
3540 (setf (fill-pointer results) limit)
3541 (setf results (make-array limit :displaced-to results))))
3542 results))))
3543
3544 (defun fuzzy-find-matching-symbols (string package external &key time-limit-in-msec return-converted-p)
3545 "Return a list of symbols in PACKAGE matching STRING using the
3546 fuzzy completion algorithm. If EXTERNAL is true, only external
3547 symbols are returned."
3548 (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
3549 (time-limit (if time-limit-in-msec
3550 (ceiling (/ time-limit-in-msec 1000))
3551 0))
3552 (utime-at-start (get-universal-time))
3553 (count 0)
3554 (converter (completion-output-symbol-converter string)))
3555 (declare (type (integer 0 #.(1- most-positive-fixnum)) count time-limit)
3556 (type function converter))
3557 (flet ((symbol-match (symbol converted)
3558 (and (or (not external)
3559 (symbol-external-p symbol package))
3560 (compute-highest-scoring-completion
3561 string converted))))
3562 (block loop
3563 (do-symbols* (symbol package)
3564 (incf count)
3565 (when (and (not (zerop time-limit))
3566 (zerop (mod count 256)) ; ease up on calling get-universal-time like crazy
3567 (>= (- (get-universal-time) utime-at-start) time-limit))
3568 (return-from loop))
3569 (let* ((converted (funcall converter (symbol-name symbol)))
3570 (result (if return-converted-p converted symbol)))
3571 (if (string= "" string)
3572 (when (or (and external (symbol-external-p symbol package))
3573 (not external))
3574 (vector-push-extend (list result 0.0 (list (list 0 ""))) completions))
3575 (multiple-value-bind (match-result score) (symbol-match symbol converted)
3576 (when match-result
3577 (vector-push-extend (list result score match-result) completions)))))))
3578 completions)))
3579
3580 (defun fuzzy-find-matching-packages (name)
3581 "Return a list of package names matching NAME using the fuzzy
3582 completion algorithm."
3583 (let ((converter (completion-output-package-converter name))
3584 (completions (make-array 32 :adjustable t :fill-pointer 0)))
3585 (declare (optimize (speed 3))
3586 (type function converter))
3587 (loop for package in (list-all-packages)
3588 for package-name = (concatenate 'string
3589 (funcall converter
3590 (package-name package))
3591 ":")
3592 for (result score) = (multiple-value-list
3593 (compute-highest-scoring-completion
3594 name package-name))
3595 when result do
3596 (vector-push-extend (list package-name score result) completions))
3597 completions))
3598
3599 (defslimefun fuzzy-completion-selected (original-string completion)
3600 "This function is called by Slime when a fuzzy completion is
3601 selected by the user. It is for future expansion to make
3602 testing, say, a machine learning algorithm for completion scoring
3603 easier.
3604
3605 ORIGINAL-STRING is the string the user completed from, and
3606 COMPLETION is the completion object (see docstring for
3607 SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
3608 user selected."
3609 (declare (ignore original-string completion))
3610 nil)
3611
3612 ;;;;; Fuzzy completion core
3613
3614 (defparameter *fuzzy-recursion-soft-limit* 30
3615 "This is a soft limit for recursion in
3616 RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
3617 completing a string such as \"ZZZZZZ\" with a symbol named
3618 \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
3619 find all the ways it can match.
3620
3621 Most natural language searches and symbols do not have this
3622 problem -- this is only here as a safeguard.")
3623 (declaim (fixnum *fuzzy-recursion-soft-limit*))
3624
3625 (defun compute-highest-scoring-completion (short full)
3626 "Finds the highest scoring way to complete the abbreviation
3627 SHORT onto the string FULL, using CHAR= as a equality function for
3628 letters. Returns two values: The first being the completion
3629 chunks of the high scorer, and the second being the score."
3630 (let* ((scored-results
3631 (mapcar #'(lambda (result)
3632 (cons (score-completion result short full) result))
3633 (compute-most-completions short full)))
3634 (winner (first (sort scored-results #'> :key #'first))))
3635 (values (rest winner) (first winner))))
3636
3637 (defun compute-most-completions (short full)
3638 "Finds most possible ways to complete FULL with the letters in SHORT.
3639 Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
3640 a list of (&rest CHUNKS), where each CHUNKS is a description of
3641 how a completion matches."
3642 (let ((*all-chunks* nil))
3643 (declare (special *all-chunks*))
3644 (recursively-compute-most-completions short full 0 0 nil nil nil t)
3645 *all-chunks*))
3646
3647 (defun recursively-compute-most-completions
3648 (short full
3649 short-index initial-full-index
3650 chunks current-chunk current-chunk-pos
3651 recurse-p)
3652 "Recursively (if RECURSE-P is true) find /most/ possible ways
3653 to fuzzily map the letters in SHORT onto FULL, using CHAR= to
3654 determine if two letters match.
3655
3656 A chunk is a list of elements that have matched consecutively.
3657 When consecutive matches stop, it is coerced into a string,
3658 paired with the starting position of the chunk, and pushed onto
3659 CHUNKS.
3660
3661 Whenever a letter matches, if RECURSE-P is true,
3662 RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
3663 one index ahead, to find other possibly higher scoring
3664 possibilities. If there are less than
3665 *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
3666 this call will also recurse.
3667
3668 Once a word has been completely matched, the chunks are pushed
3669 onto the special variable *ALL-CHUNKS* and the function returns."
3670 (declare ;(optimize speed)
3671 (fixnum short-index initial-full-index)
3672 (simple-string short full)
3673 (special *all-chunks*))
3674 (flet ((short-cur ()
3675 "Returns the next letter from the abbreviation, or NIL
3676 if all have been used."
3677 (if (= short-index (length short))
3678 nil
3679 (aref short short-index)))
3680 (add-to-chunk (char pos)
3681 "Adds the CHAR at POS in FULL to the current chunk,
3682 marking the start position if it is empty."
3683 (unless current-chunk
3684 (setf current-chunk-pos pos))
3685 (push char current-chunk))
3686 (collect-chunk ()
3687 "Collects the current chunk to CHUNKS and prepares for
3688 a new chunk."
3689 (when current-chunk
3690 (push (list current-chunk-pos
3691 (coerce (reverse current-chunk) 'string)) chunks)
3692 (setf current-chunk nil
3693 current-chunk-pos nil))))
3694 ;; If there's an outstanding chunk coming in collect it. Since
3695 ;; we're recursively called on skipping an input character, the
3696 ;; chunk can't possibly continue on.
3697 (when current-chunk (collect-chunk))
3698 (do ((pos initial-full-index (1+ pos)))
3699 ((= pos (length full)))
3700 (let ((cur-char (aref full pos)))
3701 (if (and (short-cur)
3702 (char= cur-char (short-cur)))
3703 (progn
3704 (when recurse-p
3705 ;; Try other possibilities, limiting insanely deep
3706 ;; recursion somewhat.
3707 (recursively-compute-most-completions
3708 short full short-index (1+ pos)
3709 chunks current-chunk current-chunk-pos
3710 (not (> (length *all-chunks*)
3711 *fuzzy-recursion-soft-limit*))))
3712 (incf short-index)
3713 (add-to-chunk cur-char pos))
3714 (collect-chunk))))
3715 (collect-chunk)
3716 ;; If we've exhausted the short characters we have a match.
3717 (if (short-cur)
3718 nil
3719 (let ((rev-chunks (reverse chunks)))
3720 (push rev-chunks *all-chunks*)
3721 rev-chunks))))
3722
3723 ;;;;; Fuzzy completion scoring
3724
3725 (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
3726 "Letters that are likely to be at the beginning of a symbol.
3727 Letters found after one of these prefixes will be scored as if
3728 they were at the beginning of ths symbol.")
3729 (defparameter *fuzzy-completion-symbol-suffixes* "*+->"
3730 "Letters that are likely to be at the end of a symbol.
3731 Letters found before one of these suffixes will be scored as if
3732 they were at the end of the symbol.")
3733 (defparameter *fuzzy-completion-word-separators* "-/."
3734 "Letters that separate different words in symbols. Letters
3735 after one of these symbols will be scores more highly than other
3736 letters.")
3737
3738 (defun score-completion (completion short full)
3739 "Scores the completion chunks COMPLETION as a completion from