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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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