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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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