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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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