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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.174 - (hide annotations)
Mon Apr 26 18:38:39 2004 UTC (9 years, 11 months ago) by lgorrie
Branch: MAIN
Changes since 1.173: +7 -7 lines
Move definition of `with-io-redirection' above `with-connection' to
avoid a CLISP error. This is really weird.
1 heller 1.107 ;;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-;;;
2 dbarlow 1.27 ;;;
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 heller 1.26
10 heller 1.58 (defpackage :swank
11 heller 1.138 (:use :common-lisp :swank-backend)
12 lgorrie 1.152 (:export #:startup-multiprocessing
13 heller 1.138 #:start-server
14     #:create-swank-server
15     #:ed-in-emacs
16 lgorrie 1.157 #:print-indentation-lossage
17 lgorrie 1.152 ;; configurables
18     #:*sldb-pprint-frames*
19     #:*communication-style*
20     #:*log-events*
21     #:*use-dedicated-output-stream*
22 lgorrie 1.157 #:*configure-emacs-indentation*
23 heller 1.147 ;; re-exported from backend
24 heller 1.139 #:frame-source-location-for-emacs
25 wjenkner 1.146 #:restart-frame
26 heller 1.142 #:profiled-functions
27     #:profile-report
28     #:profile-reset
29     #:unprofile-all
30     #:profile-package
31 heller 1.150 #:set-default-directory
32 heller 1.170 #:quit-lisp
33 heller 1.138 ))
34 dbarlow 1.27
35 lukeg 1.1 (in-package :swank)
36 heller 1.31
37 heller 1.153 (declaim (optimize (debug 3)))
38 lgorrie 1.90
39 dbarlow 1.27 (defvar *swank-io-package*
40 heller 1.153 (let ((package (make-package :swank-io-package :use '())))
41 heller 1.26 (import '(nil t quote) package)
42 ellerh 1.7 package))
43    
44 heller 1.112 (defconstant +server-port+ 4005
45 dbarlow 1.28 "Default port for the Swank TCP server.")
46    
47     (defvar *swank-debug-p* t
48     "When true, print extra debugging information.")
49    
50 heller 1.59 (defvar *sldb-pprint-frames* nil
51     "*pretty-print* is bound to this value when sldb prints a frame.")
52    
53 heller 1.47 ;;; public interface. slimefuns are the things that emacs is allowed
54     ;;; to call
55    
56 lgorrie 1.157 (defmacro defslimefun (name arglist &body rest)
57 heller 1.47 `(progn
58 lgorrie 1.157 (defun ,name ,arglist ,@rest)
59     (export ',name :swank)))
60 heller 1.47
61 heller 1.113 (declaim (ftype (function () nil) missing-arg))
62     (defun missing-arg ()
63     (error "A required &KEY or &OPTIONAL argument was not supplied."))
64    
65 heller 1.138 (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 lgorrie 1.62
73 lgorrie 1.96 ;;;; 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 lgorrie 1.90
81     (defstruct (connection
82     (:conc-name connection.)
83 heller 1.112 ;; (:print-function %print-connection)
84     )
85 lgorrie 1.90 ;; Raw I/O stream of socket connection.
86 heller 1.113 (socket-io (missing-arg) :type stream :read-only t)
87 lgorrie 1.96 ;; 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 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
91 lgorrie 1.96 ;; redirected to Emacs.
92     (user-input nil :type (or stream null))
93     (user-output nil :type (or stream null))
94 heller 1.112 (user-io nil :type (or stream null))
95     ;;
96 heller 1.134 control-thread
97     reader-thread
98 lgorrie 1.173 ;; 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 heller 1.113 (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 lgorrie 1.157 ;; 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 heller 1.112 )
113 lgorrie 1.96
114 heller 1.115 #+(or)
115     (defun %print-connection (connection stream depth)
116     (declare (ignore depth))
117     (print-unreadable-object (connection stream :type t :identity t)))
118    
119 lgorrie 1.157 (defvar *connections* '()
120     "List of all active connections, with the most recent at the front.")
121    
122 heller 1.112 (defvar *emacs-connection* nil
123     "The connection to Emacs.
124 heller 1.115 All threads communicate through this interface with Emacs.")
125 lgorrie 1.96
126 heller 1.115 (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 lgorrie 1.90
130 lgorrie 1.157 (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 heller 1.112 (defslimefun state-stack ()
137 heller 1.115 "Return the value of *SWANK-STATE-STACK*."
138 heller 1.112 *swank-state-stack*)
139    
140 lgorrie 1.90 ;; 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 lgorrie 1.96 ;;;; Helper macros
147    
148 lgorrie 1.174 (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 heller 1.153 (defmacro with-connection ((connection) &body body)
156     "Execute BODY in the context of CONNECTION."
157     `(let ((*emacs-connection* ,connection))
158 lgorrie 1.157 (catch 'slime-toplevel
159     (with-io-redirection (*emacs-connection*)
160     (let ((*debugger-hook* #'swank-debugger-hook))
161     ,@body)))))
162 lgorrie 1.96
163 heller 1.103 (defmacro without-interrupts (&body body)
164     `(call-without-interrupts (lambda () ,@body)))
165 heller 1.112
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 heller 1.103
193 lgorrie 1.157 (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 lgorrie 1.90 ;;;; TCP Server
201 dbarlow 1.28
202 heller 1.112 (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 heller 1.94 (defvar *use-dedicated-output-stream* t)
207 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
208 heller 1.113 (defvar *log-events* nil)
209 heller 1.79
210 lgorrie 1.152 (defun start-server (port-file &optional (background *communication-style*)
211 heller 1.133 dont-close)
212 heller 1.101 (setup-server 0 (lambda (port) (announce-server-port port-file port))
213 heller 1.133 background dont-close))
214 heller 1.101
215 heller 1.112 (defun create-swank-server (&optional (port +server-port+)
216 lgorrie 1.152 (background *communication-style*)
217 heller 1.133 (announce-fn #'simple-announce-function)
218     dont-close)
219     (setup-server port announce-fn background dont-close))
220 heller 1.101
221 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
222    
223 heller 1.133 (defun setup-server (port announce-fn style dont-close)
224 heller 1.111 (declare (type function announce-fn))
225 heller 1.119 (let* ((socket (create-socket *loopback-interface* port))
226 heller 1.106 (port (local-port socket)))
227     (funcall announce-fn port)
228 heller 1.112 (cond ((eq style :spawn)
229 heller 1.133 (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 heller 1.106 port))
235 lgorrie 1.96
236 heller 1.133 (defun serve-connection (socket style dont-close)
237 heller 1.106 (let ((client (accept-connection socket)))
238 heller 1.133 (unless dont-close
239     (close-socket socket))
240 heller 1.112 (let ((connection (create-connection client style)))
241     (init-emacs-connection connection)
242 lgorrie 1.157 (push connection *connections*)
243 heller 1.112 (serve-requests connection))))
244    
245     (defun serve-requests (connection)
246 heller 1.115 "Read and process all requests on connections."
247 heller 1.112 (funcall (connection.serve-requests connection) connection))
248    
249     (defun init-emacs-connection (connection)
250 heller 1.134 (declare (ignore connection))
251 lgorrie 1.96 (emacs-connected))
252    
253 heller 1.94 (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 lgorrie 1.90
261 heller 1.115 (defun simple-announce-function (port)
262     (when *swank-debug-p*
263     (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
264    
265 heller 1.153 (defun open-streams (connection)
266 heller 1.115 "Return the 4 streams for IO redirection:
267     DEDICATED-OUTPUT INPUT OUTPUT IO"
268 heller 1.97 (multiple-value-bind (output-fn dedicated-output)
269 heller 1.153 (make-output-function connection)
270 lgorrie 1.157 (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 lgorrie 1.96 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
276 heller 1.101 (let ((out (or dedicated-output out)))
277     (let ((io (make-two-way-stream in out)))
278 heller 1.112 (values dedicated-output in out io)))))))
279 lgorrie 1.90
280 heller 1.153 (defun make-output-function (connection)
281 lgorrie 1.96 "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 lgorrie 1.90 (if *use-dedicated-output-stream*
286 heller 1.153 (let ((stream (open-dedicated-output-stream
287     (connection.socket-io connection))))
288 lgorrie 1.96 (values (lambda (string)
289 heller 1.97 (write-string string stream)
290 lgorrie 1.96 (force-output stream))
291     stream))
292 heller 1.153 (values (lambda (string)
293     (with-connection (connection)
294 lgorrie 1.157 (with-simple-restart
295     (abort "Abort sending output to Emacs.")
296     (send-to-emacs `(:read-output ,string)))))
297 lgorrie 1.96 nil)))
298 heller 1.97
299 lgorrie 1.90 (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 heller 1.119 (let* ((socket (create-socket *loopback-interface* 0))
305 heller 1.94 (port (local-port socket)))
306 heller 1.112 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
307 heller 1.94 (accept-connection socket)))
308 lgorrie 1.90
309 heller 1.134 (defun handle-request (connection)
310 heller 1.115 "Read and process one request. The processing is done in the extend
311     of the toplevel restart."
312 heller 1.112 (assert (null *swank-state-stack*))
313     (let ((*swank-state-stack* '(:handle-request)))
314 heller 1.134 (with-connection (connection)
315 lgorrie 1.157 (with-simple-restart (abort "Abort handling SLIME request.")
316     (read-from-emacs)))))
317 heller 1.97
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 heller 1.100 (let* ((here (or *compile-file-truename* *load-truename*))
323     (changelog (make-pathname
324     :name "ChangeLog"
325 lgorrie 1.151 :device (pathname-device here)
326 heller 1.100 :directory (pathname-directory here)
327     :host (pathname-host here)))
328 heller 1.97 (date (with-open-file (file changelog :direction :input)
329     (string (read file)))))
330     `(quote ,date))))
331     (date)))
332 heller 1.77
333 heller 1.112 (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 heller 1.113 (let ((cleanup (connection.cleanup c)))
340     (when cleanup
341     (funcall cleanup c)))
342 heller 1.112 (close (connection.socket-io c))
343     (when (connection.dedicated-output c)
344 lgorrie 1.157 (close (connection.dedicated-output c)))
345     (setf *connections* (remove c *connections*)))
346 heller 1.112
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 heller 1.134 (defun read-loop (control-thread input-stream connection)
352     (with-reader-error-handler (connection)
353 heller 1.112 (loop (send control-thread (decode-message input-stream)))))
354    
355     (defvar *active-threads* '())
356     (defvar *thread-counter* 0)
357    
358 heller 1.135 (defun remove-dead-threads ()
359 heller 1.168 (setq *active-threads*
360 heller 1.135 (remove-if-not #'thread-alive-p *active-threads*)))
361    
362 heller 1.112 (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 heller 1.113 (declare (type function key test))
372 heller 1.112 (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 heller 1.135 (defvar *lookup-counter* nil
388     "A simple counter used to remove dead threads from *active-threads*.")
389    
390 heller 1.112 (defun lookup-thread (thread)
391 heller 1.135 (when (zerop (decf *lookup-counter*))
392     (setf *lookup-counter* 50)
393     (remove-dead-threads))
394 heller 1.112 (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 heller 1.134 (defun dispatch-loop (socket-io connection)
405     (let ((*emacs-connection* connection)
406     (*active-threads* '())
407 heller 1.135 (*thread-counter* 0)
408     (*lookup-counter* 50))
409 lgorrie 1.173 (loop (with-simple-restart (abort "Restart dispatch loop.")
410 heller 1.134 (loop (dispatch-event (receive) socket-io))))))
411 heller 1.112
412     (defun simple-break ()
413     (with-simple-restart (continue "Continue from interrupt.")
414 heller 1.114 (let ((*debugger-hook* #'swank-debugger-hook))
415     (invoke-debugger
416     (make-condition 'simple-error
417     :format-control "Interrupt from Emacs")))))
418 heller 1.112
419     (defun interrupt-worker-thread (thread)
420     (let ((thread (etypecase thread
421     ((member t) (cdr (car *active-threads*)))
422 heller 1.129 (fixnum (lookup-thread-id thread)))))
423     (interrupt-thread thread #'simple-break)))
424 heller 1.112
425     (defun dispatch-event (event socket-io)
426     (log-event "DISPATCHING: ~S~%" event)
427     (destructure-case event
428 heller 1.149 ((:emacs-rex form package thread id)
429 heller 1.112 (let ((thread (etypecase thread
430 heller 1.134 ((member t)
431     (let ((c *emacs-connection*))
432     (spawn (lambda () (handle-request c))
433     :name "worker")))
434 heller 1.112 (fixnum (lookup-thread-id thread)))))
435 heller 1.149 (send thread `(eval-for-emacs ,form ,package ,id))
436 heller 1.112 (add-thread thread)))
437     ((:emacs-interrupt thread)
438     (interrupt-worker-thread thread))
439 heller 1.115 (((:debug :debug-condition :debug-activate) thread &rest args)
440 heller 1.117 (encode-message `(,(car event) ,(add-thread thread) . ,args) socket-io))
441 heller 1.112 ((: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 lgorrie 1.159 (((:read-output :new-package :new-features :ed :%apply :indentation-update)
453 heller 1.112 &rest _)
454     (declare (ignore _))
455     (encode-message event socket-io))))
456    
457 heller 1.153 (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 lgorrie 1.173 (setf (connection.repl-thread connection)
469     (spawn (lambda () (repl-loop connection))))
470 heller 1.153 connection))))
471    
472 lgorrie 1.173 (defun repl-loop (connection)
473     (with-connection (connection)
474     (loop do (funcall (receive)))))
475    
476 heller 1.153 (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 heller 1.112 (defun create-connection (socket-io style)
485 heller 1.153 (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 heller 1.112
510 heller 1.122 (defun process-available-input (stream fn)
511     (loop while (and (open-stream-p stream)
512     (listen stream))
513     do (funcall fn)))
514    
515 heller 1.123 ;;;;;; Signal driven IO
516    
517 heller 1.112 (defun install-sigio-handler (connection)
518     (let ((client (connection.socket-io connection)))
519 heller 1.134 (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 heller 1.123 (add-sigio-handler client #'handler)
527 heller 1.122 (handler))))
528 heller 1.112
529 heller 1.123 (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 heller 1.134 (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 heller 1.123 (encode-message '(:use-sigint-for-interrupt) client)
544     (setq *debugger-hook*
545     (lambda (c h)
546 heller 1.134 (with-reader-error-handler (connection)
547 heller 1.123 (block debugger
548 heller 1.134 (with-connection (connection)
549 heller 1.123 (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 heller 1.112
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 heller 1.134 (loop (handle-request connection)))))
565 heller 1.112
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 heller 1.149 ((:emacs-rex form package thread id)
571 heller 1.113 (declare (ignore thread))
572 heller 1.149 `(eval-for-emacs ,form ,package ,id))
573 heller 1.112 ((:emacs-interrupt thread)
574 heller 1.113 (declare (ignore thread))
575 heller 1.112 '(simple-break))
576     ((:emacs-return-string thread tag string)
577 heller 1.113 (declare (ignore thread))
578 heller 1.112 `(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 heller 1.115 (((:debug-activate :debug :debug-return :read-string :read-aborted)
585     thread &rest args)
586 heller 1.112 (declare (ignore thread))
587     (send `(,(car event) 0 ,@args)))
588     ((:return thread &rest args)
589     (declare (ignore thread))
590     (send `(:return ,@args)))
591 lgorrie 1.157 (((:read-output :new-package :new-features :debug-condition
592     :indentation-update :ed :%apply)
593 heller 1.112 &rest _)
594     (declare (ignore _))
595     (send event)))))
596    
597 lgorrie 1.80
598 lgorrie 1.62 ;;;; 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 dbarlow 1.28
605 lgorrie 1.90 (defun call-with-redirected-io (connection function)
606     "Call FUNCTION with I/O streams redirected via CONNECTION."
607 heller 1.111 (declare (type function function))
608 lgorrie 1.90 (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 heller 1.155 (defvar *log-io* *terminal-io*)
621    
622 heller 1.87 (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 heller 1.155 (apply #'format *log-io* format-string args)))
627 heller 1.87
628 heller 1.112 (defun read-from-emacs ()
629 dbarlow 1.28 "Read and process a request from Emacs."
630 heller 1.112 (apply #'funcall (funcall (connection.read *emacs-connection*))))
631    
632     (defun read-from-control-thread ()
633     (receive))
634 heller 1.46
635 heller 1.112 (defun decode-message (stream)
636 lgorrie 1.90 "Read an S-expression from STREAM using the SLIME protocol.
637     If a protocol error occurs then a SLIME-READ-ERROR is signalled."
638 heller 1.112 (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 dbarlow 1.28
654     (defun read-form (string)
655     (with-standard-io-syntax
656     (let ((*package* *swank-io-package*))
657     (read-from-string string))))
658    
659 lgorrie 1.50 (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 lgorrie 1.157 (send-to-emacs (list :new-features (mapcar #'symbol-name *features*))))
667     (update-connection-indentation *emacs-connection*))
668 lgorrie 1.50
669 heller 1.112 (defun send-to-emacs (object)
670     "Send OBJECT to Emacs."
671     (funcall (connection.send *emacs-connection*) object))
672 dbarlow 1.28
673 lgorrie 1.104 (defun send-oob-to-emacs (object)
674 heller 1.112 (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 lgorrie 1.104
691 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
692 heller 1.31 (with-standard-io-syntax
693     (let ((*print-case* :downcase)
694 heller 1.38 (*print-readably* t)
695 heller 1.31 (*print-pretty* nil)
696     (*package* *swank-io-package*))
697     (prin1-to-string object))))
698 dbarlow 1.28
699 heller 1.112 (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 lgorrie 1.62
706 lgorrie 1.91 (defvar *read-input-catch-tag* 0)
707    
708 heller 1.112 (defun read-user-input-from-emacs ()
709 lgorrie 1.62 (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
710 heller 1.117 (force-output)
711 heller 1.112 (send-to-emacs `(:read-string ,(current-thread)
712     ,*read-input-catch-tag*))
713 lgorrie 1.90 (let ((ok nil))
714 lgorrie 1.62 (unwind-protect
715     (prog1 (catch *read-input-catch-tag*
716 heller 1.112 (loop (read-from-emacs)))
717 lgorrie 1.62 (setq ok t))
718     (unless ok
719 heller 1.112 (send-to-emacs `(:read-aborted ,(current-thread)
720     *read-input-catch-tag*)))))))
721 lgorrie 1.90
722 lgorrie 1.62 (defslimefun take-input (tag input)
723 heller 1.147 "Return the string INPUT to the continuation TAG."
724 lgorrie 1.62 (throw tag input))
725 heller 1.126
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 lgorrie 1.62
735    
736     ;;;; Reading and printing
737 dbarlow 1.28
738     (defvar *buffer-package*)
739     (setf (documentation '*buffer-package* 'symbol)
740     "Package corresponding to slime-buffer-package.
741    
742 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
743 dbarlow 1.28 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 lgorrie 1.60 (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 dbarlow 1.28 (defun to-string (string)
756     "Write string in the *BUFFER-PACKAGE*."
757     (let ((*package* *buffer-package*))
758     (prin1-to-string string)))
759    
760 heller 1.53 (defun guess-package-from-string (name &optional (default-package *package*))
761 dbarlow 1.28 (or (and name
762     (or (find-package name)
763 heller 1.153 (find-package (string-upcase name))
764     (find-package (substitute #\- #\! name))))
765 heller 1.53 default-package))
766 dbarlow 1.28
767 heller 1.72 (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 heller 1.149 (tokenize-symbol-designator (case-convert-input string))
774 heller 1.72 (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 heller 1.138 (cond ((and package-name (not internal-p)
780 heller 1.72 (not (eq access :external)))
781     (values nil nil))
782 heller 1.138 (access (values symbol access)))))))))
783 heller 1.103
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 heller 1.172 (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 heller 1.148 "Return the arglist for the first function, macro, or special-op in NAMES."
802 heller 1.172 (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 heller 1.135
818 heller 1.172 (defun arglist-to-string (arglist package)
819 heller 1.147 "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 heller 1.172 (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 heller 1.135
847     (defun test-print-arglist (list string)
848 heller 1.172 (string= (arglist-to-string list (find-package :swank)) string))
849 heller 1.135
850 heller 1.141 ;; Should work:
851     (assert (test-print-arglist '(function cons) "(function cons)"))
852     (assert (test-print-arglist '(quote cons) "(quote cons)"))
853 heller 1.144 (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
854 heller 1.141 ;; Expected failure:
855 heller 1.135 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
856 heller 1.72
857 heller 1.172 (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 lgorrie 1.62
869     ;;;; Debugger
870 heller 1.47
871 lgorrie 1.62 ;;; These variables are dynamically bound during debugging.
872 dbarlow 1.28
873 lgorrie 1.63 ;; The condition being debugged.
874     (defvar *swank-debugger-condition* nil)
875 dbarlow 1.28
876 lgorrie 1.62 (defvar *sldb-level* 0
877     "The current level of recursive debugging.")
878 heller 1.38
879 lgorrie 1.76 (defvar *sldb-initial-frames* 20
880     "The initial number of backtrace frames to send to Emacs.")
881    
882 heller 1.147 (defvar *sldb-restarts* nil
883     "The list of currenlty active restarts.")
884 heller 1.138
885 heller 1.38 (defun swank-debugger-hook (condition hook)
886 lgorrie 1.62 "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 heller 1.67 (declare (ignore hook))
891 lgorrie 1.157 (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 heller 1.38 (let ((*swank-debugger-condition* condition)
900 heller 1.138 (*sldb-restarts* (compute-restarts condition))
901 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
902     (symbol-value '*buffer-package*))
903 heller 1.112 *package*))
904     (*sldb-level* (1+ *sldb-level*))
905 heller 1.138 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))
906     (*print-readably* nil))
907 lgorrie 1.157 (force-user-output)
908     (call-with-debugging-environment
909     (lambda () (sldb-loop *sldb-level*)))))
910 lgorrie 1.80
911 lgorrie 1.62 (defun sldb-loop (level)
912 heller 1.119 (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 heller 1.117 (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 heller 1.119 (read-from-emacs))))))
923     (send-to-emacs `(:debug-return ,(current-thread) ,level))))
924 heller 1.117
925 heller 1.147 (defslimefun sldb-break-with-default-debugger ()
926     "Invoke the default debugger by returning from our debugger-loop."
927 heller 1.117 (throw 'sldb-enter-default-debugger nil))
928 lgorrie 1.62
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 heller 1.115 (send-to-emacs `(:debug-condition ,(current-thread)
935     ,(princ-to-string real-condition))))
936 lgorrie 1.62 (throw 'sldb-loop-catcher nil))
937    
938 heller 1.86 (defun safe-condition-message (condition)
939     "Safely print condition to a string, handling any errors during
940     printing."
941 heller 1.147 (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 heller 1.86
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 heller 1.138 (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 heller 1.86 (let* ((label (format nil " ~D: " n))
964     (string (with-output-to-string (stream)
965 heller 1.116 (let ((*print-pretty* *sldb-pprint-frames*)
966     (*print-circle* t))
967 heller 1.138 (princ label stream)
968     (print-frame frame stream)))))
969 heller 1.86 (subseq string (length label))))
970    
971 heller 1.138 (defslimefun backtrace (start end)
972 heller 1.147 "Return a list ((I FRAME) ...) of frames from START to END.
973     I is an integer describing and FRAME a string."
974 heller 1.138 (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 lgorrie 1.62 (defslimefun sldb-continue ()
1018 heller 1.79 (continue))
1019 lgorrie 1.64
1020 heller 1.142 (defslimefun throw-to-toplevel ()
1021     (throw 'slime-toplevel nil))
1022    
1023 lgorrie 1.84 (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 lgorrie 1.64 (defslimefun eval-string-in-frame (string index)
1031 lgorrie 1.65 (to-string (eval-in-frame (from-string string) index)))
1032 lgorrie 1.62
1033 heller 1.138 (defslimefun pprint-eval-string-in-frame (string index)
1034     (swank-pprint
1035     (multiple-value-list
1036 heller 1.156 (eval-in-frame (from-string string) index))))
1037 heller 1.138
1038 heller 1.147 (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 heller 1.137 (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 heller 1.138 (list :name (to-string name) :id id
1047 heller 1.137 :value (to-string value))))
1048 heller 1.147 (frame-locals index))))
1049 mbaringer 1.136
1050 heller 1.138 (defslimefun frame-catch-tags-for-emacs (frame-index)
1051 heller 1.147 (mapcar #'to-string (frame-catch-tags frame-index)))
1052 heller 1.139
1053     (defslimefun sldb-disassemble (index)
1054     (with-output-to-string (*standard-output*)
1055     (disassemble-frame index)))
1056 heller 1.138
1057 heller 1.147 (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 lgorrie 1.62
1062     ;;;; Evaluation
1063 heller 1.38
1064 heller 1.68 (defun eval-in-emacs (form)
1065 heller 1.124 "Execute FORM in Emacs."
1066 heller 1.68 (destructuring-bind (fn &rest args) form
1067 heller 1.112 (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))
1068 heller 1.68
1069 heller 1.149 (defun eval-for-emacs (form buffer-package id)
1070     "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
1071 heller 1.147 Return the result values as a list to strings to the continuation ID.
1072     Errors are trapped and invoke our debugger."
1073 heller 1.112 (let ((*debugger-hook* #'swank-debugger-hook))
1074 dbarlow 1.28 (let (ok result)
1075     (unwind-protect
1076 heller 1.149 (let ((*buffer-package* (guess-package-from-string buffer-package)))
1077 dbarlow 1.28 (assert (packagep *buffer-package*))
1078 heller 1.149 (setq result (eval form))
1079 dbarlow 1.28 (force-output)
1080 lgorrie 1.157 (sync-state-to-emacs)
1081 dbarlow 1.28 (setq ok t))
1082 lgorrie 1.90 (force-user-output)
1083 heller 1.112 (send-to-emacs `(:return ,(current-thread)
1084     ,(if ok `(:ok ,result) '(:abort))
1085     ,id))))))
1086 lgorrie 1.84
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 dbarlow 1.28
1095 heller 1.59 (defun format-values-for-echo-area (values)
1096 heller 1.150 (let ((*package* *buffer-package*))
1097     (cond (values (format nil "~{~S~^, ~}" values))
1098     (t "; No value"))))
1099 heller 1.59
1100 dbarlow 1.28 (defslimefun interactive-eval (string)
1101 heller 1.156 (let ((values (multiple-value-list (eval (from-string string)))))
1102 heller 1.149 (fresh-line)
1103 dbarlow 1.28 (force-output)
1104 heller 1.59 (format-values-for-echo-area values)))
1105 dbarlow 1.28
1106 lgorrie 1.50 (defun eval-region (string &optional package-update-p)
1107     "Evaluate STRING and return the result.
1108     If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
1109     change, then send Emacs an update."
1110 vsedach 1.92 (let ((*package* *buffer-package*)
1111     - values)
1112 heller 1.89 (unwind-protect
1113 vsedach 1.92 (with-input-from-string (stream string)
1114     (loop for form = (read stream nil stream)
1115     until (eq form stream)
1116     do (progn
1117     (setq - form)
1118     (setq values (multiple-value-list (eval form)))
1119     (force-output))
1120 heller 1.149 finally (progn
1121     (fresh-line)
1122     (force-output)
1123     (return (values values -)))))
1124 heller 1.89 (when (and package-update-p (not (eq *package* *buffer-package*)))
1125 vsedach 1.92 (send-to-emacs
1126     (list :new-package (shortest-package-nickname *package*)))))))
1127 lgorrie 1.81
1128     (defun shortest-package-nickname (package)
1129     "Return the shortest nickname (or canonical name) of PACKAGE."
1130     (loop for name in (cons (package-name package) (package-nicknames package))
1131     for shortest = name then (if (< (length name) (length shortest))
1132     name
1133     shortest)
1134     finally (return shortest)))
1135 heller 1.49
1136 heller 1.38 (defslimefun interactive-eval-region (string)
1137     (let ((*package* *buffer-package*))
1138 heller 1.59 (format-values-for-echo-area (eval-region string))))
1139 heller 1.38
1140     (defslimefun re-evaluate-defvar (form)
1141     (let ((*package* *buffer-package*))
1142     (let ((form (read-from-string form)))
1143     (destructuring-bind (dv name &optional value doc) form
1144     (declare (ignore value doc))
1145     (assert (eq dv 'defvar))
1146     (makunbound name)
1147     (prin1-to-string (eval form))))))
1148    
1149 mbaringer 1.118 (defvar *swank-pprint-circle* *print-circle*
1150 lgorrie 1.158 "*PRINT-CIRCLE* is bound to this value when pretty printing slime output.")
1151 mbaringer 1.118
1152 pseibel 1.165 (defvar *swank-pprint-case* *print-case*
1153     "*PRINT-CASE* is bound to this value when pretty printing slime output.")
1154    
1155     (defvar *swank-pprint-right-margin* *print-right-margin*
1156     "*PRINT-RIGHT-MARGIN* is bound to this value when pretty printing slime output.")
1157    
1158 mbaringer 1.118 (defvar *swank-pprint-escape* *print-escape*
1159 lgorrie 1.158 "*PRINT-ESCAPE* is bound to this value when pretty printing slime output.")
1160 mbaringer 1.118
1161     (defvar *swank-pprint-level* *print-level*
1162 lgorrie 1.158 "*PRINT-LEVEL* is bound to this value when pretty printing slime output.")
1163 mbaringer 1.118
1164     (defvar *swank-pprint-length* *print-length*
1165 lgorrie 1.158 "*PRINT-LENGTH* is bound to this value when pretty printing slime output.")
1166 mbaringer 1.118
1167 heller 1.59 (defun swank-pprint (list)
1168     "Bind some printer variables and pretty print each object in LIST."
1169 heller 1.57 (let ((*print-pretty* t)
1170 pseibel 1.165 (*print-case* *swank-pprint-case*)
1171     (*print-right-margin* *swank-pprint-right-margin*)
1172 mbaringer 1.118 (*print-circle* *swank-pprint-circle*)
1173     (*print-escape* *swank-pprint-escape*)
1174     (*print-level* *swank-pprint-level*)
1175 heller 1.127 (*print-length* *swank-pprint-length*)
1176     (*package* *buffer-package*))
1177 heller 1.59 (cond ((null list) "; No value")
1178     (t (with-output-to-string (*standard-output*)
1179     (dolist (o list)
1180     (pprint o)
1181     (terpri)))))))
1182 heller 1.57
1183 dbarlow 1.29 (defslimefun pprint-eval (string)
1184     (let ((*package* *buffer-package*))
1185 heller 1.59 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1186 dbarlow 1.28
1187 dbarlow 1.29 (defslimefun set-package (package)
1188 heller 1.109 "Set *package* to PACKAGE and return its name and shortest nickname."
1189     (let ((p (setq *package* (guess-package-from-string package))))
1190     (list (package-name p) (shortest-package-nickname p))))
1191 heller 1.49
1192     (defslimefun listener-eval (string)
1193 lgorrie 1.173 (if (connection.repl-thread *emacs-connection*)
1194     (repl-thread-eval string)
1195     (repl-eval string)))
1196    
1197     (defun repl-thread-eval (string)
1198     "Evaluate STRING using REPL-EVAL in the REPL thread."
1199     ;; XXX Perhaps we should somehow formalize the set of "important"
1200     ;; specials which are here being passed to the other thread? -luke (26/Apr/2004)
1201     (let ((self (current-thread))
1202     (connection *emacs-connection*)
1203     (package *package*)
1204     (buffer-package *buffer-package*))
1205     (send (connection.repl-thread connection)
1206     (lambda ()
1207     (with-connection (connection)
1208     (let ((*buffer-package* buffer-package)
1209     (*package* package))
1210     (restart-case (send self (repl-eval string))
1211     (abort ()
1212     :report "Abort REPL evaluation"
1213     (send self "; Aborted")))))))
1214     (receive)))
1215    
1216     (defun repl-eval (string)
1217 lgorrie 1.90 (clear-user-input)
1218 lgorrie 1.50 (multiple-value-bind (values last-form) (eval-region string t)
1219 heller 1.49 (setq +++ ++ ++ + + last-form
1220     *** ** ** * * (car values)
1221     /// // // / / values)
1222 heller 1.59 (cond ((null values) "; No value")
1223 lgorrie 1.60 (t
1224     (let ((*package* *buffer-package*))
1225     (format nil "~{~S~^~%~}" values))))))
1226 dbarlow 1.28
1227 lgorrie 1.104 (defslimefun ed-in-emacs (&optional what)
1228     "Edit WHAT in Emacs.
1229 heller 1.156
1230     WHAT can be:
1231     A filename (string),
1232     A list (FILENAME LINE [COLUMN]),
1233     A function name (symbol),
1234     nil."
1235 lgorrie 1.173 (let ((target
1236     (cond ((and (listp what) (pathnamep (first what)))
1237     (cons (canonicalize-filename (car what)) (cdr what)))
1238     ((pathnamep what)
1239     (canonicalize-filename what))
1240     (t what))))
1241     (send-oob-to-emacs `(:ed ,target))))
1242    
1243 lgorrie 1.62
1244 dbarlow 1.29 ;;;; Compilation Commands.
1245    
1246     (defvar *compiler-notes* '()
1247     "List of compiler notes for the last compilation unit.")
1248    
1249     (defun clear-compiler-notes ()
1250 lgorrie 1.61 (setf *compiler-notes* '()))
1251 dbarlow 1.29
1252     (defun canonicalize-filename (filename)
1253     (namestring (truename filename)))
1254    
1255 heller 1.31 (defslimefun compiler-notes-for-emacs ()
1256     "Return the list of compiler notes for the last compilation unit."
1257     (reverse *compiler-notes*))
1258    
1259 dbarlow 1.29 (defun measure-time-interval (fn)
1260     "Call FN and return the first return value and the elapsed time.
1261     The time is measured in microseconds."
1262 heller 1.111 (declare (type function fn))
1263 dbarlow 1.29 (let ((before (get-internal-real-time)))
1264     (values
1265     (funcall fn)
1266     (* (- (get-internal-real-time) before)
1267     (/ 1000000 internal-time-units-per-second)))))
1268    
1269 lgorrie 1.61 (defun record-note-for-condition (condition)
1270     "Record a note for a compiler-condition."
1271     (push (make-compiler-note condition) *compiler-notes*))
1272    
1273     (defun make-compiler-note (condition)
1274     "Make a compiler note data structure from a compiler-condition."
1275     (declare (type compiler-condition condition))
1276 heller 1.121 (list* :message (message condition)
1277     :severity (severity condition)
1278     :location (location condition)
1279     (let ((s (short-message condition)))
1280     (if s (list :short-message s)))))
1281 lgorrie 1.32
1282 dbarlow 1.78 (defun swank-compiler (function)
1283 lgorrie 1.61 (clear-compiler-notes)
1284 dbarlow 1.29 (multiple-value-bind (result usecs)
1285 lgorrie 1.61 (handler-bind ((compiler-condition #'record-note-for-condition))
1286 dbarlow 1.78 (measure-time-interval function))
1287 lgorrie 1.61 (list (to-string result)
1288     (format nil "~,2F" (/ usecs 1000000.0)))))
1289    
1290 heller 1.138 (defslimefun compile-file-for-emacs (filename load-p)
1291 dbarlow 1.78 "Compile FILENAME and, when LOAD-P, load the result.
1292     Record compiler notes signalled as `compiler-condition's."
1293 heller 1.138 (swank-compiler (lambda () (swank-compile-file filename load-p))))
1294 dbarlow 1.78
1295 heller 1.138 (defslimefun compile-string-for-emacs (string buffer position)
1296 lgorrie 1.62 "Compile STRING (exerpted from BUFFER at POSITION).
1297     Record compiler notes signalled as `compiler-condition's."
1298 dbarlow 1.78 (swank-compiler
1299     (lambda ()
1300 heller 1.138 (let ((*package* *buffer-package*))
1301     (swank-compile-string string :buffer buffer :position position)))))
1302 dbarlow 1.78
1303 lgorrie 1.167 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
1304 dbarlow 1.78 "Compile and load SYSTEM using ASDF.
1305     Record compiler notes signalled as `compiler-condition's."
1306 heller 1.171 (swank-compiler
1307     (lambda ()
1308     (apply #'operate-on-system system-name operation keywords))))
1309 dbarlow 1.78
1310 heller 1.171 (defun asdf-central-registry ()
1311     (when (find-package :asdf)
1312     (symbol-value (find-symbol (string :*central-registry*) :asdf))))
1313    
1314     (defslimefun list-all-systems-in-central-registry ()
1315     "Returns a list of all systems in ASDF's central registry."
1316     (loop for dir in (asdf-central-registry)
1317     for defaults = (eval dir)
1318     when defaults
1319     nconc (mapcar #'file-namestring
1320     (directory
1321     (make-pathname :defaults defaults
1322     :version :newest
1323     :type "asd"
1324     :case :local)))))
1325 lgorrie 1.62
1326 lgorrie 1.70 ;;;; Macroexpansion
1327 dbarlow 1.29
1328     (defun apply-macro-expander (expander string)
1329 heller 1.111 (declare (type function expander))
1330 mbaringer 1.118 (swank-pprint (list (funcall expander (from-string string)))))
1331 dbarlow 1.29
1332     (defslimefun swank-macroexpand-1 (string)
1333     (apply-macro-expander #'macroexpand-1 string))
1334    
1335     (defslimefun swank-macroexpand (string)
1336     (apply-macro-expander #'macroexpand string))
1337    
1338 lgorrie 1.61 (defslimefun swank-macroexpand-all (string)
1339     (apply-macro-expander #'macroexpand-all string))
1340    
1341 heller 1.155 (defslimefun disassemble-symbol (name)
1342 heller 1.138 (with-output-to-string (*standard-output*)
1343 heller 1.155 (disassemble (fdefinition (from-string name)))))
1344 heller 1.138
1345 lgorrie 1.62
1346 lgorrie 1.70 ;;;; Completion
1347 heller 1.38
1348 heller 1.149 (defun determine-case (string)
1349     "Return to booleans LOWER and UPPER indicating whether STRING
1350     contains lower or upper case characters."
1351     (values (some #'lower-case-p string)
1352     (some #'upper-case-p string)))
1353    
1354     (defun case-convert-input (string)
1355 heller 1.53 "Convert STRING according to the current readtable-case."
1356 heller 1.56 (check-type string string)
1357 heller 1.53 (ecase (readtable-case *readtable*)
1358     (:upcase (string-upcase string))
1359     (:downcase (string-downcase string))
1360     (:preserve string)
1361 heller 1.149 (:invert (multiple-value-bind (lower upper) (determine-case string)
1362     (cond ((and upper lower) string)
1363     (lower (string-upcase string))
1364     (upper (string-downcase string))
1365     (t string))))))
1366 heller 1.53
1367 heller 1.108 (defun carefully-find-package (name default-package-name)
1368     "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
1369     *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
1370 heller 1.150 (let ((string (cond ((equal name "") "KEYWORD")
1371     (t (or name default-package-name)))))
1372     (if string
1373     (guess-package-from-string string nil)
1374 heller 1.108 *buffer-package*)))
1375    
1376 heller 1.130 (defun parse-completion-arguments (string default-package-name)
1377     (multiple-value-bind (name package-name internal-p)
1378     (tokenize-symbol-designator string)
1379     (let ((package (carefully-find-package package-name default-package-name)))
1380     (values name package-name package internal-p))))
1381    
1382 heller 1.149 (defun format-completion-set (strings internal-p package-name)
1383     (mapcar (lambda (string)
1384     (cond (internal-p
1385     (format nil "~A::~A" package-name string))
1386     (package-name
1387     (format nil "~A:~A" package-name string))
1388 heller 1.130 (t
1389 heller 1.149 (format nil "~A" string))))
1390     (sort strings #'string<)))
1391 heller 1.130
1392 heller 1.149 (defun output-case-converter (input)
1393     "Return a function to case convert strings for output.
1394     INPUT is used to guess the preferred case."
1395     (ecase (readtable-case *readtable*)
1396     (:upcase (if (some #'lower-case-p input) #'string-downcase #'identity))
1397     (:invert (lambda (output)
1398     (multiple-value-bind (lower upper) (determine-case output)
1399     (cond ((and lower upper) output)
1400     (lower (string-upcase output))
1401     (upper (string-downcase output))
1402     (t output)))))
1403     (:downcase (if (some #'upper-case-p input) #'string-upcase #'identity))
1404     (:preserve #'identity)))
1405    
1406     (defun find-matching-symbols (string package external test)
1407     "Return a list of symbols in PACKAGE matching STRING.
1408     TEST is called with two strings. If EXTERNAL is true, only external
1409     symbols are returned."
1410     (let ((completions '())
1411     (converter (output-case-converter string)))
1412 heller 1.130 (flet ((symbol-matches-p (symbol)
1413 heller 1.149 (and (or (not external)
1414     (symbol-external-p symbol package))
1415     (funcall test string
1416     (funcall converter (symbol-name symbol))))))
1417     (do-symbols (symbol package)
1418 heller 1.130 (when (symbol-matches-p symbol)
1419     (push symbol completions))))
1420 heller 1.149 (remove-duplicates completions)))
1421 heller 1.130
1422 lgorrie 1.162 (defun find-matching-packages (name matcher)
1423     "Return a list of package names matching NAME."
1424     (let ((to-match (string-upcase name)))
1425 lgorrie 1.164 (remove-if-not (lambda (x) (funcall matcher to-match x))
1426     (mapcar (lambda (pkgname)
1427     (concatenate 'string pkgname ":"))
1428 lgorrie 1.163 (mapcar #'package-name (list-all-packages))))))
1429 lgorrie 1.162
1430 heller 1.130 (defun completion-set (string default-package-name matchp)
1431     (declare (type simple-base-string string))
1432     (multiple-value-bind (name package-name package internal-p)
1433     (parse-completion-arguments string default-package-name)
1434 heller 1.149 (let* ((symbols (and package
1435     (find-matching-symbols name
1436     package
1437     (and (not internal-p)
1438     package-name)
1439     matchp)))
1440 lgorrie 1.162 (packs (and (not package-name)
1441     (find-matching-packages name matchp)))
1442 heller 1.149 (converter (output-case-converter name))
1443 lgorrie 1.162 (strings
1444     (mapcar converter
1445     (nconc (mapcar #'symbol-name symbols) packs))))
1446 heller 1.149 (format-completion-set strings internal-p package-name))))
1447 heller 1.130
1448 heller 1.38 (defslimefun completions (string default-package-name)
1449     "Return a list of completions for a symbol designator STRING.
1450    
1451 lgorrie 1.70 The result is the list (COMPLETION-SET
1452     COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
1453     completions, and COMPLETED-PREFIX is the best (partial)
1454     completion of the input string.
1455    
1456     If STRING is package qualified the result list will also be
1457     qualified. If string is non-qualified the result strings are
1458     also not qualified and are considered relative to
1459 lgorrie 1.42 DEFAULT-PACKAGE-NAME.
1460    
1461     The way symbols are matched depends on the symbol designator's
1462     format. The cases are as follows:
1463     FOO - Symbols with matching prefix and accessible in the buffer package.
1464     PKG:FOO - Symbols with matching prefix and external in package PKG.
1465     PKG::FOO - Symbols with matching prefix and accessible in package PKG."
1466 heller 1.132 (let ((completion-set (completion-set string default-package-name
1467     #'compound-prefix-match)))
1468     (list completion-set (longest-completion completion-set))))
1469 heller 1.130
1470     (defslimefun simple-completions (string default-package-name)
1471     "Return a list of completions for a symbol designator STRING."
1472 heller 1.132 (let ((completion-set (completion-set string default-package-name
1473     #'prefix-match-p)))
1474     (list completion-set (longest-common-prefix completion-set))))
1475 heller 1.38
1476 heller 1.108 (defun tokenize-symbol-designator (string)
1477 lgorrie 1.41 "Parse STRING as a symbol designator.
1478     Return three values:
1479     SYMBOL-NAME
1480     PACKAGE-NAME, or nil if the designator does not include an explicit package.
1481     INTERNAL-P, if the symbol is qualified with `::'."
1482 heller 1.111 (declare (type simple-base-string string))
1483 lgorrie 1.41 (values (let ((pos (position #\: string :from-end t)))
1484     (if pos (subseq string (1+ pos)) string))
1485     (let ((pos (position #\: string)))
1486     (if pos (subseq string 0 pos) nil))
1487     (search "::" string)))
1488 heller 1.53
1489 lgorrie 1.42 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
1490     "True if SYMBOL is external in PACKAGE.
1491     If PACKAGE is not specified, the home package of SYMBOL is used."
1492 heller 1.38 (multiple-value-bind (_ status)
1493 lgorrie 1.42 (find-symbol (symbol-name symbol) (or package (symbol-package symbol)))
1494 heller 1.38 (declare (ignore _))
1495     (eq status :external)))
1496    
1497 lgorrie 1.69
1498 lgorrie 1.70 ;;;;; Subword-word matching
1499 lgorrie 1.66
1500 lgorrie 1.76 (defun compound-prefix-match (prefix target)
1501     "Return true if PREFIX is a compound-prefix of TARGET.
1502     Viewing each of PREFIX and TARGET as a series of substrings delimited
1503     by hyphens, if each substring of PREFIX is a prefix of the
1504     corresponding substring in TARGET then we call PREFIX a
1505     compound-prefix of TARGET.
1506    
1507 lgorrie 1.66 Examples:
1508 lgorrie 1.76 \(compound-prefix-match \"foo\" \"foobar\") => t
1509     \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
1510     \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
1511 heller 1.149 (declare (type simple-string prefix target))
1512 lgorrie 1.76 (loop for ch across prefix
1513     with tpos = 0
1514     always (and (< tpos (length target))
1515     (if (char= ch #\-)
1516     (setf tpos (position #\- target :start tpos))
1517 heller 1.149 (char= ch (aref target tpos))))
1518 lgorrie 1.76 do (incf tpos)))
1519 lgorrie 1.66
1520 heller 1.130 (defun prefix-match-p (prefix string)
1521     "Return true if PREFIX is a prefix of STRING."
1522 heller 1.149 (eql (search prefix string) 0))
1523 lgorrie 1.69
1524 lgorrie 1.70 ;;;;; Extending the input string by completion
1525 lgorrie 1.69
1526     (defun longest-completion (completions)
1527     "Return the longest prefix for all COMPLETIONS."
1528     (untokenize-completion
1529     (mapcar #'longest-common-prefix
1530 lgorrie 1.71 (transpose-lists (mapcar #'tokenize-completion completions)))))
1531 lgorrie 1.69
1532 lgorrie 1.71 (defun tokenize-completion (string)
1533 lgorrie 1.69 "Return all substrings of STRING delimited by #\-."
1534 heller 1.111 (declare (type simple-base-string string))
1535 heller 1.85 (loop with end
1536     for start = 0 then (1+ end)
1537 lgorrie 1.69 until (> start (length string))
1538 heller 1.85 do (setq end (or (position #\- string :start start) (length string)))
1539 lgorrie 1.69 collect (subseq string start end)))
1540    
1541     (defun untokenize-completion (tokens)
1542 heller 1.132 (format nil "~{~A~^-~}" tokens))
1543 lgorrie 1.69
1544     (defun longest-common-prefix (strings)
1545     "Return the longest string that is a common prefix of STRINGS."
1546     (if (null strings)
1547     ""
1548     (flet ((common-prefix (s1 s2)
1549     (let ((diff-pos (mismatch s1 s2)))
1550     (if diff-pos (subseq s1 0 diff-pos) s1))))
1551     (reduce #'common-prefix strings))))
1552    
1553 lgorrie 1.71 (defun transpose-lists (lists)
1554     "Turn a list-of-lists on its side.
1555     If the rows are of unequal length, truncate uniformly to the shortest.
1556    
1557     For example:
1558 heller 1.74 \(transpose-lists '((ONE TWO THREE) (1 2)))
1559     => ((ONE 1) (TWO 2))"
1560 lgorrie 1.69 ;; A cute function from PAIP p.574
1561 lgorrie 1.71 (if lists (apply #'mapcar #'list lists)))
1562 heller 1.38
1563 lgorrie 1.62
1564 heller 1.149 ;;;;; Completion Tests
1565    
1566     (defpackage :swank-completion-test
1567     (:use))
1568    
1569     (let ((*readtable* (copy-readtable *readtable*))
1570     (p (find-package :swank-completion-test)))
1571     (intern "foo" p)
1572     (intern "Foo" p)
1573     (intern "FOO" p)
1574     (setf (readtable-case *readtable*) :invert)
1575     (assert (string= (case-convert-input "f") "F"))
1576     (assert (string= (case-convert-input "foo") "FOO"))
1577     (assert (string= (case-convert-input "Foo") "Foo"))
1578     (assert (string= (case-convert-input "FOO") "foo"))
1579     (assert (string= (case-convert-input "find-if") "FIND-IF"))
1580     (flet ((names (prefix)
1581     (sort (mapcar #'symbol-name
1582     (find-matching-symbols prefix p nil #'prefix-match-p))
1583     #'string<)))
1584     (assert (equal '("FOO") (names "f")))
1585     (assert (equal '("Foo" "foo") (names "F")))
1586     (assert (equal '("Foo") (names "Fo")))
1587     (assert (equal '("foo") (names "FO")))))
1588    
1589 lgorrie 1.157
1590     ;;;; Indentation
1591     ;;;
1592     ;;; This code decides how macros should be indented (based on their
1593     ;;; arglists) and tells Emacs. A per-connection cache is used to avoid
1594     ;;; sending redundant information to Emacs -- we just say what's
1595     ;;; changed since last time.
1596     ;;;
1597     ;;; The strategy is to scan all symbols, pick out the macros, and look
1598     ;;; for &body-arguments.
1599    
1600     (defvar *configure-emacs-indentation* t
1601     "When true, automatically send indentation information to Emacs
1602     after each command.")
1603    
1604     (defslimefun update-indentation-information ()
1605     (perform-indentation-update *emacs-connection* t))
1606    
1607     ;; Called automatically at the end of each request.
1608     (defun update-connection-indentation (connection)
1609     "Send any indentation updates to Emacs via CONNECTION."
1610     (when *configure-emacs-indentation*
1611     (perform-indentation-update connection
1612     (need-full-indentation-update-p connection))))
1613    
1614     (defun perform-indentation-update (connection force)
1615     (let* ((cache (connection.indentation-cache connection))
1616     (delta (update-indentation/delta-for-emacs cache force)))
1617     (when force
1618     (setf (connection.indentation-cache-packages connection)
1619     (list-all-packages)))
1620     (when delta
1621     (send-to-emacs (list :indentation-update delta)))))
1622    
1623     (defun need-full-indentation-update-p (connection)
1624     "Return true if the whole indentation cache should be updated.
1625     This is a heuristic to avoid scanning all symbols all the time:
1626     instead, we only do a full scan if the set of packages has changed."
1627     (set-difference (list-all-packages)
1628     (connection.indentation-cache-packages connection)))
1629    
1630     (defun update-indentation/delta-for-emacs (cache &optional force)
1631     "Update the cache and return the changes in a (SYMBOL . INDENT) list.
1632     If FORCE is true then check all symbols, otherwise only check symbols
1633     belonging to the buffer package."
1634     (let ((alist '()))
1635     (flet ((consider (symbol)
1636     (let ((indent (symbol-indentation symbol)))
1637     (when indent
1638     (unless (equal (gethash symbol cache) indent)
1639     (setf (gethash symbol cache) indent)
1640     (push (cons (string-downcase (symbol-name symbol))
1641     indent)
1642     alist))))))
1643     (if force
1644     (do-all-symbols (symbol)
1645     (consider symbol))
1646     (do-symbols (symbol *buffer-package*)
1647     (when (eq (symbol-package symbol) *buffer-package*)
1648     (consider symbol)))))
1649     alist))
1650    
1651     (defun symbol-indentation (symbol)
1652     "Return a form describing the indentation of SYMBOL.
1653     The form is to be used as the `common-lisp-indent-function' property
1654     in Emacs."
1655     (if (macro-function symbol)
1656 heller 1.172 (let ((arglist (arglist symbol)))
1657     (etypecase arglist
1658     ((member :not-available)
1659     nil)
1660     (list
1661     (macro-indentation arglist))))
1662 lgorrie 1.157 nil))
1663    
1664     (defun macro-indentation (arglist)
1665 lgorrie 1.160 (if (well-formed-list-p arglist)
1666     (position '&body (remove '&whole arglist))
1667     nil))
1668    
1669     (defun well-formed-list-p (list)
1670     "Is LIST a proper list terminated by NIL?"
1671     (typecase list
1672     (null t)
1673     (cons (well-formed-list-p (cdr list)))
1674     (t nil)))
1675 lgorrie 1.157
1676     (defun print-indentation-lossage (&optional (stream *standard-output*))
1677     "Return the list of symbols whose indentation styles collide incompatibly.
1678     Collisions are caused because package information is ignored."
1679     (let ((table (make-hash-table :test 'equal)))
1680     (flet ((name (s) (string-downcase (symbol-name s))))
1681     (do-all-symbols (s)
1682     (setf (gethash (name s) table)
1683     (cons s (symbol-indentation s))))
1684     (let ((collisions '()))
1685     (do-all-symbols (s)
1686     (let* ((entry (gethash (name s) table))
1687     (owner (car entry))
1688     (indent (cdr entry)))
1689     (unless (or (eq s owner)
1690     (equal (symbol-indentation s) indent)
1691     (and (not (fboundp s))
1692     (null (macro-function s))))
1693     (pushnew owner collisions)
1694     (pushnew s collisions))))
1695     (if (null collisions)
1696     (format stream "~&No worries!~%")
1697     (format stream "~&Symbols with collisions:~%~{ ~S~%~}"
1698     collisions))))))
1699    
1700 heller 1.149
1701 lgorrie 1.62 ;;;; Documentation
1702 heller 1.38
1703 heller 1.169 (defslimefun apropos-list-for-emacs (name &optional external-only
1704     case-sensitive package)
1705 heller 1.38 "Make an apropos search for Emacs.
1706     The result is a list of property lists."
1707 heller 1.130 (let ((package (if package
1708 heller 1.153 (or (find-package package)
1709 heller 1.130 (error "No such package: ~S" package)))))
1710     (mapcan (listify #'briefly-describe-symbol-for-emacs)
1711 heller 1.153 (sort (remove-duplicates
1712 heller 1.169 (apropos-symbols name external-only case-sensitive package))
1713 heller 1.130 #'present-symbol-before-p))))
1714 lgorrie 1.61
1715     (defun briefly-describe-symbol-for-emacs (symbol)
1716     "Return a property list describing SYMBOL.
1717     Like `describe-symbol-for-emacs' but with at most one line per item."
1718     (flet ((first-line (string)
1719 heller 1.111 (declare (type simple-base-string string))
1720 lgorrie 1.61 (let ((pos (position #\newline string)))
1721     (if (null pos) string (subseq string 0 pos)))))
1722 heller 1.67 (let ((desc (map-if #'stringp #'first-line
1723     (describe-symbol-for-emacs symbol))))
1724     (if desc
1725     (list* :designator (to-string symbol) desc)))))
1726 lgorrie 1.61
1727     (defun map-if (test fn &rest lists)
1728     "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
1729     Example:
1730     \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
1731 heller 1.111 (declare (type function test fn))
1732 lgorrie 1.61 (apply #'mapcar
1733     (lambda (x) (if (funcall test x) (funcall fn x) x))
1734     lists))
1735 heller 1.38
1736     (defun listify (f)
1737     "Return a function like F, but which returns any non-null value
1738     wrapped in a list."
1739 heller 1.111 (declare (type function f))
1740 heller 1.38 (lambda (x)
1741     (let ((y (funcall f x)))
1742     (and y (list y)))))
1743    
1744     (defun present-symbol-before-p (a b)
1745     "Return true if A belongs before B in a printed summary of symbols.
1746     Sorted alphabetically by package name and then symbol name, except
1747     that symbols accessible in the current package go first."
1748     (flet ((accessible (s)
1749     (find-symbol (symbol-name s) *buffer-package*)))
1750 lgorrie 1.42 (cond ((and (accessible a) (accessible b))
1751     (string< (symbol-name a) (symbol-name b)))
1752     ((accessible a) t)
1753     ((accessible b) nil)
1754     (t
1755     (string< (package-name (symbol-package a))
1756     (package-name (symbol-package b)))))))
1757 heller 1.38
1758 heller 1.169 (let ((regex-hash (make-hash-table :test #'equal)))
1759     (defun compiled-regex (regex-string)
1760     (or (gethash regex-string regex-hash)
1761     (setf (gethash regex-string regex-hash)
1762     (compile nil (nregex:regex-compile regex-string))))))
1763    
1764     (defun apropos-matcher (string case-sensitive package external-only)
1765     (let* ((case-modifier (if case-sensitive #'string #'string-upcase))
1766     (regex (compiled-regex (funcall case-modifier string))))
1767     (lambda (symbol)
1768     (and (not (keywordp symbol))
1769     (if package (eq (symbol-package symbol) package) t)
1770     (if external-only (symbol-external-p symbol) t)
1771     (funcall regex (funcall case-modifier symbol))))))
1772    
1773     (defun apropos-symbols (string external-only case-sensitive package)
1774     (let ((result '())
1775     (matchp (apropos-matcher string case-sensitive package external-only)))
1776     (with-package-iterator (next (or package (list-all-packages))
1777     :external :internal)
1778     (loop
1779     (multiple-value-bind (morep symbol) (next)
1780     (cond ((not morep)
1781     (return))
1782     ((funcall matchp symbol)
1783     (push symbol result))))))
1784     result))
1785 lgorrie 1.62
1786 heller 1.138 (defun describe-to-string (object)
1787 lgorrie 1.62 (with-output-to-string (*standard-output*)
1788 heller 1.138 (describe object)))
1789 lgorrie 1.62
1790     (defslimefun describe-symbol (symbol-name)
1791 heller 1.138 (describe-to-string (find-symbol-or-lose symbol-name)))
1792 lgorrie 1.62
1793     (defslimefun describe-function (symbol-name)
1794 heller 1.138 (let ((symbol (find-symbol-or-lose symbol-name)))
1795     (describe-to-string (or (macro-function symbol)
1796     (symbol-function symbol)))))
1797    
1798 heller 1.147 (defslimefun describe-definition-for-emacs (name kind)
1799     (with-output-to-string (*standard-output*)
1800     (describe-definition (find-symbol-or-lose name) kind)))
1801 lgorrie 1.62
1802 heller 1.75 (defslimefun documentation-symbol (symbol-name &optional default)
1803 lgorrie 1.62 (let ((*package* *buffer-package*))
1804     (let ((vdoc (documentation (symbol-from-string symbol-name) 'variable))
1805     (fdoc (documentation (symbol-from-string symbol-name) 'function)))
1806 heller 1.75 (or (and (or vdoc fdoc)
1807     (concatenate 'string
1808     fdoc
1809     (and vdoc fdoc '(#\Newline #\Newline))
1810     vdoc))
1811     default))))
1812 lgorrie 1.62
1813    
1814     ;;;;
1815    
1816 heller 1.168 (defslimefun list-all-package-names (&optional include-nicknames)
1817     "Return a list of all package names.
1818     Include the nicknames if INCLUDE-NICKNAMES is true."
1819     (loop for package in (list-all-packages)
1820     collect (package-name package)
1821     when include-nicknames append (package-nicknames package)))
1822 heller 1.79
1823     ;; Use eval for the sake of portability...
1824     (defun tracedp (fspec)
1825     (member fspec (eval '(trace))))
1826    
1827     (defslimefun toggle-trace-fdefinition (fname-string)
1828     (let ((fname (from-string fname-string)))
1829     (cond ((tracedp fname)
1830     (eval `(untrace ,fname))
1831     (format nil "~S is now untraced." fname))
1832     (t
1833     (eval `(trace ,fname))
1834     (format nil "~S is now traced." fname)))))
1835 heller 1.38
1836     (defslimefun untrace-all ()
1837     (untrace))
1838    
1839 heller 1.116 (defslimefun undefine-function (fname-string)
1840     (let ((fname (from-string fname-string)))
1841     (format nil "~S" (fmakunbound fname))))
1842    
1843 heller 1.38 (defslimefun load-file (filename)
1844 heller 1.67 (to-string (load filename)))
1845 heller 1.72
1846 mbaringer 1.166 (defun requires-compile-p (pathname)
1847     (let ((compile-file-truename (probe-file (compile-file-pathname pathname))))
1848     (or (not compile-file-truename)
1849     (< (file-write-date compile-file-truename)
1850     (file-write-date pathname)))))
1851    
1852 heller 1.102
1853 heller 1.110 ;;;; Profiling
1854    
1855     (defun profiledp (fspec)
1856     (member fspec (profiled-functions)))
1857    
1858     (defslimefun toggle-profile-fdefinition (fname-string)
1859     (let ((fname (from-string fname-string)))
1860     (cond ((profiledp fname)
1861     (unprofile fname)
1862     (format nil "~S is now unprofiled." fname))
1863     (t
1864     (profile fname)
1865     (format nil "~S is now profiled." fname)))))
1866    
1867    
1868 heller 1.102 ;;;; Source Locations
1869 heller 1.72
1870 heller 1.147 (defslimefun find-definitions-for-emacs (name)
1871     "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
1872     DSPEC is a string and LOCATION a source location. NAME is a string."
1873     (multiple-value-bind (sexp error)
1874     (ignore-errors (values (from-string name)))
1875 heller 1.149 (cond (error '())
1876 heller 1.147 (t (loop for (dspec loc) in (find-definitions sexp)
1877 heller 1.141 collect (list (to-string dspec) loc))))))
1878 heller 1.147
1879 heller 1.72 (defun alistify (list key test)
1880 heller 1.77 "Partition the elements of LIST into an alist. KEY extracts the key
1881 heller 1.72 from an element and TEST is used to compare keys."
1882 heller 1.111 (declare (type function key))
1883 heller 1.72 (let ((alist '()))
1884     (dolist (e list)
1885     (let* ((k (funcall key e))
1886     (probe (assoc k alist :test test)))
1887     (if probe
1888     (push e (cdr probe))
1889     (push (cons k (list e)) alist))))
1890     alist))
1891 heller 1.77
1892 heller 1.72 (defun location-position< (pos1 pos2)
1893     (cond ((and (position-p pos1) (position-p pos2))
1894     (< (position-pos pos1)
1895     (position-pos pos2)))
1896     (t nil)))
1897 heller 1.74
1898 heller 1.138 (defun partition (list test key)
1899     (declare (type function test key))
1900 heller 1.74 (loop for e in list
1901 heller 1.138 if (funcall test (funcall key e)) collect e into yes
1902 heller 1.74 else collect e into no
1903     finally (return (values yes no))))
1904 heller 1.77
1905 heller 1.138 (defstruct (xref (:conc-name xref.)
1906     (:type list))
1907     dspec location)
1908    
1909     (defun location-valid-p (location)
1910     (eq (car location) :location))
1911    
1912     (defun xref-buffer (xref)
1913     (location-buffer (xref.location xref)))
1914    
1915     (defun xref-position (xref)
1916     (location-buffer (xref.location xref)))
1917    
1918 heller 1.72 (defun group-xrefs (xrefs)
1919 heller 1.147 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
1920     The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
1921 heller 1.138 (multiple-value-bind (resolved errors)
1922     (partition xrefs #'location-valid-p #'xref.location)
1923     (let ((alist (alistify resolved #'xref-buffer #'equal)))
1924     (append
1925     (loop for (buffer . list) in alist
1926     collect (cons (second buffer)
1927     (mapcar (lambda (xref)
1928     (cons (to-string (xref.dspec xref))
1929     (xref.location xref)))
1930     (sort list #'location-position<
1931     :key #'xref-position))))
1932     (if errors
1933     (list (cons "Unresolved"
1934     (mapcar (lambda (xref)
1935     (cons (to-string (xref.dspec xref))
1936     (xref.location xref)))
1937     errors))))))))
1938    
1939     (defslimefun xref (type symbol-name)
1940     (let ((symbol (find-symbol-or-lose symbol-name)))
1941     (group-xrefs
1942     (ecase type
1943     (:calls (who-calls symbol))
1944     (:references (who-references symbol))
1945     (:binds (who-binds symbol))
1946     (:sets (who-sets symbol))
1947     (:macroexpands (who-macroexpands symbol))
1948     (:specializes (who-specializes symbol))
1949     (:callers (list-callers symbol))
1950     (:callees (list-callees symbol))))))
1951 heller 1.72
1952 heller 1.138 ; (xref :calls "to-string")
1953 heller 1.102
1954     ;;;; Inspecting
1955    
1956     (defvar *inspectee*)
1957     (defvar *inspectee-parts*)
1958     (defvar *inspector-stack* '())
1959     (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1960 heller 1.111 (declaim (type vector *inspector-history*))
1961 heller 1.102 (defvar *inspect-length* 30)
1962    
1963     (defun reset-inspector ()
1964     (setq *inspectee* nil)
1965     (setq *inspectee-parts* nil)
1966     (setq *inspector-stack* nil)
1967     (setf (fill-pointer *inspector-history*) 0))
1968    
1969     (defslimefun init-inspector (string)
1970     (reset-inspector)
1971     (inspect-object (eval (from-string string))))
1972    
1973     (defun print-part-to-string (value)
1974 heller 1.116 (let ((*print-pretty* nil)
1975     (*print-circle* t))
1976 heller 1.102 (let ((string (to-string value))
1977     (pos (position value *inspector-history*)))
1978     (if pos
1979     (format nil "#~D=~A" pos string)
1980     string))))
1981    
1982     (defun inspect-object (object)
1983     (push (setq *inspectee* object) *inspector-stack*)
1984     (unless (find object *inspector-history*)
1985     (vector-push-extend object *inspector-history*))
1986     (multiple-value-bind (text parts) (inspected-parts object)
1987     (setq *inspectee-parts* parts)
1988     (list :text text
1989     :type (to-string (type-of object))
1990     :primitive-type (describe-primitive-type object)
1991     :parts (loop for (label . value) in parts
1992 heller 1.153 collect (cons (princ-to-string label)
1993 heller 1.102 (print-part-to-string value))))))
1994    
1995     (defun nth-part (index)
1996     (cdr (nth index *inspectee-parts*)))
1997    
1998     (defslimefun inspect-nth-part (index)
1999     (inspect-object (nth-part index)))
2000    
2001     (defslimefun inspector-pop ()
2002     "Drop the inspector stack and inspect the second element. Return
2003     nil if there's no second element."
2004     (cond ((cdr *inspector-stack*)
2005     (pop *inspector-stack*)
2006     (inspect-object (pop *inspector-stack*)))
2007     (t nil)))
2008    
2009     (defslimefun inspector-next ()
2010     "Inspect the next element in the *inspector-history*."
2011     (let ((position (position *inspectee* *inspector-history*)))
2012     (cond ((= (1+ position) (length *inspector-history*))
2013     nil)
2014     (t (inspect-object (aref *inspector-history* (1+ position)))))))
2015    
2016     (defslimefun quit-inspector ()
2017     (reset-inspector)
2018     nil)
2019    
2020     (defslimefun describe-inspectee ()
2021     "Describe the currently inspected object."
2022 heller 1.138 (describe-to-string *inspectee*))
2023 heller 1.102
2024     (defmethod inspected-parts ((object cons))
2025     (if (consp (cdr object))
2026     (inspected-parts-of-nontrivial-list object)
2027     (inspected-parts-of-simple-cons object)))
2028    
2029     (defun inspected-parts-of-simple-cons (object)
2030     (values "The object is a CONS."
2031     (list (cons (string 'car) (car object))
2032     (cons (string 'cdr) (cdr object)))))
2033    
2034     (defun inspected-parts-of-nontrivial-list (object)
2035     (let ((length 0)
2036     (in-list object)
2037     (reversed-elements nil))
2038     (flet ((done (description-format)
2039     (return-from inspected-parts-of-nontrivial-list
2040     (values (format nil description-format length)
2041     (nreverse reversed-elements)))))
2042     (loop
2043     (cond ((null in-list)
2044     (done "The object is a proper list of length ~S.~%"))
2045     ((>= length *inspect-length*)
2046     (push (cons (string 'rest) in-list) reversed-elements)
2047     (done "The object is a long list (more than ~S elements).~%"))
2048     ((consp in-list)
2049     (push (cons (format nil "~D" length) (pop in-list))
2050     reversed-elements)
2051     (incf length))
2052     (t
2053     (push (cons (string 'rest) in-list) reversed-elements)
2054     (done "The object is an improper list of length ~S.~%")))))))
2055 heller 1.135
2056     (defmethod inspected-parts ((o hash-table))
2057     (values (format nil "~A~% is a ~A" o (class-of o))
2058     (list*
2059     (cons "Test" (hash-table-test o))
2060     (cons "Count" (hash-table-count o))
2061     (cons "Size" (hash-table-size o))
2062     (cons "Rehash-Threshold" (hash-table-rehash-threshold o))
2063     (cons "Rehash-Size" (hash-table-rehash-size o))
2064     (cons "---" :---)
2065     (let ((pairs '()))
2066     (maphash (lambda (key value)
2067