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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.110 - (hide annotations)
Thu Jan 29 08:37:57 2004 UTC (10 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.109: +15 -0 lines
Profiler support.  Patch by Michael Weber.
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 lgorrie 1.62 ;;; Currently the package is declared in swank-backend.lisp
11 lgorrie 1.61 #+nil
12 heller 1.58 (defpackage :swank
13     (:use :common-lisp)
14 lgorrie 1.60 (:export #:start-server #:create-swank-server
15 heller 1.59 #:*sldb-pprint-frames*))
16 dbarlow 1.27
17 lukeg 1.1 (in-package :swank)
18 heller 1.31
19 lgorrie 1.90 (declaim (optimize (debug 3)))
20    
21 dbarlow 1.27 (defvar *swank-io-package*
22 heller 1.74 (let ((package (make-package "SWANK-IO-PACKAGE" :use '())))
23 heller 1.26 (import '(nil t quote) package)
24 ellerh 1.7 package))
25    
26 dbarlow 1.28 (defconstant server-port 4005
27     "Default port for the Swank TCP server.")
28    
29     (defvar *swank-debug-p* t
30     "When true, print extra debugging information.")
31    
32 heller 1.59 (defvar *sldb-pprint-frames* nil
33     "*pretty-print* is bound to this value when sldb prints a frame.")
34    
35 lgorrie 1.80 (defvar *processing-rpc* nil
36     "True when Lisp is evaluating an RPC from Emacs.")
37    
38     (defvar *multiprocessing-enabled* nil
39     "True when multiprocessing support is to be used.")
40    
41     (defvar *debugger-hook-passback* nil
42     ;; Temporary hack!
43     "When set while processing a command, the value is copied into
44     *debugger-hook*.
45    
46     This allows RPCs from Emacs to change the global value of
47     *debugger-hook*, which is shadowed in a dynamic binding while they
48     run.")
49    
50 lgorrie 1.91 (defparameter *redirect-io* t
51     "When non-nil redirect Lisp standard I/O to Emacs.
52     Redirection is done while Lisp is processing a request for Emacs.")
53    
54 heller 1.47 ;;; public interface. slimefuns are the things that emacs is allowed
55     ;;; to call
56    
57     (defmacro defslimefun (fun &rest rest)
58     `(progn
59     (defun ,fun ,@rest)
60     (export ',fun :swank)))
61    
62     (defmacro defslimefun-unimplemented (fun args)
63     `(progn
64     (defun ,fun ,args
65     (declare (ignore ,@args))
66     (error "Backend function ~A not implemented." ',fun))
67     (export ',fun :swank)))
68    
69 lgorrie 1.62
70 lgorrie 1.96 ;;;; Connections
71     ;;;
72     ;;; Connection structures represent the network connections between
73     ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
74     ;;; streams that redirect to Emacs, and optionally a second socket
75     ;;; used solely to pipe user-output to Emacs (an optimization).
76     ;;;
77     ;;; Initially Emacs connects to Lisp and the "main" connection is
78     ;;; created. The thread that accepts this connection then reads and
79     ;;; serves requests from Emacs as they arrive. Later, new connections
80     ;;; can be created for other threads that need to talke to Emacs,
81     ;;; e.g. to enter the debugger.
82     ;;;
83     ;;; Each connection is owned by the thread that accepts it. Only the
84     ;;; owner can use a connection to communicate with Emacs, with one
85     ;;; exception: Any thread may send out-of-band messages to Emacs using
86     ;;; the main connection. A message is "out of band" if it is
87     ;;; independent of the protocol state (or more specifically, if the
88     ;;; `slime-handle-oob' elisp function can handle it).
89     ;;;
90     ;;; When a new thread needs to talk to Emacs it must first create a
91     ;;; connection of its own. This is done by binding a listen-socket and
92     ;;; asking Emacs to connect, using an out-of-band message on the main
93     ;;; connection to tell Emacs what port to connect to. This logic is
94     ;;; encapsulated by the WITH-A-CONNECTION macro, which will execute
95     ;;; its body forms with a connection available, creating a temporary
96     ;;; one if necessary.
97     ;;;
98     ;;; Multiple threads can write to the main connection, so these writes
99     ;;; must by synchronized. This is coarsely achieved by using the
100     ;;; WITH-I/O-LOCK macro to globally serialize all writes to any
101     ;;; connection. Reads do not have to be synchronized because each
102     ;;; connection can only be read by one thread.
103 lgorrie 1.90 ;;;
104 lgorrie 1.96 ;;; Non-multiprocessing systems can ignore all of this. There is only
105     ;;; one connection and only one thread, so the invariants come for
106     ;;; free.
107 lgorrie 1.90
108     (defstruct (connection
109     (:conc-name connection.)
110     (:print-function %print-connection)
111 lgorrie 1.96 (:constructor make-connection (owner-id socket-io dedicated-output
112     user-input user-output user-io)))
113     ;; Thread-id of the connection's owner.
114     (owner-id nil)
115 lgorrie 1.90 ;; Raw I/O stream of socket connection.
116 lgorrie 1.96 (socket-io nil :type stream)
117     ;; Optional dedicated output socket (backending `user-output' slot).
118     ;; Has a slot so that it can be closed with the connection.
119     (dedicated-output nil :type (or stream null))
120 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
121 lgorrie 1.96 ;; redirected to Emacs.
122     (user-input nil :type (or stream null))
123     (user-output nil :type (or stream null))
124     (user-io nil :type (or stream null)))
125    
126     (defvar *main-connection* nil
127     "The main (first established) connection to Emacs.
128     Any thread may send out-of-band messages to Emacs using this
129     connection.")
130    
131     (defvar *main-thread-id* nil
132     "ID of the thread that established *MAIN-CONNECTION*.
133     Only this thread can read from or send in-band messages to the
134     *MAIN-CONNECTION*.")
135    
136     ;; This can't be initialized right away due to our compilation/loading
137     ;; order: it ends up calling the NO-APPLICABLE-METHOD version from
138     ;; swank-backend before the real one loads.
139 heller 1.101 (defvar *write-lock*)
140     (setf (documentation '*write-lock* 'variable)
141     "Lock held while writing to sockets.")
142 lgorrie 1.96
143     (defvar *dispatching-connection* nil
144     "Connection currently being served.
145     Dynamically bound while dispatching a request that arrives from
146     Emacs.")
147 lgorrie 1.90
148     (defun %print-connection (connection stream depth)
149     (declare (ignore depth))
150     (print-unreadable-object (connection stream :type t :identity t)))
151    
152     ;; Condition for SLIME protocol errors.
153     (define-condition slime-read-error (error)
154     ((condition :initarg :condition :reader slime-read-error.condition))
155     (:report (lambda (condition stream)
156     (format stream "~A" (slime-read-error.condition condition)))))
157    
158 lgorrie 1.96 ;;;; Helper macros
159    
160 heller 1.100 (defmacro with-I/O-lock ((&rest ignore) &body body)
161     (declare (ignore ignore))
162 lgorrie 1.96 `(call-with-lock-held *write-lock* (lambda () ,@body)))
163    
164 lgorrie 1.99 (defmacro with-io-redirection ((&optional (connection '(current-connection)))
165 lgorrie 1.96 &body body)
166     "Execute BODY with I/O redirection to CONNECTION.
167     If *REDIRECT-IO* is true, all standard I/O streams are redirected."
168     `(if *redirect-io*
169     (call-with-redirected-io ,connection (lambda () ,@body))
170     (progn ,@body)))
171    
172 heller 1.103 (defmacro without-interrupts (&body body)
173     `(call-without-interrupts (lambda () ,@body)))
174    
175 lgorrie 1.90 ;;;; TCP Server
176 dbarlow 1.28
177 heller 1.79 (defvar *close-swank-socket-after-setup* nil)
178 heller 1.94 (defvar *use-dedicated-output-stream* t)
179 heller 1.95 (defvar *swank-in-background* nil)
180 heller 1.79
181 heller 1.103 (defun start-server (port-file)
182 heller 1.101 (setup-server 0 (lambda (port) (announce-server-port port-file port))
183 heller 1.103 *swank-in-background*))
184 heller 1.101
185     (defun create-swank-server (&optional (port 4005)
186 heller 1.105 (background *swank-in-background*)
187     (announce-fn #'simple-announce-function))
188     (setup-server port announce-fn background))
189 heller 1.101
190     (defun setup-server (port announce-fn background)
191 lgorrie 1.96 (setq *write-lock* (make-lock :name "Swank write lock"))
192 heller 1.106 (let* ((socket (create-socket port))
193     (port (local-port socket)))
194     (funcall announce-fn port)
195     (if (eq *swank-in-background* :spawn)
196     (spawn (lambda () (serve-connection socket nil)) :name "Swank")
197     (serve-connection socket background))
198     port))
199 lgorrie 1.96
200 heller 1.106 (defun serve-connection (socket background)
201     (let ((client (accept-connection socket)))
202     (close-socket socket)
203     (let ((connection (create-connection client)))
204     (init-main-connection connection)
205     (serve-requests client connection background))))
206 heller 1.97
207     (defun serve-requests (client connection background)
208     (ecase background
209 heller 1.106 (:fd-handler (add-input-handler
210     client (lambda ()
211 heller 1.97 (loop (cond ((handle-request connection)
212     (remove-input-handlers client)
213     (return))
214     ((listen client))
215     (t (return)))))))
216     ((nil) (loop until (handle-request connection)))))
217 heller 1.94
218 lgorrie 1.96 (defun init-main-connection (connection)
219     (setq *main-connection* connection)
220     (setq *main-thread-id* (thread-id))
221     (emacs-connected))
222    
223 heller 1.94 (defun announce-server-port (file port)
224     (with-open-file (s file
225     :direction :output
226     :if-exists :overwrite
227     :if-does-not-exist :create)
228     (format s "~S~%" port))
229     (simple-announce-function port))
230 lgorrie 1.90
231     (defun create-connection (socket-io)
232 heller 1.97 (send-to-emacs `(:check-protocol-version ,(changelog-date)) socket-io)
233     (multiple-value-bind (output-fn dedicated-output)
234     (make-output-function socket-io)
235 lgorrie 1.96 (let ((input-fn (lambda () (read-user-input-from-emacs socket-io))))
236     (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
237 heller 1.101 (let ((out (or dedicated-output out)))
238     (let ((io (make-two-way-stream in out)))
239     (make-connection (thread-id) socket-io dedicated-output
240     in out io)))))))
241 lgorrie 1.90
242     (defun make-output-function (socket-io)
243 lgorrie 1.96 "Create function to send user output to Emacs.
244     This function may open a dedicated socket to send output. It
245     returns two values: the output function, and the dedicated
246     stream (or NIL if none was created)."
247 lgorrie 1.90 (if *use-dedicated-output-stream*
248     (let ((stream (open-dedicated-output-stream socket-io)))
249 lgorrie 1.96 (values (lambda (string)
250 heller 1.97 (write-string string stream)
251 lgorrie 1.96 (force-output stream))
252     stream))
253     (values (lambda (string) (send-output-to-emacs string socket-io))
254     nil)))
255 heller 1.97
256 lgorrie 1.90 (defun open-dedicated-output-stream (socket-io)
257     "Open a dedicated output connection to the Emacs on SOCKET-IO.
258     Return an output stream suitable for writing program output.
259    
260     This is an optimized way for Lisp to deliver output to Emacs."
261 heller 1.94 (let* ((socket (create-socket 0))
262     (port (local-port socket)))
263     (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io)
264     (accept-connection socket)))
265 lgorrie 1.90
266     (defun handle-request (connection)
267     "Read and respond to one request from CONNECTION."
268     (catch 'slime-toplevel
269     (with-simple-restart (abort "Return to SLIME toplevel.")
270     (let ((*dispatching-connection* connection))
271     (with-io-redirection ()
272     (handler-case (read-from-emacs)
273     (slime-read-error (e)
274     (when *swank-debug-p*
275     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
276 lgorrie 1.96 (close-connection connection)
277 lgorrie 1.90 (return-from handle-request t)))))))
278     nil)
279    
280 heller 1.77 (defun simple-announce-function (port)
281 dbarlow 1.28 (when *swank-debug-p*
282 heller 1.85 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
283 heller 1.97
284     (defun changelog-date ()
285     "Return the datestring of the latest ChangeLog entry. The date is
286     determined at compile time."
287     (macrolet ((date ()
288 heller 1.100 (let* ((here (or *compile-file-truename* *load-truename*))
289     (changelog (make-pathname
290     :name "ChangeLog"
291     :directory (pathname-directory here)
292     :host (pathname-host here)))
293 heller 1.97 (date (with-open-file (file changelog :direction :input)
294     (string (read file)))))
295     `(quote ,date))))
296     (date)))
297 heller 1.77
298 lgorrie 1.80
299 lgorrie 1.62 ;;;; IO to Emacs
300     ;;;
301     ;;; The lower layer is a socket connection. Emacs sends us forms to
302     ;;; evaluate, and we accept these by calling READ-FROM-EMACS. These
303     ;;; evaluations can send messages back to Emacs as a side-effect by
304     ;;; calling SEND-TO-EMACS.
305 dbarlow 1.28
306 lgorrie 1.90 (defun call-with-redirected-io (connection function)
307     "Call FUNCTION with I/O streams redirected via CONNECTION."
308     (let* ((io (connection.user-io connection))
309     (in (connection.user-input connection))
310     (out (connection.user-output connection))
311     (*standard-output* out)
312     (*error-output* out)
313     (*trace-output* out)
314     (*debug-io* io)
315     (*query-io* io)
316     (*standard-input* in)
317     (*terminal-io* io))
318     (funcall function)))
319    
320 lgorrie 1.96 (defun current-connection ()
321     (cond ((and *dispatching-connection*
322     ;; In SBCL new threads inherit the dynamic bindings of
323     ;; their parent. That means the *dispatching-connection*
324     ;; when the thread is created (e.g. from SLIME REPL)
325     ;; will be visible to the new thread, even though it's
326     ;; not the owner and mustn't use it. Must ask Dan all
327     ;; about this. -luke (15/Jan/2004)
328     #+SBCL (equal (thread-id) (connection.owner-id *dispatching-connection*)))
329     *dispatching-connection*)
330     ((equal (thread-id) *main-thread-id*)
331     *main-connection*)
332     (t nil)))
333    
334 lgorrie 1.90 (defun current-socket-io ()
335 lgorrie 1.96 (connection.socket-io (current-connection)))
336 lgorrie 1.80
337 heller 1.100 (defmacro with-a-connection ((&rest ignore) &body body)
338 lgorrie 1.96 "Execute BODY with a connection.
339     If no connection is currently available then a new one is
340     temporarily created for the extent of the execution.
341    
342     Thus the BODY forms can call READ-FROM-EMACS and SEND-TO-EMACS."
343 heller 1.100 (declare (ignore ignore))
344 lgorrie 1.96 `(if (current-connection)
345     (progn ,@body)
346     (call-with-aux-connection (lambda () ,@body))))
347    
348     (defun call-with-aux-connection (fn)
349     (let* ((c (open-aux-connection))
350     (*dispatching-connection* c))
351     (unwind-protect (funcall fn)
352     (close-connection c))))
353    
354     (defun close-connection (c)
355     (close (connection.socket-io c))
356     (when (connection.dedicated-output c)
357     (close (connection.dedicated-output c))))
358    
359     (defun open-aux-connection ()
360     (let* ((socket (create-socket 0))
361     (port (local-port socket)))
362     (send-to-emacs `(:open-aux-connection ,port)
363     (connection.socket-io *main-connection*))
364     (create-connection (accept-connection socket))))
365    
366     (defun announce-aux-server (port)
367     (send-to-emacs `(:open-aux-connection ,port)
368     (connection.socket-io *main-connection*)))
369    
370     (defvar *log-events* nil)
371 heller 1.87
372     (defun log-event (format-string &rest args)
373     "Write a message to *terminal-io* when *log-events* is non-nil.
374     Useful for low level debugging."
375     (when *log-events*
376     (apply #'format *terminal-io* format-string args)))
377    
378 lgorrie 1.90 (defun read-from-emacs (&optional (stream (current-socket-io)))
379 dbarlow 1.28 "Read and process a request from Emacs."
380 lgorrie 1.90 (let ((form (read-next-form stream)))
381 heller 1.87 (log-event "READ: ~S~%" form)
382 lgorrie 1.90 (apply #'funcall form)))
383 heller 1.46
384 lgorrie 1.90 (defun read-next-form (stream)
385     "Read an S-expression from STREAM using the SLIME protocol.
386     If a protocol error occurs then a SLIME-READ-ERROR is signalled."
387     (flet ((next-byte () (char-code (read-char stream))))
388 heller 1.44 (handler-case
389 lgorrie 1.96 (let* ((length (logior (ash (next-byte) 16)
390     (ash (next-byte) 8)
391     (next-byte)))
392     (string (make-string length))
393     (pos (read-sequence string stream)))
394     (assert (= pos length) ()
395     "Short read: length=~D pos=~D" length pos)
396     (read-form string))
397 lgorrie 1.90 (serious-condition (c)
398 heller 1.46 (error (make-condition 'slime-read-error :condition c))))))
399 dbarlow 1.28
400     (defun read-form (string)
401     (with-standard-io-syntax
402     (let ((*package* *swank-io-package*))
403     (read-from-string string))))
404    
405 lgorrie 1.50 (defvar *slime-features* nil
406     "The feature list that has been sent to Emacs.")
407    
408     (defun sync-state-to-emacs ()
409     "Update Emacs if any relevant Lisp state has changed."
410     (unless (eq *slime-features* *features*)
411     (setq *slime-features* *features*)
412     (send-to-emacs (list :new-features (mapcar #'symbol-name *features*)))))
413    
414 lgorrie 1.90 (defun send-to-emacs (object &optional (output (current-socket-io)))
415     "Send OBJECT to over CONNECTION to Emacs."
416 lgorrie 1.80 (let* ((string (prin1-to-string-for-emacs object))
417     (length (1+ (length string))))
418 heller 1.87 (log-event "SEND: ~A~%" string)
419 lgorrie 1.96 (with-I/O-lock ()
420 heller 1.103 (without-interrupts
421     (loop for position from 16 downto 0 by 8
422     do (write-char (code-char (ldb (byte 8 position) length))
423     output))
424     (write-string string output)
425     (terpri output)
426     (force-output output)))))
427 dbarlow 1.28
428 lgorrie 1.104 (defun send-oob-to-emacs (object)
429     (send-to-emacs object (connection.socket-io *main-connection*)))
430    
431 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
432 heller 1.31 (with-standard-io-syntax
433     (let ((*print-case* :downcase)
434 heller 1.38 (*print-readably* t)
435 heller 1.31 (*print-pretty* nil)
436     (*package* *swank-io-package*))
437     (prin1-to-string object))))
438 dbarlow 1.28
439 lgorrie 1.90 (defun force-user-output (&optional (connection *dispatching-connection*))
440     (assert (connection-p connection))
441     (force-output (connection.user-io connection))
442     (force-output (connection.user-output connection)))
443    
444     (defun clear-user-input (&optional (connection *dispatching-connection*))
445     (assert (connection-p connection))
446     (clear-input (connection.user-input connection)))
447 lgorrie 1.62
448 lgorrie 1.90 (defun send-output-to-emacs (string socket-io)
449     (send-to-emacs `(:read-output ,string) socket-io))
450 lgorrie 1.62
451 lgorrie 1.91 (defvar *read-input-catch-tag* 0)
452    
453 lgorrie 1.90 (defun read-user-input-from-emacs (socket-io)
454 lgorrie 1.62 (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
455 lgorrie 1.90 (send-to-emacs `(:read-string ,*read-input-catch-tag*) socket-io)
456     (let ((ok nil))
457 lgorrie 1.62 (unwind-protect
458     (prog1 (catch *read-input-catch-tag*
459 lgorrie 1.90 (loop (read-from-emacs socket-io)))
460 lgorrie 1.62 (setq ok t))
461     (unless ok
462     (send-to-emacs `(:read-aborted)))))))
463 lgorrie 1.90
464 lgorrie 1.62 (defslimefun take-input (tag input)
465     (throw tag input))
466    
467    
468     ;;;; Reading and printing
469 dbarlow 1.28
470     (defvar *buffer-package*)
471     (setf (documentation '*buffer-package* 'symbol)
472     "Package corresponding to slime-buffer-package.
473    
474     EVAL-STRING binds *buffer-package*. Strings originating from a slime
475     buffer are best read in this package. See also FROM-STRING and TO-STRING.")
476    
477     (defun from-string (string)
478     "Read string in the *BUFFER-PACKAGE*"
479     (let ((*package* *buffer-package*))
480     (read-from-string string)))
481    
482 lgorrie 1.60 (defun symbol-from-string (string)
483     "Read string in the *BUFFER-PACKAGE*"
484     (let ((*package* *buffer-package*))
485     (find-symbol (string-upcase string))))
486    
487 dbarlow 1.28 (defun to-string (string)
488     "Write string in the *BUFFER-PACKAGE*."
489     (let ((*package* *buffer-package*))
490     (prin1-to-string string)))
491    
492 heller 1.53 (defun guess-package-from-string (name &optional (default-package *package*))
493 dbarlow 1.28 (or (and name
494     (or (find-package name)
495     (find-package (string-upcase name))))
496 heller 1.53 default-package))
497 dbarlow 1.28
498 heller 1.72 (defun find-symbol-designator (string &optional
499     (default-package *buffer-package*))
500     "Return the symbol corresponding to the symbol designator STRING.
501     If string is not package qualified use DEFAULT-PACKAGE for the
502     resolution. Return nil if no such symbol exists."
503     (multiple-value-bind (name package-name internal-p)
504 heller 1.108 (tokenize-symbol-designator (case-convert string))
505 heller 1.72 (cond ((and package-name (not (find-package package-name)))
506     (values nil nil))
507     (t
508     (let ((package (or (find-package package-name) default-package)))
509     (multiple-value-bind (symbol access) (find-symbol name package)
510     (cond ((and symbol package-name (not internal-p)
511     (not (eq access :external)))
512     (values nil nil))
513     (symbol (values symbol access)))))))))
514 heller 1.103
515     (defun find-symbol-or-lose (string &optional
516     (default-package *buffer-package*))
517     "Like FIND-SYMBOL-DESIGNATOR but signal an error the symbols doesn't
518     exists."
519     (multiple-value-bind (symbol package)
520     (find-symbol-designator string default-package)
521     (cond (package (values symbol package))
522     (t (error "Unknown symbol: ~S [in ~A]" string default-package)))))
523    
524     (defun format-arglist (function-name lambda-list-fn)
525     "Use LAMBDA-LIST-FN to format the arglist for FUNCTION-NAME.
526     Call LAMBDA-LIST-FN with the symbol corresponding to FUNCTION-NAME."
527     (multiple-value-bind (arglist condition)
528     (ignore-errors
529     (let ((symbol (find-symbol-or-lose function-name)))
530     (values (funcall lambda-list-fn symbol))))
531     (cond (condition (format nil "(-- ~A)" condition))
532     (t (let ((*print-case* :downcase))
533     (format nil "(~{~A~^ ~})" arglist))))))
534 heller 1.72
535 lgorrie 1.62
536     ;;;; Debugger
537 heller 1.47
538 lgorrie 1.62 ;;; These variables are dynamically bound during debugging.
539 dbarlow 1.28
540 lgorrie 1.63 ;; The condition being debugged.
541     (defvar *swank-debugger-condition* nil)
542 dbarlow 1.28
543 lgorrie 1.62 (defvar *sldb-level* 0
544     "The current level of recursive debugging.")
545 heller 1.38
546 lgorrie 1.76 (defvar *sldb-initial-frames* 20
547     "The initial number of backtrace frames to send to Emacs.")
548    
549 heller 1.107
550 heller 1.38 (defun swank-debugger-hook (condition hook)
551 lgorrie 1.62 "Debugger entry point, called from *DEBUGGER-HOOK*.
552     Sends a message to Emacs declaring that the debugger has been entered,
553     then waits to handle further requests from Emacs. Eventually returns
554     after Emacs causes a restart to be invoked."
555 heller 1.67 (declare (ignore hook))
556 lgorrie 1.96 ;; (unless (or *processing-rpc* (not *multiprocessing-enabled*))
557     ;; (request-async-debug condition))
558 heller 1.38 (let ((*swank-debugger-condition* condition)
559 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
560     (symbol-value '*buffer-package*))
561     *package*)))
562 lgorrie 1.62 (let ((*sldb-level* (1+ *sldb-level*)))
563 heller 1.107 (force-user-output)
564 lgorrie 1.62 (call-with-debugging-environment
565     (lambda () (sldb-loop *sldb-level*))))))
566 dbarlow 1.73
567     (defun slime-debugger-function ()
568     "Returns a function suitable for use as the value of *DEBUGGER-HOOK*
569     or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to install the SLIME debugger
570     globally. Must be run from the *slime-repl* buffer or somewhere else
571     that the slime streams are visible so that it can capture them."
572 lgorrie 1.96 (let ((package *buffer-package*))
573 dbarlow 1.73 (labels ((slime-debug (c &optional next)
574 lgorrie 1.96 (let ((*buffer-package* package))
575 dbarlow 1.73 ;; check emacs is still there: don't want to end up
576     ;; in recursive debugger loops if it's disconnected
577 lgorrie 1.96 (when (open-stream-p (connection.socket-io *main-connection*))
578     (with-a-connection ()
579     (with-io-redirection ()
580     (swank-debugger-hook c next)))))))
581 dbarlow 1.73 #'slime-debug)))
582 lgorrie 1.62
583 lgorrie 1.80 (defslimefun install-global-debugger-hook ()
584     (setq *debugger-hook-passback* (slime-debugger-function))
585     t)
586    
587     (defun startup-multiprocessing-for-emacs ()
588     (setq *multiprocessing-enabled* t)
589     (startup-multiprocessing))
590    
591 lgorrie 1.62 (defun sldb-loop (level)
592 lgorrie 1.76 (send-to-emacs (list* :debug *sldb-level*
593     (debugger-info-for-emacs 0 *sldb-initial-frames*)))
594 lgorrie 1.62 (unwind-protect
595     (loop (catch 'sldb-loop-catcher
596     (with-simple-restart
597     (abort "Return to sldb level ~D." level)
598     (handler-bind ((sldb-condition #'handle-sldb-condition))
599     (read-from-emacs)))))
600     (send-to-emacs `(:debug-return ,level))))
601    
602     (defun handle-sldb-condition (condition)
603     "Handle an internal debugger condition.
604     Rather than recursively debug the debugger (a dangerous idea!), these
605     conditions are simply reported."
606     (let ((real-condition (original-condition condition)))
607     (send-to-emacs `(:debug-condition ,(princ-to-string real-condition))))
608     (throw 'sldb-loop-catcher nil))
609    
610 heller 1.86 (defun safe-condition-message (condition)
611     "Safely print condition to a string, handling any errors during
612     printing."
613     (handler-case
614     (princ-to-string condition)
615     (error (cond)
616     ;; Beware of recursive errors in printing, so only use the condition
617     ;; if it is printable itself:
618     (format nil "Unable to display error condition~@[: ~A~]"
619     (ignore-errors (princ-to-string cond))))))
620    
621     (defun debugger-condition-for-emacs ()
622     (list (safe-condition-message *swank-debugger-condition*)
623     (format nil " [Condition of type ~S]"
624     (type-of *swank-debugger-condition*))))
625    
626     (defun print-with-frame-label (n fn)
627     "Bind some printer variables to properly indent the frame and call
628     FN with a string-stream for printing a frame of a bracktrace. Return
629     the string."
630     (let* ((label (format nil " ~D: " n))
631     (string (with-output-to-string (stream)
632     (let ((*print-pretty* *sldb-pprint-frames*))
633     (princ label stream) (funcall fn stream)))))
634     (subseq string (length label))))
635    
636     (defslimefun sldb-can-continue-p ()
637     "Return T if there is a continue restart; otherwise NIL."
638     (if (find-restart 'continue) t nil))
639    
640 lgorrie 1.62 (defslimefun sldb-continue ()
641 heller 1.79 (continue))
642 lgorrie 1.64
643 lgorrie 1.84 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
644     "Invoke the Nth available restart.
645     SLDB-LEVEL is the debug level when the request was made. If this
646     has changed, ignore the request."
647     (when (= sldb-level *sldb-level*)
648     (invoke-nth-restart n)))
649    
650     (defun sldb-break-with-default-debugger ()
651     (let ((*debugger-hook* nil))
652     ;; FIXME: This will break when the SBCL backend starts using the
653     ;; extra sbcl debugger hook.
654     (break)))
655    
656 lgorrie 1.64 (defslimefun eval-string-in-frame (string index)
657 lgorrie 1.65 (to-string (eval-in-frame (from-string string) index)))
658 lgorrie 1.62
659    
660     ;;;; Evaluation
661 heller 1.38
662 heller 1.68 (defun eval-in-emacs (form)
663     "Execute FROM in Emacs."
664     (destructuring-bind (fn &rest args) form
665     (swank::send-to-emacs
666     `(:%apply ,(string-downcase (string fn)) ,args))))
667    
668 heller 1.87 (defslimefun eval-string (string buffer-package id)
669 lgorrie 1.80 (let ((*processing-rpc* t)
670     (*debugger-hook* #'swank-debugger-hook))
671 dbarlow 1.28 (let (ok result)
672     (unwind-protect
673     (let ((*buffer-package* (guess-package-from-string buffer-package)))
674     (assert (packagep *buffer-package*))
675     (setq result (eval (read-form string)))
676     (force-output)
677     (setq ok t))
678 lgorrie 1.50 (sync-state-to-emacs)
679 lgorrie 1.90 (force-user-output)
680 heller 1.87 (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id)))))
681 lgorrie 1.80 (when *debugger-hook-passback*
682     (setq *debugger-hook* *debugger-hook-passback*)
683     (setq *debugger-hook-passback* nil)))
684 lgorrie 1.84
685     (defslimefun oneway-eval-string (string buffer-package)
686     "Evaluate STRING in BUFFER-PACKAGE, without sending a reply.
687     The debugger hook is inhibited during the evaluation."
688     (let ((*buffer-package* (guess-package-from-string buffer-package))
689     (*package* *buffer-package*)
690     (*debugger-hook* nil))
691     (eval (read-form string))))
692 dbarlow 1.28
693 heller 1.59 (defun format-values-for-echo-area (values)
694     (cond (values (format nil "~{~S~^, ~}" values))
695     (t "; No value")))
696    
697 dbarlow 1.28 (defslimefun interactive-eval (string)
698 lgorrie 1.48 (let ((values (multiple-value-list
699     (let ((*package* *buffer-package*))
700     (eval (from-string string))))))
701 dbarlow 1.28 (force-output)
702 heller 1.59 (format-values-for-echo-area values)))
703 dbarlow 1.28
704 lgorrie 1.50 (defun eval-region (string &optional package-update-p)
705     "Evaluate STRING and return the result.
706     If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
707     change, then send Emacs an update."
708 vsedach 1.92 (let ((*package* *buffer-package*)
709     - values)
710 heller 1.89 (unwind-protect
711 vsedach 1.92 (with-input-from-string (stream string)
712     (loop for form = (read stream nil stream)
713     until (eq form stream)
714     do (progn
715     (setq - form)
716     (setq values (multiple-value-list (eval form)))
717     (force-output))
718     finally (return (values values -))))
719 heller 1.89 (when (and package-update-p (not (eq *package* *buffer-package*)))
720 vsedach 1.92 (send-to-emacs
721     (list :new-package (shortest-package-nickname *package*)))))))
722 lgorrie 1.81
723     (defun shortest-package-nickname (package)
724     "Return the shortest nickname (or canonical name) of PACKAGE."
725     (loop for name in (cons (package-name package) (package-nicknames package))
726     for shortest = name then (if (< (length name) (length shortest))
727     name
728     shortest)
729     finally (return shortest)))
730 heller 1.49
731 heller 1.38 (defslimefun interactive-eval-region (string)
732     (let ((*package* *buffer-package*))
733 heller 1.59 (format-values-for-echo-area (eval-region string))))
734 heller 1.38
735     (defslimefun re-evaluate-defvar (form)
736     (let ((*package* *buffer-package*))
737     (let ((form (read-from-string form)))
738     (destructuring-bind (dv name &optional value doc) form
739     (declare (ignore value doc))
740     (assert (eq dv 'defvar))
741     (makunbound name)
742     (prin1-to-string (eval form))))))
743    
744 heller 1.59 (defun swank-pprint (list)
745     "Bind some printer variables and pretty print each object in LIST."
746 heller 1.57 (let ((*print-pretty* t)
747     (*print-circle* t)
748 heller 1.59 (*print-escape* t)
749 heller 1.57 (*print-level* nil)
750     (*print-length* nil))
751 heller 1.59 (cond ((null list) "; No value")
752     (t (with-output-to-string (*standard-output*)
753     (dolist (o list)
754     (pprint o)
755     (terpri)))))))
756 heller 1.57
757 dbarlow 1.29 (defslimefun pprint-eval (string)
758     (let ((*package* *buffer-package*))
759 heller 1.59 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
760 dbarlow 1.28
761 dbarlow 1.29 (defslimefun set-package (package)
762 heller 1.109 "Set *package* to PACKAGE and return its name and shortest nickname."
763     (let ((p (setq *package* (guess-package-from-string package))))
764     (list (package-name p) (shortest-package-nickname p))))
765 heller 1.49
766     (defslimefun listener-eval (string)
767 lgorrie 1.90 (clear-user-input)
768 lgorrie 1.50 (multiple-value-bind (values last-form) (eval-region string t)
769 heller 1.49 (setq +++ ++ ++ + + last-form
770     *** ** ** * * (car values)
771     /// // // / / values)
772 heller 1.59 (cond ((null values) "; No value")
773 lgorrie 1.60 (t
774     (let ((*package* *buffer-package*))
775     (format nil "~{~S~^~%~}" values))))))
776 dbarlow 1.28
777 lgorrie 1.104 (defslimefun ed-in-emacs (&optional what)
778     "Edit WHAT in Emacs.
779     WHAT can be a filename (pathname or string) or function name (symbol)."
780     (send-oob-to-emacs `(:ed ,(if (pathnamep what)
781     (canonicalize-filename what)
782     what))))
783    
784 lgorrie 1.62
785 dbarlow 1.29 ;;;; Compilation Commands.
786    
787     (defvar *compiler-notes* '()
788     "List of compiler notes for the last compilation unit.")
789    
790     (defun clear-compiler-notes ()
791 lgorrie 1.61 (setf *compiler-notes* '()))
792 dbarlow 1.29
793     (defun canonicalize-filename (filename)
794     (namestring (truename filename)))
795    
796 heller 1.31 (defslimefun compiler-notes-for-emacs ()
797     "Return the list of compiler notes for the last compilation unit."
798     (reverse *compiler-notes*))
799    
800 dbarlow 1.29 (defun measure-time-interval (fn)
801     "Call FN and return the first return value and the elapsed time.
802     The time is measured in microseconds."
803     (let ((before (get-internal-real-time)))
804     (values
805     (funcall fn)
806     (* (- (get-internal-real-time) before)
807     (/ 1000000 internal-time-units-per-second)))))
808    
809 lgorrie 1.61 (defun record-note-for-condition (condition)
810     "Record a note for a compiler-condition."
811     (push (make-compiler-note condition) *compiler-notes*))
812    
813     (defun make-compiler-note (condition)
814     "Make a compiler note data structure from a compiler-condition."
815     (declare (type compiler-condition condition))
816     (list :message (message condition)
817     :severity (severity condition)
818     :location (location condition)))
819 lgorrie 1.32
820 dbarlow 1.78 (defun swank-compiler (function)
821 lgorrie 1.61 (clear-compiler-notes)
822 dbarlow 1.29 (multiple-value-bind (result usecs)
823 lgorrie 1.61 (handler-bind ((compiler-condition #'record-note-for-condition))
824 dbarlow 1.78 (measure-time-interval function))
825 lgorrie 1.61 (list (to-string result)
826     (format nil "~,2F" (/ usecs 1000000.0)))))
827    
828 dbarlow 1.78 (defslimefun swank-compile-file (filename load-p)
829     "Compile FILENAME and, when LOAD-P, load the result.
830     Record compiler notes signalled as `compiler-condition's."
831     (swank-compiler (lambda () (compile-file-for-emacs filename load-p))))
832    
833 lgorrie 1.62 (defslimefun swank-compile-string (string buffer position)
834     "Compile STRING (exerpted from BUFFER at POSITION).
835     Record compiler notes signalled as `compiler-condition's."
836 dbarlow 1.78 (swank-compiler
837     (lambda ()
838     (compile-string-for-emacs string :buffer buffer :position position))))
839    
840     (defslimefun swank-load-system (system)
841     "Compile and load SYSTEM using ASDF.
842     Record compiler notes signalled as `compiler-condition's."
843     (swank-compiler (lambda () (compile-system-for-emacs system))))
844    
845 lgorrie 1.62
846 lgorrie 1.70 ;;;; Macroexpansion
847 dbarlow 1.29
848     (defun apply-macro-expander (expander string)
849     (let ((*print-pretty* t)
850     (*print-length* 20)
851     (*print-level* 20))
852     (to-string (funcall expander (from-string string)))))
853    
854     (defslimefun swank-macroexpand-1 (string)
855     (apply-macro-expander #'macroexpand-1 string))
856    
857     (defslimefun swank-macroexpand (string)
858     (apply-macro-expander #'macroexpand string))
859    
860     (defslimefun disassemble-symbol (symbol-name)
861     (print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
862 heller 1.38
863 lgorrie 1.61 (defslimefun swank-macroexpand-all (string)
864     (apply-macro-expander #'macroexpand-all string))
865    
866 lgorrie 1.62
867 lgorrie 1.70 ;;;; Completion
868 heller 1.38
869 heller 1.53 (defun case-convert (string)
870     "Convert STRING according to the current readtable-case."
871 heller 1.56 (check-type string string)
872 heller 1.53 (ecase (readtable-case *readtable*)
873     (:upcase (string-upcase string))
874     (:downcase (string-downcase string))
875     (:preserve string)
876 heller 1.55 (:invert (cond ((every #'lower-case-p string) (string-upcase string))
877     ((every #'upper-case-p string) (string-downcase string))
878     (t string)))))
879 heller 1.53
880 heller 1.108 (defun carefully-find-package (name default-package-name)
881     "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
882     *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
883     (let ((n (cond ((equal name "") "KEYWORD")
884     (t (or name default-package-name)))))
885     (if n
886     (find-package (case-convert n))
887     *buffer-package*)))
888    
889 heller 1.38 (defslimefun completions (string default-package-name)
890     "Return a list of completions for a symbol designator STRING.
891    
892 lgorrie 1.70 The result is the list (COMPLETION-SET
893     COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
894     completions, and COMPLETED-PREFIX is the best (partial)
895     completion of the input string.
896    
897     If STRING is package qualified the result list will also be
898     qualified. If string is non-qualified the result strings are
899     also not qualified and are considered relative to
900 lgorrie 1.42 DEFAULT-PACKAGE-NAME.
901    
902     The way symbols are matched depends on the symbol designator's
903     format. The cases are as follows:
904     FOO - Symbols with matching prefix and accessible in the buffer package.
905     PKG:FOO - Symbols with matching prefix and external in package PKG.
906     PKG::FOO - Symbols with matching prefix and accessible in package PKG."
907 lgorrie 1.41 (multiple-value-bind (name package-name internal-p)
908 heller 1.108 (tokenize-symbol-designator string)
909     (let ((package (carefully-find-package package-name default-package-name))
910     (completions nil))
911 lgorrie 1.42 (flet ((symbol-matches-p (symbol)
912 lgorrie 1.76 (and (compound-prefix-match name (symbol-name symbol))
913 heller 1.108 (or internal-p
914     (null package-name)
915 lgorrie 1.42 (symbol-external-p symbol package)))))
916 heller 1.108 (when package
917 lgorrie 1.41 (do-symbols (symbol package)
918 lgorrie 1.42 (when (symbol-matches-p symbol)
919 lgorrie 1.41 (push symbol completions)))))
920     (let ((*print-case* (if (find-if #'upper-case-p string)
921 heller 1.108 :upcase :downcase)))
922     (let ((completion-set
923     (mapcar (lambda (s)
924     (cond (internal-p
925     (format nil "~A::~A" package-name s))
926     (package-name
927     (format nil "~A:~A" package-name s))
928     (t
929     (format nil "~A" s))))
930     ;; DO-SYMBOLS can consider the same symbol more than
931     ;; once, so remove duplicates.
932     (remove-duplicates (sort completions #'string<
933     :key #'symbol-name)))))
934 lgorrie 1.69 (list completion-set (longest-completion completion-set)))))))
935 heller 1.38
936 heller 1.108 (defun tokenize-symbol-designator (string)
937 lgorrie 1.41 "Parse STRING as a symbol designator.
938     Return three values:
939     SYMBOL-NAME
940     PACKAGE-NAME, or nil if the designator does not include an explicit package.
941     INTERNAL-P, if the symbol is qualified with `::'."
942     (values (let ((pos (position #\: string :from-end t)))
943     (if pos (subseq string (1+ pos)) string))
944     (let ((pos (position #\: string)))
945     (if pos (subseq string 0 pos) nil))
946     (search "::" string)))
947 heller 1.53
948 lgorrie 1.42 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
949     "True if SYMBOL is external in PACKAGE.
950     If PACKAGE is not specified, the home package of SYMBOL is used."
951 heller 1.38 (multiple-value-bind (_ status)
952 lgorrie 1.42 (find-symbol (symbol-name symbol) (or package (symbol-package symbol)))
953 heller 1.38 (declare (ignore _))
954     (eq status :external)))
955    
956 lgorrie 1.69
957 lgorrie 1.70 ;;;;; Subword-word matching
958 lgorrie 1.66
959 lgorrie 1.76 (defun compound-prefix-match (prefix target)
960     "Return true if PREFIX is a compound-prefix of TARGET.
961     Viewing each of PREFIX and TARGET as a series of substrings delimited
962     by hyphens, if each substring of PREFIX is a prefix of the
963     corresponding substring in TARGET then we call PREFIX a
964     compound-prefix of TARGET.
965    
966 lgorrie 1.66 Examples:
967 lgorrie 1.76 \(compound-prefix-match \"foo\" \"foobar\") => t
968     \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
969     \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
970     (loop for ch across prefix
971     with tpos = 0
972     always (and (< tpos (length target))
973     (if (char= ch #\-)
974     (setf tpos (position #\- target :start tpos))
975     (char-equal ch (aref target tpos))))
976     do (incf tpos)))
977 lgorrie 1.66
978 lgorrie 1.69
979 lgorrie 1.70 ;;;;; Extending the input string by completion
980 lgorrie 1.69
981     (defun longest-completion (completions)
982     "Return the longest prefix for all COMPLETIONS."
983     (untokenize-completion
984     (mapcar #'longest-common-prefix
985 lgorrie 1.71 (transpose-lists (mapcar #'tokenize-completion completions)))))
986 lgorrie 1.69
987 lgorrie 1.71 (defun tokenize-completion (string)
988 lgorrie 1.69 "Return all substrings of STRING delimited by #\-."
989 heller 1.85 (loop with end
990     for start = 0 then (1+ end)
991 lgorrie 1.69 until (> start (length string))
992 heller 1.85 do (setq end (or (position #\- string :start start) (length string)))
993 lgorrie 1.69 collect (subseq string start end)))
994    
995     (defun untokenize-completion (tokens)
996     (format nil "~{~A~^-~}" tokens))
997    
998     (defun longest-common-prefix (strings)
999     "Return the longest string that is a common prefix of STRINGS."
1000     (if (null strings)
1001     ""
1002     (flet ((common-prefix (s1 s2)
1003     (let ((diff-pos (mismatch s1 s2)))
1004     (if diff-pos (subseq s1 0 diff-pos) s1))))
1005     (reduce #'common-prefix strings))))
1006    
1007 lgorrie 1.71 (defun transpose-lists (lists)
1008     "Turn a list-of-lists on its side.
1009     If the rows are of unequal length, truncate uniformly to the shortest.
1010    
1011     For example:
1012 heller 1.74 \(transpose-lists '((ONE TWO THREE) (1 2)))
1013     => ((ONE 1) (TWO 2))"
1014 lgorrie 1.69 ;; A cute function from PAIP p.574
1015 lgorrie 1.71 (if lists (apply #'mapcar #'list lists)))
1016 heller 1.38
1017 lgorrie 1.62
1018     ;;;; Documentation
1019 heller 1.38
1020     (defslimefun apropos-list-for-emacs (name &optional external-only package)
1021     "Make an apropos search for Emacs.
1022     The result is a list of property lists."
1023     (mapcan (listify #'briefly-describe-symbol-for-emacs)
1024 lgorrie 1.104 (sort (apropos-symbols name
1025     external-only
1026     (if package
1027     (or (find-package (read-from-string package))
1028     (error "No such package: ~S" package))
1029     nil))
1030 heller 1.38 #'present-symbol-before-p)))
1031 lgorrie 1.61
1032     (defun briefly-describe-symbol-for-emacs (symbol)
1033     "Return a property list describing SYMBOL.
1034     Like `describe-symbol-for-emacs' but with at most one line per item."
1035     (flet ((first-line (string)
1036     (let ((pos (position #\newline string)))
1037     (if (null pos) string (subseq string 0 pos)))))
1038 heller 1.67 (let ((desc (map-if #'stringp #'first-line
1039     (describe-symbol-for-emacs symbol))))
1040     (if desc
1041     (list* :designator (to-string symbol) desc)))))
1042 lgorrie 1.61
1043     (defun map-if (test fn &rest lists)
1044     "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
1045     Example:
1046     \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
1047     (apply #'mapcar
1048     (lambda (x) (if (funcall test x) (funcall fn x) x))
1049     lists))
1050 heller 1.38
1051     (defun listify (f)
1052     "Return a function like F, but which returns any non-null value
1053     wrapped in a list."
1054     (lambda (x)
1055     (let ((y (funcall f x)))
1056     (and y (list y)))))
1057    
1058     (defun present-symbol-before-p (a b)
1059     "Return true if A belongs before B in a printed summary of symbols.
1060     Sorted alphabetically by package name and then symbol name, except
1061     that symbols accessible in the current package go first."
1062     (flet ((accessible (s)
1063     (find-symbol (symbol-name s) *buffer-package*)))
1064 lgorrie 1.42 (cond ((and (accessible a) (accessible b))
1065     (string< (symbol-name a) (symbol-name b)))
1066     ((accessible a) t)
1067     ((accessible b) nil)
1068     (t
1069     (string< (package-name (symbol-package a))
1070     (package-name (symbol-package b)))))))
1071 heller 1.38
1072 lgorrie 1.62 (defun apropos-symbols (string &optional external-only package)
1073     (remove-if (lambda (sym)
1074     (or (keywordp sym)
1075     (and external-only
1076 lgorrie 1.104 ;; (not (equal (symbol-package sym) *buffer-package*))
1077 lgorrie 1.62 (not (symbol-external-p sym)))))
1078     (apropos-list string package)))
1079    
1080     (defun print-output-to-string (fn)
1081     (with-output-to-string (*standard-output*)
1082     (let ((*debug-io* *standard-output*))
1083     (funcall fn))))
1084    
1085     (defun print-description-to-string (object)
1086     (print-output-to-string (lambda () (describe object))))
1087    
1088     (defslimefun describe-symbol (symbol-name)
1089 heller 1.74 (multiple-value-bind (symbol foundp)
1090     (find-symbol-designator symbol-name)
1091     (cond (foundp (print-description-to-string symbol))
1092 lgorrie 1.90 (t (format nil "Unknown symbol: ~S [in ~A]"
1093 heller 1.74 symbol-name *buffer-package*)))))
1094 lgorrie 1.62
1095     (defslimefun describe-function (symbol-name)
1096     (print-description-to-string
1097 heller 1.67 (symbol-function (find-symbol-designator symbol-name))))
1098 lgorrie 1.62
1099 heller 1.75 (defslimefun documentation-symbol (symbol-name &optional default)
1100 lgorrie 1.62 (let ((*package* *buffer-package*))
1101     (let ((vdoc (documentation (symbol-from-string symbol-name) 'variable))
1102     (fdoc (documentation (symbol-from-string symbol-name) 'function)))
1103 heller 1.75 (or (and (or vdoc fdoc)
1104     (concatenate 'string
1105     fdoc
1106     (and vdoc fdoc '(#\Newline #\Newline))
1107     vdoc))
1108     default))))
1109 lgorrie 1.62
1110    
1111     ;;;;
1112    
1113     (defslimefun list-all-package-names ()
1114     (mapcar #'package-name (list-all-packages)))
1115 heller 1.79
1116     ;; Use eval for the sake of portability...
1117     (defun tracedp (fspec)
1118     (member fspec (eval '(trace))))
1119    
1120     (defslimefun toggle-trace-fdefinition (fname-string)
1121     (let ((fname (from-string fname-string)))
1122     (cond ((tracedp fname)
1123     (eval `(untrace ,fname))
1124     (format nil "~S is now untraced." fname))
1125     (t
1126     (eval `(trace ,fname))
1127     (format nil "~S is now traced." fname)))))
1128 heller 1.38
1129     (defslimefun untrace-all ()
1130     (untrace))
1131    
1132     (defslimefun load-file (filename)
1133 heller 1.67 (to-string (load filename)))
1134 heller 1.46
1135     (defslimefun throw-to-toplevel ()
1136     (throw 'slime-toplevel nil))
1137 heller 1.72
1138 heller 1.102
1139 heller 1.110 ;;;; Profiling
1140    
1141     (defun profiledp (fspec)
1142     (member fspec (profiled-functions)))
1143    
1144     (defslimefun toggle-profile-fdefinition (fname-string)
1145     (let ((fname (from-string fname-string)))
1146     (cond ((profiledp fname)
1147     (unprofile fname)
1148     (format nil "~S is now unprofiled." fname))
1149     (t
1150     (profile fname)
1151     (format nil "~S is now profiled." fname)))))
1152    
1153    
1154 heller 1.102 ;;;; Source Locations
1155 heller 1.72
1156     (defstruct (:location (:type list) :named
1157     (:constructor make-location (buffer position)))
1158 heller 1.74 buffer position)
1159 heller 1.72
1160 heller 1.74 (defstruct (:error (:type list) :named (:constructor)) message)
1161     (defstruct (:file (:type list) :named (:constructor)) name)
1162     (defstruct (:buffer (:type list) :named (:constructor)) name)
1163     (defstruct (:position (:type list) :named (:constructor)) pos)
1164 heller 1.72
1165     (defun alistify (list key test)
1166 heller 1.77 "Partition the elements of LIST into an alist. KEY extracts the key
1167 heller 1.72 from an element and TEST is used to compare keys."
1168     (let ((alist '()))
1169     (dolist (e list)
1170     (let* ((k (funcall key e))
1171     (probe (assoc k alist :test test)))
1172     (if probe
1173     (push e (cdr probe))
1174     (push (cons k (list e)) alist))))
1175     alist))
1176 heller 1.77
1177 heller 1.72 (defun location-position< (pos1 pos2)
1178     (cond ((and (position-p pos1) (position-p pos2))
1179     (< (position-pos pos1)
1180     (position-pos pos2)))
1181     (t nil)))
1182 heller 1.74
1183     (defun partition (list predicate)
1184     (loop for e in list
1185     if (funcall predicate e) collect e into yes
1186     else collect e into no
1187     finally (return (values yes no))))
1188 heller 1.77
1189 heller 1.72 (defun group-xrefs (xrefs)
1190     (flet ((xref-buffer (xref) (location-buffer (cdr xref)))
1191     (xref-position (xref) (location-position (cdr xref))))
1192 heller 1.74 (multiple-value-bind (resolved errors)
1193     (partition xrefs (lambda (x) (location-p (cdr x))))
1194     (let ((alist (alistify resolved #'xref-buffer #'equal)))
1195     (append
1196     (loop for (key . list) in alist
1197     collect (cons (to-string key)
1198     (sort list #'location-position<
1199     :key #'xref-position)))
1200     (if errors
1201     `(("Unresolved" . ,errors))))))))
1202 heller 1.72
1203 heller 1.102
1204     ;;;; Inspecting
1205    
1206     (defvar *inspectee*)
1207     (defvar *inspectee-parts*)
1208     (defvar *inspector-stack* '())
1209     (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1210     (defvar *inspect-length* 30)
1211    
1212     (defun reset-inspector ()
1213     (setq *inspectee* nil)
1214     (setq *inspectee-parts* nil)
1215     (setq *inspector-stack* nil)
1216     (setf (fill-pointer *inspector-history*) 0))
1217    
1218     (defslimefun init-inspector (string)
1219     (reset-inspector)
1220     (inspect-object (eval (from-string string))))
1221    
1222     (defun print-part-to-string (value)
1223     (let ((*print-pretty* nil))
1224     (let ((string (to-string value))
1225     (pos (position value *inspector-history*)))
1226     (if pos
1227     (format nil "#~D=~A" pos string)
1228     string))))
1229    
1230     (defun inspect-object (object)
1231     (push (setq *inspectee* object) *inspector-stack*)
1232     (unless (find object *inspector-history*)
1233     (vector-push-extend object *inspector-history*))
1234     (multiple-value-bind (text parts) (inspected-parts object)
1235     (setq *inspectee-parts* parts)
1236     (list :text text
1237     :type (to-string (type-of object))
1238     :primitive-type (describe-primitive-type object)
1239     :parts (loop for (label . value) in parts
1240     collect (cons label
1241     (print-part-to-string value))))))
1242    
1243     (defun nth-part (index)
1244     (cdr (nth index *inspectee-parts*)))
1245    
1246     (defslimefun inspect-nth-part (index)
1247     (inspect-object (nth-part index)))
1248    
1249     (defslimefun inspector-pop ()
1250     "Drop the inspector stack and inspect the second element. Return
1251     nil if there's no second element."
1252     (cond ((cdr *inspector-stack*)
1253     (pop *inspector-stack*)
1254     (inspect-object (pop *inspector-stack*)))
1255     (t nil)))
1256    
1257     (defslimefun inspector-next ()
1258     "Inspect the next element in the *inspector-history*."
1259     (let ((position (position *inspectee* *inspector-history*)))
1260     (cond ((= (1+ position) (length *inspector-history*))
1261     nil)
1262     (t (inspect-object (aref *inspector-history* (1+ position)))))))
1263    
1264     (defslimefun quit-inspector ()
1265     (reset-inspector)
1266     nil)
1267    
1268     (defslimefun describe-inspectee ()
1269     "Describe the currently inspected object."
1270     (print-description-to-string *inspectee*))
1271    
1272     (defmethod inspected-parts ((object cons))
1273     (if (consp (cdr object))
1274     (inspected-parts-of-nontrivial-list object)
1275     (inspected-parts-of-simple-cons object)))
1276    
1277     (defun inspected-parts-of-simple-cons (object)
1278     (values "The object is a CONS."
1279     (list (cons (string 'car) (car object))
1280     (cons (string 'cdr) (cdr object)))))
1281    
1282     (defun inspected-parts-of-nontrivial-list (object)
1283     (let ((length 0)
1284     (in-list object)
1285     (reversed-elements nil))
1286     (flet ((done (description-format)
1287     (return-from inspected-parts-of-nontrivial-list
1288     (values (format nil description-format length)
1289     (nreverse reversed-elements)))))
1290     (loop
1291     (cond ((null in-list)
1292     (done "The object is a proper list of length ~S.~%"))
1293     ((>= length *inspect-length*)
1294     (push (cons (string 'rest) in-list) reversed-elements)
1295     (done "The object is a long list (more than ~S elements).~%"))
1296     ((consp in-list)
1297     (push (cons (format nil "~D" length) (pop in-list))
1298     reversed-elements)
1299     (incf length))
1300     (t
1301     (push (cons (string 'rest) in-list) reversed-elements)
1302     (done "The object is an improper list of length ~S.~%")))))))
1303 ellerh 1.9
1304     ;;; Local Variables:
1305     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1306 dbarlow 1.35 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5