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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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