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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.175 - (show annotations)
Mon Apr 26 21:59:25 2004 UTC (9 years, 11 months ago) by lgorrie
Branch: MAIN
Changes since 1.174: +3 -1 lines
(interactive-eval): Bind *package* to *buffer-package*, so that `C-x
C-e' and related commands evaluate in the expected package.
1 ;;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-;;;
2 ;;;
3 ;;; swank.lisp --- the portable bits
4 ;;;
5 ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties are
8 ;;; disclaimed.
9
10 (defpackage :swank
11 (:use :common-lisp :swank-backend)
12 (:export #:startup-multiprocessing
13 #:start-server
14 #:create-swank-server
15 #:ed-in-emacs
16 #:print-indentation-lossage
17 ;; configurables
18 #:*sldb-pprint-frames*
19 #:*communication-style*
20 #:*log-events*
21 #:*use-dedicated-output-stream*
22 #:*configure-emacs-indentation*
23 ;; re-exported from backend
24 #:frame-source-location-for-emacs
25 #:restart-frame
26 #:profiled-functions
27 #:profile-report
28 #:profile-reset
29 #:unprofile-all
30 #:profile-package
31 #:set-default-directory
32 #:quit-lisp
33 ))
34
35 (in-package :swank)
36
37 (declaim (optimize (debug 3)))
38
39 (defvar *swank-io-package*
40 (let ((package (make-package :swank-io-package :use '())))
41 (import '(nil t quote) package)
42 package))
43
44 (defconstant +server-port+ 4005
45 "Default port for the Swank TCP server.")
46
47 (defvar *swank-debug-p* t
48 "When true, print extra debugging information.")
49
50 (defvar *sldb-pprint-frames* nil
51 "*pretty-print* is bound to this value when sldb prints a frame.")
52
53 ;;; public interface. slimefuns are the things that emacs is allowed
54 ;;; to call
55
56 (defmacro defslimefun (name arglist &body rest)
57 `(progn
58 (defun ,name ,arglist ,@rest)
59 (export ',name :swank)))
60
61 (declaim (ftype (function () nil) missing-arg))
62 (defun missing-arg ()
63 (error "A required &KEY or &OPTIONAL argument was not supplied."))
64
65 (defun package-external-symbols (package)
66 (let ((list '()))
67 (do-external-symbols (sym package) (push sym list))
68 list))
69
70 ;; (package-external-symbols (find-package :swank))
71
72
73 ;;;; Connections
74 ;;;
75 ;;; Connection structures represent the network connections between
76 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
77 ;;; streams that redirect to Emacs, and optionally a second socket
78 ;;; used solely to pipe user-output to Emacs (an optimization).
79 ;;;
80
81 (defstruct (connection
82 (:conc-name connection.)
83 ;; (:print-function %print-connection)
84 )
85 ;; Raw I/O stream of socket connection.
86 (socket-io (missing-arg) :type stream :read-only t)
87 ;; Optional dedicated output socket (backending `user-output' slot).
88 ;; Has a slot so that it can be closed with the connection.
89 (dedicated-output nil :type (or stream null))
90 ;; Streams that can be used for user interaction, with requests
91 ;; redirected to Emacs.
92 (user-input nil :type (or stream null))
93 (user-output nil :type (or stream null))
94 (user-io nil :type (or stream null))
95 ;;
96 control-thread
97 reader-thread
98 ;; The REPL thread loops receiving functions to apply.
99 ;; REPL expressions are sent to this thread for evaluation so that
100 ;; they always run in the same thread.
101 repl-thread
102 (read (missing-arg) :type function)
103 (send (missing-arg) :type function)
104 (serve-requests (missing-arg) :type function)
105 (cleanup nil :type (or null function))
106 ;; Cache of indentation information that has been sent to Emacs.
107 ;; This is used for preparing deltas for updates.
108 ;; Maps: symbol -> indentation specification
109 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
110 ;; The list of packages represented in the cache.
111 (indentation-cache-packages nil)
112 )
113
114 #+(or)
115 (defun %print-connection (connection stream depth)
116 (declare (ignore depth))
117 (print-unreadable-object (connection stream :type t :identity t)))
118
119 (defvar *connections* '()
120 "List of all active connections, with the most recent at the front.")
121
122 (defvar *emacs-connection* nil
123 "The connection to Emacs.
124 All threads communicate through this interface with Emacs.")
125
126 (defvar *swank-state-stack* '()
127 "A list of symbols describing the current state. Used for debugging
128 and to detect situations where interrupts can be ignored.")
129
130 (defun default-connection ()
131 "Return the 'default' Emacs connection.
132 The default connection is defined (quite arbitrarily) as the most
133 recently established one."
134 (car *connections*))
135
136 (defslimefun state-stack ()
137 "Return the value of *SWANK-STATE-STACK*."
138 *swank-state-stack*)
139
140 ;; Condition for SLIME protocol errors.
141 (define-condition slime-read-error (error)
142 ((condition :initarg :condition :reader slime-read-error.condition))
143 (:report (lambda (condition stream)
144 (format stream "~A" (slime-read-error.condition condition)))))
145
146 ;;;; Helper macros
147
148 (defmacro with-io-redirection ((connection) &body body)
149 "Execute BODY with I/O redirection to CONNECTION.
150 If *REDIRECT-IO* is true, all standard I/O streams are redirected."
151 `(if *redirect-io*
152 (call-with-redirected-io ,connection (lambda () ,@body))
153 (progn ,@body)))
154
155 (defmacro with-connection ((connection) &body body)
156 "Execute BODY in the context of CONNECTION."
157 `(let ((*emacs-connection* ,connection))
158 (catch 'slime-toplevel
159 (with-io-redirection (*emacs-connection*)
160 (let ((*debugger-hook* #'swank-debugger-hook))
161 ,@body)))))
162
163 (defmacro without-interrupts (&body body)
164 `(call-without-interrupts (lambda () ,@body)))
165
166 (defmacro destructure-case (value &rest patterns)
167 "Dispatch VALUE to one of PATTERNS.
168 A cross between `case' and `destructuring-bind'.
169 The pattern syntax is:
170 ((HEAD . ARGS) . BODY)
171 The list of patterns is searched for a HEAD `eq' to the car of
172 VALUE. If one is found, the BODY is executed with ARGS bound to the
173 corresponding values in the CDR of VALUE."
174 (let ((operator (gensym "op-"))
175 (operands (gensym "rand-"))
176 (tmp (gensym "tmp-")))
177 `(let* ((,tmp ,value)
178 (,operator (car ,tmp))
179 (,operands (cdr ,tmp)))
180 (case ,operator
181 ,@(mapcar (lambda (clause)
182 (if (eq (car clause) t)
183 `(t ,@(cdr clause))
184 (destructuring-bind ((op &rest rands) &rest body)
185 clause
186 `(,op (destructuring-bind ,rands ,operands
187 . ,body)))))
188 patterns)
189 ,@(if (eq (caar (last patterns)) t)
190 '()
191 `((t (error "destructure-case failed: ~S" ,tmp))))))))
192
193 (defmacro with-temp-package (var &body body)
194 "Execute BODY with VAR bound to a temporary package.
195 The package is deleted before returning."
196 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
197 (unwind-protect (progn ,@body)
198 (delete-package ,var))))
199
200 ;;;; TCP Server
201
202 (defparameter *redirect-io* t
203 "When non-nil redirect Lisp standard I/O to Emacs.
204 Redirection is done while Lisp is processing a request for Emacs.")
205
206 (defvar *use-dedicated-output-stream* t)
207 (defvar *communication-style* (preferred-communication-style))
208 (defvar *log-events* nil)
209
210 (defun start-server (port-file &optional (background *communication-style*)
211 dont-close)
212 (setup-server 0 (lambda (port) (announce-server-port port-file port))
213 background dont-close))
214
215 (defun create-swank-server (&optional (port +server-port+)
216 (background *communication-style*)
217 (announce-fn #'simple-announce-function)
218 dont-close)
219 (setup-server port announce-fn background dont-close))
220
221 (defparameter *loopback-interface* "127.0.0.1")
222
223 (defun setup-server (port announce-fn style dont-close)
224 (declare (type function announce-fn))
225 (let* ((socket (create-socket *loopback-interface* port))
226 (port (local-port socket)))
227 (funcall announce-fn port)
228 (cond ((eq style :spawn)
229 (spawn (lambda ()
230 (loop do (serve-connection socket :spawn dont-close)
231 while dont-close))
232 :name "Swank"))
233 (t (serve-connection socket style nil)))
234 port))
235
236 (defun serve-connection (socket style dont-close)
237 (let ((client (accept-connection socket)))
238 (unless dont-close
239 (close-socket socket))
240 (let ((connection (create-connection client style)))
241 (init-emacs-connection connection)
242 (push connection *connections*)
243 (serve-requests connection))))
244
245 (defun serve-requests (connection)
246 "Read and process all requests on connections."
247 (funcall (connection.serve-requests connection) connection))
248
249 (defun init-emacs-connection (connection)
250 (declare (ignore connection))
251 (emacs-connected))
252
253 (defun announce-server-port (file port)
254 (with-open-file (s file
255 :direction :output
256 :if-exists :overwrite
257 :if-does-not-exist :create)
258 (format s "~S~%" port))
259 (simple-announce-function port))
260
261 (defun simple-announce-function (port)
262 (when *swank-debug-p*
263 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
264
265 (defun open-streams (connection)
266 "Return the 4 streams for IO redirection:
267 DEDICATED-OUTPUT INPUT OUTPUT IO"
268 (multiple-value-bind (output-fn dedicated-output)
269 (make-output-function connection)
270 (let ((input-fn
271 (lambda ()
272 (with-connection (connection)
273 (with-simple-restart (abort "Abort reading input from Emacs.")
274 (read-user-input-from-emacs))))))
275 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
276 (let ((out (or dedicated-output out)))
277 (let ((io (make-two-way-stream in out)))
278 (values dedicated-output in out io)))))))
279
280 (defun make-output-function (connection)
281 "Create function to send user output to Emacs.
282 This function may open a dedicated socket to send output. It
283 returns two values: the output function, and the dedicated
284 stream (or NIL if none was created)."
285 (if *use-dedicated-output-stream*
286 (let ((stream (open-dedicated-output-stream
287 (connection.socket-io connection))))
288 (values (lambda (string)
289 (write-string string stream)
290 (force-output stream))
291 stream))
292 (values (lambda (string)
293 (with-connection (connection)
294 (with-simple-restart
295 (abort "Abort sending output to Emacs.")
296 (send-to-emacs `(:read-output ,string)))))
297 nil)))
298
299 (defun open-dedicated-output-stream (socket-io)
300 "Open a dedicated output connection to the Emacs on SOCKET-IO.
301 Return an output stream suitable for writing program output.
302
303 This is an optimized way for Lisp to deliver output to Emacs."
304 (let* ((socket (create-socket *loopback-interface* 0))
305 (port (local-port socket)))
306 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
307 (accept-connection socket)))
308
309 (defun handle-request (connection)
310 "Read and process one request. The processing is done in the extend
311 of the toplevel restart."
312 (assert (null *swank-state-stack*))
313 (let ((*swank-state-stack* '(:handle-request)))
314 (with-connection (connection)
315 (with-simple-restart (abort "Abort handling SLIME request.")
316 (read-from-emacs)))))
317
318 (defun changelog-date ()
319 "Return the datestring of the latest ChangeLog entry. The date is
320 determined at compile time."
321 (macrolet ((date ()
322 (let* ((here (or *compile-file-truename* *load-truename*))
323 (changelog (make-pathname
324 :name "ChangeLog"
325 :device (pathname-device here)
326 :directory (pathname-directory here)
327 :host (pathname-host here)))
328 (date (with-open-file (file changelog :direction :input)
329 (string (read file)))))
330 `(quote ,date))))
331 (date)))
332
333 (defun current-socket-io ()
334 (connection.socket-io *emacs-connection*))
335
336 (defun close-connection (c &optional condition)
337 (when condition
338 (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition))
339 (let ((cleanup (connection.cleanup c)))
340 (when cleanup
341 (funcall cleanup c)))
342 (close (connection.socket-io c))
343 (when (connection.dedicated-output c)
344 (close (connection.dedicated-output c)))
345 (setf *connections* (remove c *connections*)))
346
347 (defmacro with-reader-error-handler ((connection) &body body)
348 `(handler-case (progn ,@body)
349 (slime-read-error (e) (close-connection ,connection e))))
350
351 (defun read-loop (control-thread input-stream connection)
352 (with-reader-error-handler (connection)
353 (loop (send control-thread (decode-message input-stream)))))
354
355 (defvar *active-threads* '())
356 (defvar *thread-counter* 0)
357
358 (defun remove-dead-threads ()
359 (setq *active-threads*
360 (remove-if-not #'thread-alive-p *active-threads*)))
361
362 (defun add-thread (thread)
363 (let ((id (mod (1+ *thread-counter*) most-positive-fixnum)))
364 (setq *active-threads* (acons id thread *active-threads*)
365 *thread-counter* id)
366 id))
367
368 (defun drop&find (item list key test)
369 "Return LIST where item is removed together with the removed
370 element."
371 (declare (type function key test))
372 (do ((stack '() (cons (car l) stack))
373 (l list (cdr l)))
374 ((null l) (values (nreverse stack) nil))
375 (when (funcall test item (funcall key (car l)))
376 (return (values (nreconc stack (cdr l))
377 (car l))))))
378
379 (defun drop-thread (thread)
380 "Drop the first occurence of thread in *active-threads* and return its id."
381 (multiple-value-bind (list pair) (drop&find thread *active-threads*
382 #'cdr #'eql)
383 (setq *active-threads* list)
384 (assert pair)
385 (car pair)))
386
387 (defvar *lookup-counter* nil
388 "A simple counter used to remove dead threads from *active-threads*.")
389
390 (defun lookup-thread (thread)
391 (when (zerop (decf *lookup-counter*))
392 (setf *lookup-counter* 50)
393 (remove-dead-threads))
394 (let ((probe (rassoc thread *active-threads*)))
395 (cond (probe (car probe))
396 (t (add-thread thread)))))
397
398 (defun lookup-thread-id (id &optional noerror)
399 (let ((probe (assoc id *active-threads*)))
400 (cond (probe (cdr probe))
401 (noerror nil)
402 (t (error "Thread id not found ~S" id)))))
403
404 (defun dispatch-loop (socket-io connection)
405 (let ((*emacs-connection* connection)
406 (*active-threads* '())
407 (*thread-counter* 0)
408 (*lookup-counter* 50))
409 (loop (with-simple-restart (abort "Restart dispatch loop.")
410 (loop (dispatch-event (receive) socket-io))))))
411
412 (defun simple-break ()
413 (with-simple-restart (continue "Continue from interrupt.")
414 (let ((*debugger-hook* #'swank-debugger-hook))
415 (invoke-debugger
416 (make-condition 'simple-error
417 :format-control "Interrupt from Emacs")))))
418
419 (defun interrupt-worker-thread (thread)
420 (let ((thread (etypecase thread
421 ((member t) (cdr (car *active-threads*)))
422 (fixnum (lookup-thread-id thread)))))
423 (interrupt-thread thread #'simple-break)))
424
425 (defun dispatch-event (event socket-io)
426 (log-event "DISPATCHING: ~S~%" event)
427 (destructure-case event
428 ((:emacs-rex form package thread id)
429 (let ((thread (etypecase thread
430 ((member t)
431 (let ((c *emacs-connection*))
432 (spawn (lambda () (handle-request c))
433 :name "worker")))
434 (fixnum (lookup-thread-id thread)))))
435 (send thread `(eval-for-emacs ,form ,package ,id))
436 (add-thread thread)))
437 ((:emacs-interrupt thread)
438 (interrupt-worker-thread thread))
439 (((:debug :debug-condition :debug-activate) thread &rest args)
440 (encode-message `(,(car event) ,(add-thread thread) . ,args) socket-io))
441 ((:debug-return thread level)
442 (encode-message `(:debug-return ,(drop-thread thread) ,level) socket-io))
443 ((:return thread &rest args)
444 (drop-thread thread)
445 (encode-message `(:return ,@args) socket-io))
446 ((:read-string thread &rest args)
447 (encode-message `(:read-string ,(add-thread thread) ,@args) socket-io))
448 ((:read-aborted thread &rest args)
449 (encode-message `(:read-aborted ,(drop-thread thread) ,@args) socket-io))
450 ((:emacs-return-string thread tag string)
451 (send (lookup-thread-id thread) `(take-input ,tag ,string)))
452 (((:read-output :new-package :new-features :ed :%apply :indentation-update)
453 &rest _)
454 (declare (ignore _))
455 (encode-message event socket-io))))
456
457 (defun spawn-threads-for-connection (connection)
458 (let ((socket-io (connection.socket-io connection)))
459 (let ((control-thread (spawn (lambda ()
460 (dispatch-loop socket-io connection))
461 :name "control-thread")))
462 (setf (connection.control-thread connection) control-thread)
463 (let ((reader-thread (spawn (lambda ()
464 (read-loop control-thread socket-io
465 connection))
466 :name "reader-thread")))
467 (setf (connection.reader-thread connection) reader-thread)
468 (setf (connection.repl-thread connection)
469 (spawn (lambda () (repl-loop connection))))
470 connection))))
471
472 (defun repl-loop (connection)
473 (with-connection (connection)
474 (loop do (funcall (receive)))))
475
476 (defun initialize-streams-for-connection (connection)
477 (multiple-value-bind (dedicated in out io) (open-streams connection)
478 (setf (connection.dedicated-output connection) dedicated
479 (connection.user-io connection) io
480 (connection.user-output connection) out
481 (connection.user-input connection) in)
482 connection))
483
484 (defun create-connection (socket-io style)
485 (initialize-streams-for-connection
486 (ecase style
487 (:spawn
488 (make-connection :socket-io socket-io
489 :read #'read-from-control-thread
490 :send #'send-to-control-thread
491 :serve-requests #'spawn-threads-for-connection))
492 (:sigio
493 (make-connection :socket-io socket-io
494 :read #'read-from-socket-io
495 :send #'send-to-socket-io
496 :serve-requests #'install-sigio-handler
497 :cleanup #'deinstall-sigio-handler))
498 (:fd-handler
499 (make-connection :socket-io socket-io
500 :read #'read-from-socket-io
501 :send #'send-to-socket-io
502 :serve-requests #'install-fd-handler
503 :cleanup #'deinstall-fd-handler))
504 ((nil)
505 (make-connection :socket-io socket-io
506 :read #'read-from-socket-io
507 :send #'send-to-socket-io
508 :serve-requests #'simple-serve-requests)))))
509
510 (defun process-available-input (stream fn)
511 (loop while (and (open-stream-p stream)
512 (listen stream))
513 do (funcall fn)))
514
515 ;;;;;; Signal driven IO
516
517 (defun install-sigio-handler (connection)
518 (let ((client (connection.socket-io connection)))
519 (flet ((handler ()
520 (cond ((null *swank-state-stack*)
521 (with-reader-error-handler (connection)
522 (process-available-input
523 client (lambda () (handle-request connection)))))
524 ((eq (car *swank-state-stack*) :read-next-form))
525 (t (process-available-input client #'read-from-emacs)))))
526 (add-sigio-handler client #'handler)
527 (handler))))
528
529 (defun deinstall-sigio-handler (connection)
530 (remove-sigio-handlers (connection.socket-io connection)))
531
532 ;;;;;; SERVE-EVENT based IO
533
534 (defun install-fd-handler (connection)
535 (let ((client (connection.socket-io connection)))
536 (flet ((handler ()
537 (cond ((null *swank-state-stack*)
538 (with-reader-error-handler (connection)
539 (process-available-input
540 client (lambda () (handle-request connection)))))
541 ((eq (car *swank-state-stack*) :read-next-form))
542 (t (process-available-input client #'read-from-emacs)))))
543 (encode-message '(:use-sigint-for-interrupt) client)
544 (setq *debugger-hook*
545 (lambda (c h)
546 (with-reader-error-handler (connection)
547 (block debugger
548 (with-connection (connection)
549 (swank-debugger-hook c h)
550 (return-from debugger))
551 (abort)))))
552 (add-fd-handler client #'handler)
553 (handler))))
554
555 (defun deinstall-fd-handler (connection)
556 (remove-fd-handlers (connection.socket-io connection)))
557
558 ;;;;;; Simple sequential IO
559
560 (defun simple-serve-requests (connection)
561 (let ((socket-io (connection.socket-io connection)))
562 (encode-message '(:use-sigint-for-interrupt) socket-io)
563 (with-reader-error-handler (connection)
564 (loop (handle-request connection)))))
565
566 (defun read-from-socket-io ()
567 (let ((event (decode-message (current-socket-io))))
568 (log-event "DISPATCHING: ~S~%" event)
569 (destructure-case event
570 ((:emacs-rex form package thread id)
571 (declare (ignore thread))
572 `(eval-for-emacs ,form ,package ,id))
573 ((:emacs-interrupt thread)
574 (declare (ignore thread))
575 '(simple-break))
576 ((:emacs-return-string thread tag string)
577 (declare (ignore thread))
578 `(take-input ,tag ,string)))))
579
580 (defun send-to-socket-io (event)
581 (log-event "DISPATCHING: ~S~%" event)
582 (flet ((send (o) (encode-message o (current-socket-io))))
583 (destructure-case event
584 (((:debug-activate :debug :debug-return :read-string :read-aborted)
585 thread &rest args)
586 (declare (ignore thread))
587 (send `(,(car event) 0 ,@args)))
588 ((:return thread &rest args)
589 (declare (ignore thread))
590 (send `(:return ,@args)))
591 (((:read-output :new-package :new-features :debug-condition
592 :indentation-update :ed :%apply)
593 &rest _)
594 (declare (ignore _))
595 (send event)))))
596
597
598 ;;;; IO to Emacs
599 ;;;
600 ;;; The lower layer is a socket connection. Emacs sends us forms to
601 ;;; evaluate, and we accept these by calling READ-FROM-EMACS. These
602 ;;; evaluations can send messages back to Emacs as a side-effect by
603 ;;; calling SEND-TO-EMACS.
604
605 (defun call-with-redirected-io (connection function)
606 "Call FUNCTION with I/O streams redirected via CONNECTION."
607 (declare (type function function))
608 (let* ((io (connection.user-io connection))
609 (in (connection.user-input connection))
610 (out (connection.user-output connection))
611 (*standard-output* out)
612 (*error-output* out)
613 (*trace-output* out)
614 (*debug-io* io)
615 (*query-io* io)
616 (*standard-input* in)
617 (*terminal-io* io))
618 (funcall function)))
619
620 (defvar *log-io* *terminal-io*)
621
622 (defun log-event (format-string &rest args)
623 "Write a message to *terminal-io* when *log-events* is non-nil.
624 Useful for low level debugging."
625 (when *log-events*
626 (apply #'format *log-io* format-string args)))
627
628 (defun read-from-emacs ()
629 "Read and process a request from Emacs."
630 (apply #'funcall (funcall (connection.read *emacs-connection*))))
631
632 (defun read-from-control-thread ()
633 (receive))
634
635 (defun decode-message (stream)
636 "Read an S-expression from STREAM using the SLIME protocol.
637 If a protocol error occurs then a SLIME-READ-ERROR is signalled."
638 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
639 (flet ((next-byte () (char-code (read-char stream t))))
640 (handler-case
641 (let* ((length (logior (ash (next-byte) 16)
642 (ash (next-byte) 8)
643 (next-byte)))
644 (string (make-string length))
645 (pos (read-sequence string stream)))
646 (assert (= pos length) ()
647 "Short read: length=~D pos=~D" length pos)
648 (let ((form (read-form string)))
649 (log-event "READ: ~A~%" string)
650 form))
651 (serious-condition (c)
652 (error (make-condition 'slime-read-error :condition c)))))))
653
654 (defun read-form (string)
655 (with-standard-io-syntax
656 (let ((*package* *swank-io-package*))
657 (read-from-string string))))
658
659 (defvar *slime-features* nil
660 "The feature list that has been sent to Emacs.")
661
662 (defun sync-state-to-emacs ()
663 "Update Emacs if any relevant Lisp state has changed."
664 (unless (eq *slime-features* *features*)
665 (setq *slime-features* *features*)
666 (send-to-emacs (list :new-features (mapcar #'symbol-name *features*))))
667 (update-connection-indentation *emacs-connection*))
668
669 (defun send-to-emacs (object)
670 "Send OBJECT to Emacs."
671 (funcall (connection.send *emacs-connection*) object))
672
673 (defun send-oob-to-emacs (object)
674 (send-to-emacs object))
675
676 (defun send-to-control-thread (object)
677 (send (connection.control-thread *emacs-connection*) object))
678
679 (defun encode-message (message stream)
680 (let* ((string (prin1-to-string-for-emacs message))
681 (length (1+ (length string))))
682 (log-event "WRITE: ~A~%" string)
683 (without-interrupts
684 (loop for position from 16 downto 0 by 8
685 do (write-char (code-char (ldb (byte 8 position) length))
686 stream))
687 (write-string string stream)
688 (terpri stream)
689 (force-output stream))))
690
691 (defun prin1-to-string-for-emacs (object)
692 (with-standard-io-syntax
693 (let ((*print-case* :downcase)
694 (*print-readably* t)
695 (*print-pretty* nil)
696 (*package* *swank-io-package*))
697 (prin1-to-string object))))
698
699 (defun force-user-output ()
700 (force-output (connection.user-io *emacs-connection*))
701 (force-output (connection.user-output *emacs-connection*)))
702
703 (defun clear-user-input ()
704 (clear-input (connection.user-input *emacs-connection*)))
705
706 (defvar *read-input-catch-tag* 0)
707
708 (defun read-user-input-from-emacs ()
709 (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
710 (force-output)
711 (send-to-emacs `(:read-string ,(current-thread)
712 ,*read-input-catch-tag*))
713 (let ((ok nil))
714 (unwind-protect
715 (prog1 (catch *read-input-catch-tag*
716 (loop (read-from-emacs)))
717 (setq ok t))
718 (unless ok
719 (send-to-emacs `(:read-aborted ,(current-thread)
720 *read-input-catch-tag*)))))))
721
722 (defslimefun take-input (tag input)
723 "Return the string INPUT to the continuation TAG."
724 (throw tag input))
725
726 (defslimefun connection-info ()
727 "Return a list of the form:
728 \(VERSION PID IMPLEMENTATION-TYPE IMPLEMENTATION-NAME FEATURES)."
729 (list (changelog-date)
730 (getpid)
731 (lisp-implementation-type)
732 (lisp-implementation-type-name)
733 (setq *slime-features* *features*)))
734
735
736 ;;;; Reading and printing
737
738 (defvar *buffer-package*)
739 (setf (documentation '*buffer-package* 'symbol)
740 "Package corresponding to slime-buffer-package.
741
742 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
743 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
744
745 (defun from-string (string)
746 "Read string in the *BUFFER-PACKAGE*"
747 (let ((*package* *buffer-package*))
748 (read-from-string string)))
749
750 (defun symbol-from-string (string)
751 "Read string in the *BUFFER-PACKAGE*"
752 (let ((*package* *buffer-package*))
753 (find-symbol (string-upcase string))))
754
755 (defun to-string (string)
756 "Write string in the *BUFFER-PACKAGE*."
757 (let ((*package* *buffer-package*))
758 (prin1-to-string string)))
759
760 (defun guess-package-from-string (name &optional (default-package *package*))
761 (or (and name
762 (or (find-package name)
763 (find-package (string-upcase name))
764 (find-package (substitute #\- #\! name))))
765 default-package))
766
767 (defun find-symbol-designator (string &optional
768 (default-package *buffer-package*))
769 "Return the symbol corresponding to the symbol designator STRING.
770 If string is not package qualified use DEFAULT-PACKAGE for the
771 resolution. Return nil if no such symbol exists."
772 (multiple-value-bind (name package-name internal-p)
773 (tokenize-symbol-designator (case-convert-input string))
774 (cond ((and package-name (not (find-package package-name)))
775 (values nil nil))
776 (t
777 (let ((package (or (find-package package-name) default-package)))
778 (multiple-value-bind (symbol access) (find-symbol name package)
779 (cond ((and package-name (not internal-p)
780 (not (eq access :external)))
781 (values nil nil))
782 (access (values symbol access)))))))))
783
784 (defun find-symbol-or-lose (string &optional
785 (default-package *buffer-package*))
786 "Like FIND-SYMBOL-DESIGNATOR but signal an error the symbols doesn't
787 exists."
788 (multiple-value-bind (symbol package)
789 (find-symbol-designator string default-package)
790 (cond (package (values symbol package))
791 (t (error "Unknown symbol: ~S [in ~A]" string default-package)))))
792
793 (defun valid-operator-name-p (string)
794 "Test if STRING names a function, macro, or special-operator."
795 (let ((symbol (find-symbol-designator string)))
796 (or (fboundp symbol)
797 (macro-function symbol)
798 (special-operator-p symbol))))
799
800 (defslimefun arglist-for-echo-area (names)
801 "Return the arglist for the first function, macro, or special-op in NAMES."
802 (let ((name (find-if #'valid-operator-name-p names)))
803 (if name
804 (format-arglist-for-echo-area (find-symbol-designator name) name)
805 "")))
806
807 (defun format-arglist-for-echo-area (symbol name)
808 "Return SYMBOL's arglist as string for display in the echo area.
809 Use the string NAME as operator name."
810 (let ((arglist (arglist symbol)))
811 (etypecase arglist
812 ((member :not-available)
813 (format nil "(~A -- <not available>)" name))
814 (list
815 (arglist-to-string (cons name arglist)
816 (symbol-package symbol))))))
817
818 (defun arglist-to-string (arglist package)
819 "Print the list ARGLIST for display in the echo area.
820 The argument name are printed without package qualifiers and
821 pretty printing of (function foo) as #'foo is suppressed."
822 (etypecase arglist
823 (null "()")
824 (cons
825 (with-output-to-string (*standard-output*)
826 (with-standard-io-syntax
827 (let ((*package* package)
828 (*print-case* :downcase)
829 (*print-pretty* t)
830 (*print-circle* nil)
831 (*print-level* 10)
832 (*print-length* 20))
833 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
834 (loop
835 (let ((arg (pop arglist)))
836 (etypecase arg
837 (symbol (princ arg))
838 (string (princ arg))
839 (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
840 (princ (car arg))
841 (write-char #\space)
842 (pprint-fill *standard-output* (cdr arg) nil))))
843 (when (null arglist) (return))
844 (write-char #\space)
845 (pprint-newline :fill))))))))))
846
847 (defun test-print-arglist (list string)
848 (string= (arglist-to-string list (find-package :swank)) string))
849
850 ;; Should work:
851 (assert (test-print-arglist '(function cons) "(function cons)"))
852 (assert (test-print-arglist '(quote cons) "(quote cons)"))
853 (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
854 ;; Expected failure:
855 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
856
857 (defslimefun arglist-for-insertion (name)
858 (cond ((valid-operator-name-p name)
859 (let ((arglist (arglist (find-symbol-designator name))))
860 (etypecase arglist
861 ((member :not-available)
862 " <not available>")
863 (list
864 (format nil "~(~<~{~^ ~A~}~@:>~))" (list arglist))))))
865 (t
866 " <not available>")))
867
868
869 ;;;; Debugger
870
871 ;;; These variables are dynamically bound during debugging.
872
873 ;; The condition being debugged.
874 (defvar *swank-debugger-condition* nil)
875
876 (defvar *sldb-level* 0
877 "The current level of recursive debugging.")
878
879 (defvar *sldb-initial-frames* 20
880 "The initial number of backtrace frames to send to Emacs.")
881
882 (defvar *sldb-restarts* nil
883 "The list of currenlty active restarts.")
884
885 (defun swank-debugger-hook (condition hook)
886 "Debugger entry point, called from *DEBUGGER-HOOK*.
887 Sends a message to Emacs declaring that the debugger has been entered,
888 then waits to handle further requests from Emacs. Eventually returns
889 after Emacs causes a restart to be invoked."
890 (declare (ignore hook))
891 (flet ((debug-it () (debug-in-emacs condition)))
892 (cond (*emacs-connection*
893 (debug-it))
894 ((default-connection)
895 (with-connection ((default-connection))
896 (debug-in-emacs condition))))))
897
898 (defun debug-in-emacs (condition)
899 (let ((*swank-debugger-condition* condition)
900 (*sldb-restarts* (compute-restarts condition))
901 (*package* (or (and (boundp '*buffer-package*)
902 (symbol-value '*buffer-package*))
903 *package*))
904 (*sldb-level* (1+ *sldb-level*))
905 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))
906 (*print-readably* nil))
907 (force-user-output)
908 (call-with-debugging-environment
909 (lambda () (sldb-loop *sldb-level*)))))
910
911 (defun sldb-loop (level)
912 (unwind-protect
913 (catch 'sldb-enter-default-debugger
914 (send-to-emacs
915 (list* :debug (current-thread) *sldb-level*
916 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
917 (loop (catch 'sldb-loop-catcher
918 (with-simple-restart (abort "Return to sldb level ~D." level)
919 (send-to-emacs (list :debug-activate (current-thread)
920 *sldb-level*))
921 (handler-bind ((sldb-condition #'handle-sldb-condition))
922 (read-from-emacs))))))
923 (send-to-emacs `(:debug-return ,(current-thread) ,level))))
924
925 (defslimefun sldb-break-with-default-debugger ()
926 "Invoke the default debugger by returning from our debugger-loop."
927 (throw 'sldb-enter-default-debugger nil))
928
929 (defun handle-sldb-condition (condition)
930 "Handle an internal debugger condition.
931 Rather than recursively debug the debugger (a dangerous idea!), these
932 conditions are simply reported."
933 (let ((real-condition (original-condition condition)))
934 (send-to-emacs `(:debug-condition ,(current-thread)
935 ,(princ-to-string real-condition))))
936 (throw 'sldb-loop-catcher nil))
937
938 (defun safe-condition-message (condition)
939 "Safely print condition to a string, handling any errors during
940 printing."
941 (let ((*print-pretty* t))
942 (handler-case
943 (princ-to-string condition)
944 (error (cond)
945 ;; Beware of recursive errors in printing, so only use the condition
946 ;; if it is printable itself:
947 (format nil "Unable to display error condition~@[: ~A~]"
948 (ignore-errors (princ-to-string cond)))))))
949
950 (defun debugger-condition-for-emacs ()
951 (list (safe-condition-message *swank-debugger-condition*)
952 (format nil " [Condition of type ~S]"
953 (type-of *swank-debugger-condition*))))
954
955 (defun format-restarts-for-emacs ()
956 "Return a list of restarts for *swank-debugger-condition* in a
957 format suitable for Emacs."
958 (loop for restart in *sldb-restarts*
959 collect (list (princ-to-string (restart-name restart))
960 (princ-to-string restart))))
961
962 (defun frame-for-emacs (n frame)
963 (let* ((label (format nil " ~D: " n))
964 (string (with-output-to-string (stream)
965 (let ((*print-pretty* *sldb-pprint-frames*)
966 (*print-circle* t))
967 (princ label stream)
968 (print-frame frame stream)))))
969 (subseq string (length label))))
970
971 (defslimefun backtrace (start end)
972 "Return a list ((I FRAME) ...) of frames from START to END.
973 I is an integer describing and FRAME a string."
974 (loop for frame in (compute-backtrace start end)
975 for i from start
976 collect (list i (frame-for-emacs i frame))))
977
978 (defslimefun debugger-info-for-emacs (start end)
979 "Return debugger state, with stack frames from START to END.
980 The result is a list:
981 (condition ({restart}*) ({stack-frame}*)
982 where
983 condition ::= (description type)
984 restart ::= (name description)
985 stack-frame ::= (number description)
986
987 condition---a pair of strings: message, and type.
988
989 restart---a pair of strings: restart name, and description.
990
991 stack-frame---a number from zero (the top), and a printed
992 representation of the frame's call.
993
994 Below is an example return value. In this case the condition was a
995 division by zero (multi-line description), and only one frame is being
996 fetched (start=0, end=1).
997
998 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
999 Operation was KERNEL::DIVISION, operands (1 0).\"
1000 \"[Condition of type DIVISION-BY-ZERO]\")
1001 ((\"ABORT\" \"Return to Slime toplevel.\")
1002 (\"ABORT\" \"Return to Top-Level.\"))
1003 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))"
1004 (list (debugger-condition-for-emacs)
1005 (format-restarts-for-emacs)
1006 (backtrace start end)))
1007
1008 (defun nth-restart (index)
1009 (nth index *sldb-restarts*))
1010
1011 (defslimefun invoke-nth-restart (index)
1012 (invoke-restart-interactively (nth-restart index)))
1013
1014 (defslimefun sldb-abort ()
1015 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1016
1017 (defslimefun sldb-continue ()
1018 (continue))
1019
1020 (defslimefun throw-to-toplevel ()
1021 (throw 'slime-toplevel nil))
1022
1023 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
1024 "Invoke the Nth available restart.
1025 SLDB-LEVEL is the debug level when the request was made. If this
1026 has changed, ignore the request."
1027 (when (= sldb-level *sldb-level*)
1028 (invoke-nth-restart n)))
1029
1030 (defslimefun eval-string-in-frame (string index)
1031 (to-string (eval-in-frame (from-string string) index)))
1032
1033 (defslimefun pprint-eval-string-in-frame (string index)
1034 (swank-pprint
1035 (multiple-value-list
1036 (eval-in-frame (from-string string) index))))
1037
1038 (defslimefun frame-locals-for-emacs (index)
1039 "Return a property list ((&key NAME ID VALUE) ...) describing
1040 the local variables in the frame INDEX."
1041 (let ((*print-readably* nil)
1042 (*print-pretty* t)
1043 (*print-circle* t))
1044 (mapcar (lambda (frame-locals)
1045 (destructuring-bind (&key name id value) frame-locals
1046 (list :name (to-string name) :id id
1047 :value (to-string value))))
1048 (frame-locals index))))
1049
1050 (defslimefun frame-catch-tags-for-emacs (frame-index)
1051 (mapcar #'to-string (frame-catch-tags frame-index)))
1052
1053 (defslimefun sldb-disassemble (index)
1054 (with-output-to-string (*standard-output*)
1055 (disassemble-frame index)))
1056
1057 (defslimefun sldb-return-from-frame (index string)
1058 (let ((form (from-string string)))
1059 (to-string (multiple-value-list (return-from-frame index form)))))
1060
1061
1062 ;;;; Evaluation
1063
1064 (defun eval-in-emacs (form)
1065 "Execute FORM in Emacs."
1066 (destructuring-bind (fn &rest args) form
1067 (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))
1068
1069 (defun eval-for-emacs (form buffer-package id)
1070 "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
1071 Return the result values as a list to strings to the continuation ID.
1072 Errors are trapped and invoke our debugger."
1073 (let ((*debugger-hook* #'swank-debugger-hook))
1074 (let (ok result)
1075 (unwind-protect
1076 (let ((*buffer-package* (guess-package-from-string buffer-package)))
1077 (assert (packagep *buffer-package*))
1078 (setq result (eval form))
1079 (force-output)
1080 (sync-state-to-emacs)
1081 (setq ok t))
1082 (force-user-output)
1083 (send-to-emacs `(:return ,(current-thread)
1084 ,(if ok `(:ok ,result) '(:abort))
1085 ,id))))))
1086
1087 (defslimefun oneway-eval-string (string buffer-package)
1088 "Evaluate STRING in BUFFER-PACKAGE, without sending a reply.
1089 The debugger hook is inhibited during the evaluation."
1090 (let ((*buffer-package* (guess-package-from-string buffer-package))
1091 (*package* *buffer-package*)
1092 (*debugger-hook* nil))
1093 (eval (read-form string))))
1094
1095 (defun format-values-for-echo-area (values)
1096 (let ((*package* *buffer-package*))
1097 (cond (values (format nil "~{~S~^, ~}" values))
1098 (t "; No value"))))
1099
1100 (defslimefun interactive-eval (string)
1101 (let ((values (multiple-value-list
1102 (let ((*package* *buffer-package*))
1103 (eval (from-string string))))))
1104 (fresh-line)
1105 (force-output)
1106 (format-values-for-echo-area values)))
1107
1108 (defun eval-region (string &optional package-update-p)
1109 "Evaluate STRING and return the result.
1110 If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
1111 change, then send Emacs an update."
1112 (let ((*package* *buffer-package*)
1113 - values)
1114 (unwind-protect
1115 (with-input-from-string (stream string)
1116 (loop for form = (read stream nil stream)
1117 until (eq form stream)
1118 do (progn
1119 (setq - form)
1120 (setq values (multiple-value-list (eval form)))
1121 (force-output))
1122 finally (progn
1123 (fresh-line)
1124 (force-output)
1125 (return (values values -)))))
1126 (when (and package-update-p (not (eq *package* *buffer-package*)))
1127 (send-to-emacs
1128 (list :new-package (shortest-package-nickname *package*)))))))
1129
1130 (defun shortest-package-nickname (package)
1131 "Return the shortest nickname (or canonical name) of PACKAGE."
1132 (loop for name in (cons (package-name package) (package-nicknames package))
1133 for shortest = name then (if (< (length name) (length shortest))
1134 name
1135 shortest)
1136 finally (return shortest)))
1137
1138 (defslimefun interactive-eval-region (string)
1139 (let ((*package* *buffer-package*))
1140 (format-values-for-echo-area (eval-region string))))
1141
1142 (defslimefun re-evaluate-defvar (form)
1143 (let ((*package* *buffer-package*))
1144 (let ((form (read-from-string form)))
1145 (destructuring-bind (dv name &optional value doc) form
1146 (declare (ignore value doc))
1147 (assert (eq dv 'defvar))
1148 (makunbound name)
1149 (prin1-to-string (eval form))))))
1150
1151 (defvar *swank-pprint-circle* *print-circle*
1152 "*PRINT-CIRCLE* is bound to this value when pretty printing slime output.")
1153
1154 (defvar *swank-pprint-case* *print-case*
1155 "*PRINT-CASE* is bound to this value when pretty printing slime output.")
1156
1157 (defvar *swank-pprint-right-margin* *print-right-margin*
1158 "*PRINT-RIGHT-MARGIN* is bound to this value when pretty printing slime output.")
1159
1160 (defvar *swank-pprint-escape* *print-escape*
1161 "*PRINT-ESCAPE* is bound to this value when pretty printing slime output.")
1162
1163 (defvar *swank-pprint-level* *print-level*
1164 "*PRINT-LEVEL* is bound to this value when pretty printing slime output.")
1165
1166 (defvar *swank-pprint-length* *print-length*
1167 "*PRINT-LENGTH* is bound to this value when pretty printing slime output.")
1168
1169 (defun swank-pprint (list)
1170 "Bind some printer variables and pretty print each object in LIST."
1171 (let ((*print-pretty* t)
1172 (*print-case* *swank-pprint-case*)
1173 (*print-right-margin* *swank-pprint-right-margin*)
1174 (*print-circle* *swank-pprint-circle*)
1175 (*print-escape* *swank-pprint-escape*)
1176 (*print-level* *swank-pprint-level*)
1177 (*print-length* *swank-pprint-length*)
1178 (*package* *buffer-package*))
1179 (cond ((null list) "; No value")
1180 (t (with-output-to-string (*standard-output*)
1181 (dolist (o list)
1182 (pprint o)
1183 (terpri)))))))
1184
1185 (defslimefun pprint-eval (string)
1186 (let ((*package* *buffer-package*))
1187 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1188
1189 (defslimefun set-package (package)
1190 "Set *package* to PACKAGE and return its name and shortest nickname."
1191 (let ((p (setq *package* (guess-package-from-string package))))
1192 (list (package-name p) (shortest-package-nickname p))))
1193
1194 (defslimefun listener-eval (string)
1195 (if (connection.repl-thread *emacs-connection*)
1196 (repl-thread-eval string)
1197 (repl-eval string)))
1198
1199 (defun repl-thread-eval (string)
1200 "Evaluate STRING using REPL-EVAL in the REPL thread."
1201 ;; XXX Perhaps we should somehow formalize the set of "important"
1202 ;; specials which are here being passed to the other thread? -luke (26/Apr/2004)
1203 (let ((self (current-thread))
1204 (connection *emacs-connection*)
1205 (package *package*)
1206 (buffer-package *buffer-package*))
1207 (send (connection.repl-thread connection)
1208 (lambda ()
1209 (with-connection (connection)
1210 (let ((*buffer-package* buffer-package)
1211 (*package* package))
1212 (restart-case (send self (repl-eval string))
1213 (abort ()
1214 :report "Abort REPL evaluation"
1215 (send self "; Aborted")))))))
1216 (receive)))
1217
1218 (defun repl-eval (string)
1219 (clear-user-input)
1220 (multiple-value-bind (values last-form) (eval-region string t)
1221 (setq +++ ++ ++ + + last-form
1222 *** ** ** * * (car values)
1223 /// // // / / values)
1224 (cond ((null values) "; No value")
1225 (t
1226 (let ((*package* *buffer-package*))
1227 (format nil "~{~S~^~%~}" values))))))
1228
1229 (defslimefun ed-in-emacs (&optional what)
1230 "Edit WHAT in Emacs.
1231
1232 WHAT can be:
1233 A filename (string),
1234 A list (FILENAME LINE [COLUMN]),
1235 A function name (symbol),
1236 nil."
1237 (let ((target
1238 (cond ((and (listp what) (pathnamep (first what)))
1239 (cons (canonicalize-filename (car what)) (cdr what)))
1240 ((pathnamep what)
1241 (canonicalize-filename what))
1242 (t what))))
1243 (send-oob-to-emacs `(:ed ,target))))
1244
1245
1246 ;;;; Compilation Commands.
1247
1248 (defvar *compiler-notes* '()
1249 "List of compiler notes for the last compilation unit.")
1250
1251 (defun clear-compiler-notes ()
1252 (setf *compiler-notes* '()))
1253
1254 (defun canonicalize-filename (filename)
1255 (namestring (truename filename)))
1256
1257 (defslimefun compiler-notes-for-emacs ()
1258 "Return the list of compiler notes for the last compilation unit."
1259 (reverse *compiler-notes*))
1260
1261 (defun measure-time-interval (fn)
1262 "Call FN and return the first return value and the elapsed time.
1263 The time is measured in microseconds."
1264 (declare (type function fn))
1265 (let ((before (get-internal-real-time)))
1266 (values
1267 (funcall fn)
1268 (* (- (get-internal-real-time) before)
1269 (/ 1000000 internal-time-units-per-second)))))
1270
1271 (defun record-note-for-condition (condition)
1272 "Record a note for a compiler-condition."
1273 (push (make-compiler-note condition) *compiler-notes*))
1274
1275 (defun make-compiler-note (condition)
1276 "Make a compiler note data structure from a compiler-condition."
1277 (declare (type compiler-condition condition))
1278 (list* :message (message condition)
1279 :severity (severity condition)
1280 :location (location condition)
1281 (let ((s (short-message condition)))
1282 (if s (list :short-message s)))))
1283
1284 (defun swank-compiler (function)
1285 (clear-compiler-notes)
1286 (multiple-value-bind (result usecs)
1287 (handler-bind ((compiler-condition #'record-note-for-condition))
1288 (measure-time-interval function))
1289 (list (to-string result)
1290 (format nil "~,2F" (/ usecs 1000000.0)))))
1291
1292 (defslimefun compile-file-for-emacs (filename load-p)
1293 "Compile FILENAME and, when LOAD-P, load the result.
1294 Record compiler notes signalled as `compiler-condition's."
1295 (swank-compiler (lambda () (swank-compile-file filename load-p))))
1296
1297 (defslimefun compile-string-for-emacs (string buffer position)
1298 "Compile STRING (exerpted from BUFFER at POSITION).
1299 Record compiler notes signalled as `compiler-condition's."
1300 (swank-compiler
1301 (lambda ()
1302 (let ((*package* *buffer-package*))
1303 (swank-compile-string string :buffer buffer :position position)))))
1304
1305 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
1306 "Compile and load SYSTEM using ASDF.
1307 Record compiler notes signalled as `compiler-condition's."
1308 (swank-compiler
1309 (lambda ()
1310 (apply #'operate-on-system system-name operation keywords))))
1311
1312 (defun asdf-central-registry ()
1313 (when (find-package :asdf)
1314 (symbol-value (find-symbol (string :*central-registry*) :asdf))))
1315
1316 (defslimefun list-all-systems-in-central-registry ()
1317 "Returns a list of all systems in ASDF's central registry."
1318 (loop for dir in (asdf-central-registry)
1319 for defaults = (eval dir)
1320 when defaults
1321 nconc (mapcar #'file-namestring
1322 (directory
1323 (make-pathname :defaults defaults
1324 :version :newest
1325 :type "asd"
1326 :case :local)))))
1327
1328 ;;;; Macroexpansion
1329
1330 (defun apply-macro-expander (expander string)
1331 (declare (type function expander))
1332 (swank-pprint (list (funcall expander (from-string string)))))
1333
1334 (defslimefun swank-macroexpand-1 (string)
1335 (apply-macro-expander #'macroexpand-1 string))
1336
1337 (defslimefun swank-macroexpand (string)
1338 (apply-macro-expander #'macroexpand string))
1339
1340 (defslimefun swank-macroexpand-all (string)
1341 (apply-macro-expander #'macroexpand-all string))
1342
1343 (defslimefun disassemble-symbol (name)
1344 (with-output-to-string (*standard-output*)
1345 (disassemble (fdefinition (from-string name)))))
1346
1347
1348 ;;;; Completion
1349
1350 (defun determine-case (string)
1351 "Return to booleans LOWER and UPPER indicating whether STRING
1352 contains lower or upper case characters."
1353 (values (some #'lower-case-p string)
1354 (some #'upper-case-p string)))
1355
1356 (defun case-convert-input (string)
1357 "Convert STRING according to the current readtable-case."
1358 (check-type string string)
1359 (ecase (readtable-case *readtable*)
1360 (:upcase (string-upcase string))
1361 (:downcase (string-downcase string))
1362 (:preserve string)
1363 (:invert (multiple-value-bind (lower upper) (determine-case string)
1364 (cond ((and upper lower) string)
1365 (lower (string-upcase string))
1366 (upper (string-downcase string))
1367 (t string))))))
1368
1369 (defun carefully-find-package (name default-package-name)
1370 "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
1371 *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
1372 (let ((string (cond ((equal name "") "KEYWORD")
1373 (t (or name default-package-name)))))
1374 (if string
1375 (guess-package-from-string string nil)
1376 *buffer-package*)))
1377
1378 (defun parse-completion-arguments (string default-package-name)
1379 (multiple-value-bind (name package-name internal-p)
1380 (tokenize-symbol-designator string)
1381 (let ((package (carefully-find-package package-name default-package-name)))
1382 (values name package-name package internal-p))))
1383
1384 (defun format-completion-set (strings internal-p package-name)
1385 (mapcar (lambda (string)
1386 (cond (internal-p
1387 (format nil "~A::~A" package-name string))
1388 (package-name
1389 (format nil "~A:~A" package-name string))
1390 (t
1391 (format nil "~A" string))))
1392 (sort strings #'string<)))
1393
1394 (defun output-case-converter (input)
1395 "Return a function to case convert strings for output.
1396 INPUT is used to guess the preferred case."
1397 (ecase (readtable-case *readtable*)
1398 (:upcase (if (some #'lower-case-p input) #'string-downcase #'identity))
1399 (:invert (lambda (output)
1400 (multiple-value-bind (lower upper) (determine-case output)
1401 (cond ((and lower upper) output)
1402 (lower (string-upcase output))
1403 (upper (string-downcase output))
1404 (t output)))))
1405 (:downcase (if (some #'upper-case-p input) #'string-upcase #'identity))
1406 (:preserve #'identity)))
1407
1408 (defun find-matching-symbols (string package external test)
1409 "Return a list of symbols in PACKAGE matching STRING.
1410 TEST is called with two strings. If EXTERNAL is true, only external
1411 symbols are returned."
1412 (let ((completions '())
1413 (converter (output-case-converter string)))
1414 (flet ((symbol-matches-p (symbol)
1415 (and (or (not external)
1416 (symbol-external-p symbol package))
1417 (funcall test string
1418 (funcall converter (symbol-name symbol))))))
1419 (do-symbols (symbol package)
1420 (when (symbol-matches-p symbol)
1421 (push symbol completions))))
1422 (remove-duplicates completions)))
1423
1424 (defun find-matching-packages (name matcher)
1425 "Return a list of package names matching NAME."
1426 (let ((to-match (string-upcase name)))
1427 (remove-if-not (lambda (x) (funcall matcher to-match x))
1428 (mapcar (lambda (pkgname)
1429 (concatenate 'string pkgname ":"))
1430 (mapcar #'package-name (list-all-packages))))))
1431
1432 (defun completion-set (string default-package-name matchp)
1433 (declare (type simple-base-string string))
1434 (multiple-value-bind (name package-name package internal-p)
1435 (parse-completion-arguments string default-package-name)
1436 (let* ((symbols (and package
1437 (find-matching-symbols name
1438 package
1439 (and (not internal-p)
1440 package-name)
1441 matchp)))
1442 (packs (and (not package-name)
1443 (find-matching-packages name matchp)))
1444 (converter (output-case-converter name))
1445 (strings
1446 (mapcar converter
1447 (nconc (mapcar #'symbol-name symbols) packs))))
1448 (format-completion-set strings internal-p package-name))))
1449
1450 (defslimefun completions (string default-package-name)
1451 "Return a list of completions for a symbol designator STRING.
1452
1453 The result is the list (COMPLETION-SET
1454 COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
1455 completions, and COMPLETED-PREFIX is the best (partial)
1456 completion of the input string.
1457
1458 If STRING is package qualified the result list will also be
1459 qualified. If string is non-qualified the result strings are
1460 also not qualified and are considered relative to
1461 DEFAULT-PACKAGE-NAME.
1462
1463 The way symbols are matched depends on the symbol designator's
1464 format. The cases are as follows:
1465 FOO - Symbols with matching prefix and accessible in the buffer package.
1466 PKG:FOO - Symbols with matching prefix and external in package PKG.
1467 PKG::FOO - Symbols with matching prefix and accessible in package PKG."
1468 (let ((completion-set (completion-set string default-package-name
1469 #'compound-prefix-match)))
1470 (list completion-set (longest-completion completion-set))))
1471
1472 (defslimefun simple-completions (string default-package-name)
1473 "Return a list of completions for a symbol designator STRING."
1474 (let ((completion-set (completion-set string default-package-name
1475 #'prefix-match-p)))
1476 (list completion-set (longest-common-prefix completion-set))))
1477
1478 (defun tokenize-symbol-designator (string)
1479 "Parse STRING as a symbol designator.
1480 Return three values:
1481 SYMBOL-NAME
1482 PACKAGE-NAME, or nil if the designator does not include an explicit package.
1483 INTERNAL-P, if the symbol is qualified with `::'."
1484 (declare (type simple-base-string string))
1485 (values (let ((pos (position #\: string :from-end t)))
1486 (if pos (subseq string (1+ pos)) string))
1487 (let ((pos (position #\: string)))
1488 (if pos (subseq string 0 pos) nil))
1489 (search "::" string)))
1490
1491 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
1492 "True if SYMBOL is external in PACKAGE.
1493 If PACKAGE is not specified, the home package of SYMBOL is used."
1494 (multiple-value-bind (_ status)
1495 (find-symbol (symbol-name symbol) (or package (symbol-package symbol)))
1496 (declare (ignore _))
1497 (eq status :external)))
1498
1499
1500 ;;;;; Subword-word matching
1501
1502 (defun compound-prefix-match (prefix target)
1503 "Return true if PREFIX is a compound-prefix of TARGET.
1504 Viewing each of PREFIX and TARGET as a series of substrings delimited
1505 by hyphens, if each substring of PREFIX is a prefix of the
1506 corresponding substring in TARGET then we call PREFIX a
1507 compound-prefix of TARGET.
1508
1509 Examples:
1510 \(compound-prefix-match \"foo\" \"foobar\") => t
1511 \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
1512 \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
1513 (declare (type simple-string prefix target))
1514 (loop for ch across prefix
1515 with tpos = 0
1516 always (and (< tpos (length target))
1517 (if (char= ch #\-)
1518 (setf tpos (position #\- target :start tpos))
1519 (char= ch (aref target tpos))))
1520 do (incf tpos)))
1521
1522 (defun prefix-match-p (prefix string)
1523 "Return true if PREFIX is a prefix of STRING."
1524 (eql (search prefix string) 0))
1525
1526 ;;;;; Extending the input string by completion
1527
1528 (defun longest-completion (completions)
1529 "Return the longest prefix for all COMPLETIONS."
1530 (untokenize-completion
1531 (mapcar #'longest-common-prefix
1532 (transpose-lists (mapcar #'tokenize-completion completions)))))
1533
1534 (defun tokenize-completion (string)
1535 "Return all substrings of STRING delimited by #\-."
1536 (declare (type simple-base-string string))
1537 (loop with end
1538 for start = 0 then (1+ end)
1539 until (> start (length string))
1540 do (setq end (or (position #\- string :start start) (length string)))
1541 collect (subseq string start end)))
1542
1543 (defun untokenize-completion (tokens)
1544 (format nil "~{~A~^-~}" tokens))
1545
1546 (defun longest-common-prefix (strings)
1547 "Return the longest string that is a common prefix of STRINGS."
1548 (if (null strings)
1549 ""
1550 (flet ((common-prefix (s1 s2)
1551 (let ((diff-pos (mismatch s1 s2)))
1552 (if diff-pos (subseq s1 0 diff-pos) s1))))
1553 (reduce #'common-prefix strings))))
1554
1555 (defun transpose-lists (lists)
1556 "Turn a list-of-lists on its side.
1557 If the rows are of unequal length, truncate uniformly to the shortest.
1558
1559 For example:
1560 \(transpose-lists '((ONE TWO THREE) (1 2)))
1561 => ((ONE 1) (TWO 2))"
1562 ;; A cute function from PAIP p.574
1563 (if lists (apply #'mapcar #'list lists)))
1564
1565
1566 ;;;;; Completion Tests
1567
1568 (defpackage :swank-completion-test
1569 (:use))
1570
1571 (let ((*readtable* (copy-readtable *readtable*))
1572 (p (find-package :swank-completion-test)))
1573 (intern "foo" p)
1574 (intern "Foo" p)
1575 (intern "FOO" p)
1576 (setf (readtable-case *readtable*) :invert)
1577 (assert (string= (case-convert-input "f") "F"))
1578 (assert (string= (case-convert-input "foo") "FOO"))
1579 (assert (string= (case-convert-input "Foo") "Foo"))
1580 (assert (string= (case-convert-input "FOO") "foo"))
1581 (assert (string= (case-convert-input "find-if") "FIND-IF"))
1582 (flet ((names (prefix)
1583 (sort (mapcar #'symbol-name
1584 (find-matching-symbols prefix p nil #'prefix-match-p))
1585 #'string<)))
1586 (assert (equal '("FOO") (names "f")))
1587 (assert (equal '("Foo" "foo") (names "F")))
1588 (assert (equal '("Foo") (names "Fo")))
1589 (assert (equal '("foo") (names "FO")))))
1590
1591
1592 ;;;; Indentation
1593 ;;;
1594 ;;; This code decides how macros should be indented (based on their
1595 ;;; arglists) and tells Emacs. A per-connection cache is used to avoid
1596 ;;; sending redundant information to Emacs -- we just say what's
1597 ;;; changed since last time.
1598 ;;;
1599 ;;; The strategy is to scan all symbols, pick out the macros, and look
1600 ;;; for &body-arguments.
1601
1602 (defvar *configure-emacs-indentation* t
1603 "When true, automatically send indentation information to Emacs
1604 after each command.")
1605
1606 (defslimefun update-indentation-information ()
1607 (perform-indentation-update *emacs-connection* t))
1608
1609 ;; Called automatically at the end of each request.
1610 (defun update-connection-indentation (connection)
1611 "Send any indentation updates to Emacs via CONNECTION."
1612 (when *configure-emacs-indentation*
1613 (perform-indentation-update connection
1614 (need-full-indentation-update-p connection))))
1615
1616 (defun perform-indentation-update (connection force)
1617 (let* ((cache (connection.indentation-cache connection))
1618 (delta (update-indentation/delta-for-emacs cache force)))
1619 (when force
1620 (setf (connection.indentation-cache-packages connection)
1621 (list-all-packages)))
1622 (when delta
1623 (send-to-emacs (list :indentation-update delta)))))
1624
1625 (defun need-full-indentation-update-p (connection)
1626 "Return true if the whole indentation cache should be updated.
1627 This is a heuristic to avoid scanning all symbols all the time:
1628 instead, we only do a full scan if the set of packages has changed."
1629 (set-difference (list-all-packages)
1630 (connection.indentation-cache-packages connection)))
1631
1632 (defun update-indentation/delta-for-emacs (cache &optional force)
1633 "Update the cache and return the changes in a (SYMBOL . INDENT) list.
1634 If FORCE is true then check all symbols, otherwise only check symbols
1635 belonging to the buffer package."
1636 (let ((alist '()))
1637 (flet ((consider (symbol)
1638 (let ((indent (symbol-indentation symbol)))
1639 (when indent
1640 (unless (equal (gethash symbol cache) indent)
1641 (setf (gethash symbol cache) indent)
1642 (push (cons (string-downcase (symbol-name symbol))
1643 indent)
1644 alist))))))
1645 (if force
1646 (do-all-symbols (symbol)
1647 (consider symbol))
1648 (do-symbols (symbol *buffer-package*)
1649 (when (eq (symbol-package symbol) *buffer-package*)
1650 (consider symbol)))))
1651 alist))
1652
1653 (defun symbol-indentation (symbol)
1654 "Return a form describing the indentation of SYMBOL.
1655 The form is to be used as the `common-lisp-indent-function' property
1656 in Emacs."
1657 (if (macro-function symbol)
1658 (let ((arglist (arglist symbol)))
1659 (etypecase arglist
1660 ((member :not-available)
1661 nil)
1662 (list
1663 (macro-indentation arglist))))
1664 nil))
1665
1666 (defun macro-indentation (arglist)
1667 (if (well-formed-list-p arglist)
1668 (position '&body (remove '&whole arglist))
1669 nil))
1670
1671 (defun well-formed-list-p (list)
1672 "Is LIST a proper list terminated by NIL?"
1673 (typecase list
1674 (null t)
1675 (cons (well-formed-list-p (cdr list)))
1676 (t nil)))
1677
1678 (defun print-indentation-lossage (&optional (stream *standard-output*))
1679 "Return the list of symbols whose indentation styles collide incompatibly.
1680 Collisions are caused because package information is ignored."
1681 (let ((table (make-hash-table :test 'equal)))
1682 (flet ((name (s) (string-downcase (symbol-name s))))
1683 (do-all-symbols (s)
1684 (setf (gethash (name s) table)
1685 (cons s (symbol-indentation s))))
1686 (let ((collisions '()))
1687 (do-all-symbols (s)
1688 (let* ((entry (gethash (name s) table))
1689 (owner (car entry))
1690 (indent (cdr entry)))
1691 (unless (or (eq s owner)
1692 (equal (symbol-indentation s) indent)
1693 (and (not (fboundp s))
1694 (null (macro-function s))))
1695 (pushnew owner collisions)
1696 (pushnew s collisions))))
1697 (if (null collisions)
1698 (format stream "~&No worries!~%")
1699 (format stream "~&Symbols with collisions:~%~{ ~S~%~}"
1700 collisions))))))
1701
1702
1703 ;;;; Documentation
1704
1705 (defslimefun apropos-list-for-emacs (name &optional external-only
1706 case-sensitive package)
1707 "Make an apropos search for Emacs.
1708 The result is a list of property lists."
1709 (let ((package (if package
1710 (or (find-package package)
1711 (error "No such package: ~S" package)))))
1712 (mapcan (listify #'briefly-describe-symbol-for-emacs)
1713 (sort (remove-duplicates
1714 (apropos-symbols name external-only case-sensitive package))
1715 #'present-symbol-before-p))))
1716
1717 (defun briefly-describe-symbol-for-emacs (symbol)
1718 "Return a property list describing SYMBOL.
1719 Like `describe-symbol-for-emacs' but with at most one line per item."
1720 (flet ((first-line (string)
1721 (declare (type simple-base-string string))
1722 (let ((pos (position #\newline string)))
1723 (if (null pos) string (subseq string 0 pos)))))
1724 (let ((desc (map-if #'stringp #'first-line
1725 (describe-symbol-for-emacs symbol))))
1726 (if desc
1727 (list* :designator (to-string symbol) desc)))))
1728
1729 (defun map-if (test fn &rest lists)
1730 "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
1731 Example:
1732 \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
1733 (declare (type function test fn))
1734 (apply #'mapcar
1735 (lambda (x) (if (funcall test x) (funcall fn x) x))
1736 lists))
1737
1738 (defun listify (f)
1739 "Return a function like F, but which returns any non-null value
1740 wrapped in a list."
1741 (declare (type function f))
1742 (lambda (x)
1743 (let ((y (funcall f x)))
1744 (and y (list y)))))
1745
1746 (defun present-symbol-before-p (a b)
1747 "Return true if A belongs before B in a printed summary of symbols.
1748 Sorted alphabetically by package name and then symbol name, except
1749 that symbols accessible in the current package go first."
1750 (flet ((accessible (s)
1751 (find-symbol (symbol-name s) *buffer-package*)))
1752 (cond ((and (accessible a) (accessible b))
1753 (string< (symbol-name a) (symbol-name b)))
1754 ((accessible a) t)
1755 ((accessible b) nil)
1756 (t
1757 (string< (package-name (symbol-package a))
1758 (package-name (symbol-package b)))))))
1759
1760 (let ((regex-hash (make-hash-table :test #'equal)))
1761 (defun compiled-regex (regex-string)
1762 (or (gethash regex-string regex-hash)
1763 (setf (gethash regex-string regex-hash)
1764 (compile nil (nregex:regex-compile regex-string))))))
1765
1766 (defun apropos-matcher (string case-sensitive package external-only)
1767 (let* ((case-modifier (if case-sensitive #'string #'string-upcase))
1768 (regex (compiled-regex (funcall case-modifier string))))
1769 (lambda (symbol)
1770 (and (not (keywordp symbol))
1771 (if package (eq (symbol-package symbol) package) t)
1772 (if external-only (symbol-external-p symbol) t)
1773 (funcall regex (funcall case-modifier symbol))))))
1774
1775 (defun apropos-symbols (string external-only case-sensitive package)
1776 (let ((result '())
1777 (matchp (apropos-matcher string case-sensitive package external-only)))
1778 (with-package-iterator (next (or package (list-all-packages))
1779 :external :internal)
1780 (loop
1781 (multiple-value-bind (morep symbol) (next)
1782 (cond ((not morep)
1783 (return))
1784 ((funcall matchp symbol)
1785 (push symbol result))))))
1786 result))
1787
1788 (defun describe-to-string (object)
1789 (with-output-to-string (*standard-output*)
1790 (describe object)))
1791
1792 (defslimefun describe-symbol (symbol-name)
1793 (describe-to-string (find-symbol-or-lose symbol-name)))
1794
1795 (defslimefun describe-function (symbol-name)
1796 (let ((symbol (find-symbol-or-lose symbol-name)))
1797 (describe-to-string (or (macro-function symbol)
1798 (symbol-function symbol)))))
1799
1800 (defslimefun describe-definition-for-emacs (name kind)
1801 (with-output-to-string (*standard-output*)
1802 (describe-definition (find-symbol-or-lose name) kind)))
1803
1804 (defslimefun documentation-symbol (symbol-name &optional default)
1805 (let ((*package* *buffer-package*))
1806 (let ((vdoc (documentation (symbol-from-string symbol-name) 'variable))
1807 (fdoc (documentation (symbol-from-string symbol-name) 'function)))
1808 (or (and (or vdoc fdoc)
1809 (concatenate 'string
1810 fdoc
1811 (and vdoc fdoc '(#\Newline #\Newline))
1812 vdoc))
1813 default))))
1814
1815
1816 ;;;;
1817
1818 (defslimefun list-all-package-names (&optional include-nicknames)
1819 "Return a list of all package names.
1820 Include the nicknames if INCLUDE-NICKNAMES is true."
1821 (loop for package in (list-all-packages)
1822 collect (package-name package)
1823 when include-nicknames append (package-nicknames package)))
1824
1825 ;; Use eval for the sake of portability...
1826 (defun tracedp (fspec)
1827 (member fspec (eval '(trace))))
1828
1829 (defslimefun toggle-trace-fdefinition (fname-string)
1830 (let ((fname (from-string fname-string)))
1831 (cond ((tracedp fname)
1832 (eval `(untrace ,fname))
1833 (format nil "~S is now untraced." fname))
1834 (t
1835 (eval `(trace ,fname))
1836 (format nil "~S is now traced." fname)))))
1837
1838 (defslimefun untrace-all ()
1839 (untrace))
1840
1841 (defslimefun undefine-function (fname-string)
1842 (let ((fname (from-string fname-string)))
1843 (format nil "~S" (fmakunbound fname))))
1844
1845 (defslimefun load-file (filename)
1846 (to-string (load filename)))
1847
1848 (defun requires-compile-p (pathname)
1849 (let ((compile-file-truename (probe-file (compile-file-pathname pathname))))
1850 (or (not compile-file-truename)
1851 (< (file-write-date compile-file-truename)
1852 (file-write-date pathname)))))
1853
1854
1855 ;;;; Profiling
1856
1857 (defun profiledp (fspec)
1858 (member fspec (profiled-functions)))
1859
1860 (defslimefun toggle-profile-fdefinition (fname-string)
1861 (let ((fname (from-string fname-string)))
1862 (cond ((profiledp fname)
1863 (unprofile fname)
1864 (format nil "~S is now unprofiled." fname))
1865 (t
1866 (profile fname)
1867 (format nil "~S is now profiled." fname)))))
1868
1869
1870 ;;;; Source Locations
1871
1872 (defslimefun find-definitions-for-emacs (name)
1873 "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
1874 DSPEC is a string and LOCATION a source location. NAME is a string."
1875 (multiple-value-bind (sexp error)
1876 (ignore-errors (values (from-string name)))
1877 (cond (error '())
1878 (t (loop for (dspec loc) in (find-definitions sexp)
1879 collect (list (to-string dspec) loc))))))
1880
1881 (defun alistify (list key test)
1882 "Partition the elements of LIST into an alist. KEY extracts the key
1883 from an element and TEST is used to compare keys."
1884 (declare (type function key))
1885 (let ((alist '()))
1886 (dolist (e list)
1887 (let* ((k (funcall key e))
1888 (probe (assoc k alist :test test)))
1889 (if probe
1890 (push e (cdr probe))
1891 (push (cons k (list e)) alist))))
1892 alist))
1893
1894 (defun location-position< (pos1 pos2)
1895 (cond ((and (position-p pos1) (position-p pos2))
1896 (< (position-pos pos1)
1897 (position-pos pos2)))
1898 (t nil)))
1899
1900 (defun partition (list test key)
1901 (declare (type function test key))
1902 (loop for e in list
1903 if (funcall test (funcall key e)) collect e into yes
1904 else collect e into no
1905 finally (return (values yes no))))
1906
1907 (defstruct (xref (:conc-name xref.)
1908 (:type list))
1909 dspec location)
1910
1911 (defun location-valid-p (location)
1912 (eq (car location) :location))
1913
1914 (defun xref-buffer (xref)
1915 (location-buffer (xref.location xref)))
1916
1917 (defun xref-position (xref)
1918 (location-buffer (xref.location xref)))
1919
1920 (defun group-xrefs (xrefs)
1921 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
1922 The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
1923 (multiple-value-bind (resolved errors)
1924 (partition xrefs #'location-valid-p #'xref.location)
1925 (let ((alist (alistify resolved #'xref-buffer #'equal)))
1926 (append
1927 (loop for (buffer . list) in alist
1928 collect (cons (second buffer)
1929 (mapcar (lambda (xref)
1930 (cons (to-string (xref.dspec xref))
1931 (xref.location xref)))
1932 (sort list #'location-position<
1933 :key #'xref-position))))
1934 (if errors
1935 (list (cons "Unresolved"
1936 (mapcar (lambda (xref)
1937 (cons (to-string (xref.dspec xref))
1938 (xref.location xref)))
1939 errors))))))))
1940
1941 (defslimefun xref (type symbol-name)
1942 (let ((symbol (find-symbol-or-lose symbol-name)))
1943 (group-xrefs
1944 (ecase type
1945 (:calls (who-calls symbol))
1946 (:references (who-references symbol))
1947 (:binds (who-binds symbol))
1948 (:sets (who-sets symbol))
1949 (:macroexpands (who-macroexpands symbol))
1950 (:specializes (who-specializes symbol))
1951 (:callers (list-callers symbol))
1952 (:callees (list-callees symbol))))))
1953
1954 ; (xref :calls "to-string")
1955
1956 ;;;; Inspecting
1957
1958 (defvar *inspectee*)
1959 (defvar *inspectee-parts*)
1960 (defvar *inspector-stack* '())
1961 (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1962 (declaim (type vector *inspector-history*))
1963 (defvar *inspect-length* 30)
1964
1965 (defun reset-inspector ()
1966 (setq *inspectee* nil)
1967 (setq *inspectee-parts* nil)
1968 (setq *inspector-stack* nil)
1969 (setf (fill-pointer *inspector-history*) 0))
1970
1971 (defslimefun init-inspector (string)
1972 (reset-inspector)
1973 (inspect-object (eval (from-string string))))
1974
1975 (defun print-part-to-string (value)
1976 (let ((*print-pretty* nil)
1977 (*print-circle* t))
1978 (let ((string (to-string value))
1979 (pos (position value *inspector-history*)))
1980 (if pos
1981 (format nil "#~D=~A" pos string)
1982 string))))
1983
1984 (defun inspect-object (object)
1985 (push (setq *inspectee* object) *inspector-stack*)
1986 (unless (find object *inspector-history*)
1987 (vector-push-extend object *inspector-history*))
1988 (multiple-value-bind (text parts) (inspected-parts object)
1989 (setq *inspectee-parts* parts)
1990 (list :text text
1991 :type (to-string (type-of object))
1992 :primitive-type (describe-primitive-type object)
1993 :parts (loop for (label . value) in parts
1994 collect (cons (princ-to-string label)
1995 (print-part-to-string value))))))
1996
1997 (defun nth-part (index)
1998 (cdr (nth index *inspectee-parts*)))
1999
2000 (defslimefun inspect-nth-part (index)
2001 (inspect-object (nth-part index)))
2002
2003 (defslimefun inspector-pop ()
2004 "Drop the inspector stack and inspect the second element. Return
2005 nil if there's no second element."
2006 (cond ((cdr *inspector-stack*)
2007 (pop *inspector-stack*)
2008 (inspect-object (pop *inspector-stack*)))
2009 (t nil)))
2010
2011 (defslimefun inspector-next ()
2012 "Inspect the next element in the *inspector-history*."
2013 (let ((position (position *inspectee* *inspector-history*)))
2014 (cond ((= (1+ position) (length *inspector-history*))
2015 nil)
2016 (t (inspect-object (aref *inspector-history* (1+ position)))))))
2017
2018 (defslimefun quit-inspector ()
2019 (reset-inspector)
2020 nil)
2021
2022 (defslimefun describe-inspectee ()
2023 "Describe the currently inspected object."
2024 (describe-to-string *inspectee*))
2025
2026 (defmethod inspected-parts ((object cons))
2027 (if (consp (cdr object))
2028 (inspected-parts-of-nontrivial-list object)
2029 (inspected-parts-of-simple-cons object)))
2030
2031 (defun inspected-parts-of-simple-cons (object)
2032 (values "The object is a CONS."
2033 (list (cons (string 'car) (car object))
2034 (cons (string 'cdr) (cdr object)))))
2035
2036 (defun inspected-parts-of-nontrivial-list (object)
2037 (let ((length 0)
2038 (in-list object)
2039 (reversed-elements nil))
2040 (flet ((done (description-format)
2041 (return-from inspected-parts-of-nontrivial-list
2042 (values (format nil description-format length)
2043 (nreverse reversed-elements)))))
2044 (loop
2045 (cond ((null in-list)
2046 (done "The object is a proper list of length ~S.~%"))
2047 ((>= length *inspect-length*)
2048 (push (cons (string 'rest) in-list) reversed-elements)
2049 (done "The object is a long list (more than ~S elements).~%"))
2050 ((consp in-list)
2051 (push (cons (format nil "~D" length) (pop in-list))
2052 reversed-elements)
2053 (incf length))
2054 (t
2055 (push (cons (string 'rest) in-list) reversed-elements)
2056 (done "The object is an improper list of length ~S.~%")))))))
2057
2058 (defmethod inspected-parts ((o hash-table))
2059 (values (format nil "~A~% is a ~A" o (class-of o))
2060 (list*
2061 (cons "Test" (hash-table-test o))
2062 (cons "Count" (hash-table-count o))
2063 (cons "Size" (hash-table-size o))
2064 (cons "Rehash-Threshold" (hash-table-rehash-threshold o))
2065 (cons "Rehash-Size" (hash-table-rehash-size o))
2066 (cons "---" :---)
2067 (let ((pairs '()))
2068 (maphash (lambda (key value)
2069 (push (cons (to-string key) value)
2070 pairs))
2071 o)
2072 pairs))))
2073
2074 (defslimefun inspect-in-frame (string index)
2075 (reset-inspector)
2076 (inspect-object (eval-in-frame (from-string string) index)))
2077
2078 (defslimefun inspect-current-condition ()
2079 (reset-inspector)
2080 (inspect-object *swank-debugger-condition*))
2081
2082
2083 ;;;; Thread listing
2084
2085 (defvar *thread-list* ()
2086 "List of threads displayed in Emacs. We don't care a about
2087 synchronization issues (yet). There can only be one thread listing at
2088 a time.")
2089
2090 (defslimefun list-threads ()
2091 "Return a list ((NAME DESCRIPTION) ...) of all threads."
2092 (setq *thread-list* (all-threads))
2093 (loop for thread in *thread-list*
2094 collect (list (thread-name thread)
2095 (thread-status thread))))
2096
2097 (defslimefun quit-thread-browser ()
2098 (setq *thread-list* nil))
2099
2100 (defun lookup-thread-by-id (id)
2101 (nth id *thread-list*))
2102
2103 (defslimefun debug-thread-by-id (thread-id)
2104 (let ((connection *emacs-connection*))
2105 (interrupt-thread (lookup-thread-by-id thread-id)
2106 (lambda ()
2107 (with-connection (connection)
2108 (simple-break))))))
2109
2110 (defslimefun start-swank-server-in-thread (id port-file-name)
2111 "Interrupt a thread by ID and make it start a swank server.
2112 The server port is written to PORT-FILE-NAME."
2113 (interrupt-thread (lookup-thread-by-id id)
2114 (lambda ()
2115 (start-server port-file-name nil))))
2116
2117 (defslimefun kill-thread-by-id (id)
2118 (kill-thread (lookup-thread-by-id id)))
2119
2120 ;;; Local Variables:
2121 ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
2122 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5