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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5