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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.244 - (hide annotations)
Mon Sep 27 22:23:01 2004 UTC (9 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.243: +27 -7 lines
(mop, mop-helper): Support functions for the class browser.  By Rui
Patrocínio.
1 lgorrie 1.194 ;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-;;;
2 dbarlow 1.27 ;;;
3 lgorrie 1.194 ;;; This code has been placed in the Public Domain. All warranties
4     ;;; are disclaimed.
5 dbarlow 1.27 ;;;
6 lgorrie 1.194 ;;;; swank.lisp
7 dbarlow 1.27 ;;;
8 lgorrie 1.194 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9     ;;; code in this file is purely portable Common Lisp. We do require a
10     ;;; smattering of non-portable functions in order to write the server,
11     ;;; so we have defined them in `swank-backend.lisp' and implemented
12     ;;; them separately for each Lisp implementation. These extensions are
13     ;;; available to us here via the `SWANK-BACKEND' package.
14 heller 1.26
15 heller 1.58 (defpackage :swank
16 heller 1.138 (:use :common-lisp :swank-backend)
17 lgorrie 1.152 (:export #:startup-multiprocessing
18 heller 1.138 #:start-server
19     #:create-swank-server
20 heller 1.178 #:create-server
21 heller 1.138 #:ed-in-emacs
22 lgorrie 1.157 #:print-indentation-lossage
23 lgorrie 1.177 #:swank-debugger-hook
24 lgorrie 1.194 ;; These are user-configurable variables:
25 lgorrie 1.152 #:*sldb-pprint-frames*
26     #:*communication-style*
27     #:*log-events*
28     #:*use-dedicated-output-stream*
29 lgorrie 1.157 #:*configure-emacs-indentation*
30 heller 1.189 #:*readtable-alist*
31 lgorrie 1.197 #:*globally-redirect-io*
32 lgorrie 1.223 #:*global-debugger*
33 lgorrie 1.194 ;; These are re-exported directly from the backend:
34 lgorrie 1.209 #:buffer-first-change
35 heller 1.139 #:frame-source-location-for-emacs
36 wjenkner 1.146 #:restart-frame
37 heller 1.191 #:sldb-step
38 heller 1.240 #:sldb-break
39     #:sldb-break-on-return
40 heller 1.142 #:profiled-functions
41     #:profile-report
42     #:profile-reset
43     #:unprofile-all
44     #:profile-package
45 heller 1.189 #:default-directory
46 heller 1.150 #:set-default-directory
47 heller 1.170 #:quit-lisp
48 heller 1.138 ))
49 dbarlow 1.27
50 heller 1.189 (in-package #:swank)
51    
52 lgorrie 1.194 ;;;; Top-level variables, constants, macros
53    
54     (defconstant cl-package (find-package :cl)
55     "The COMMON-LISP package.")
56    
57     (defconstant keyword-package (find-package :keyword)
58     "The KEYWORD package.")
59 heller 1.31
60 pseibel 1.211 (defvar *canonical-packge-nicknames*
61     '(("COMMON-LISP-USER" . "CL-USER"))
62     "Canonical package names to use instead of shortest name/nickname.")
63    
64     (defvar *auto-abbreviate-dotted-packages* t
65     "Automatically abbreviate dotted package names to their last component when T.")
66    
67 dbarlow 1.27 (defvar *swank-io-package*
68 heller 1.153 (let ((package (make-package :swank-io-package :use '())))
69 heller 1.26 (import '(nil t quote) package)
70 ellerh 1.7 package))
71    
72 lgorrie 1.194 (defconstant default-server-port 4005
73     "The default TCP port for the server (when started manually).")
74 dbarlow 1.28
75     (defvar *swank-debug-p* t
76     "When true, print extra debugging information.")
77    
78 heller 1.59 (defvar *sldb-pprint-frames* nil
79     "*pretty-print* is bound to this value when sldb prints a frame.")
80    
81 lgorrie 1.194 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
82     ;;; RPC.
83 heller 1.47
84 lgorrie 1.157 (defmacro defslimefun (name arglist &body rest)
85 lgorrie 1.194 "A DEFUN for functions that Emacs can call by RPC."
86 heller 1.47 `(progn
87 lgorrie 1.157 (defun ,name ,arglist ,@rest)
88 lgorrie 1.187 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
89     (eval-when (:compile-toplevel :load-toplevel :execute)
90     (export ',name :swank))))
91 heller 1.47
92 heller 1.113 (declaim (ftype (function () nil) missing-arg))
93     (defun missing-arg ()
94 lgorrie 1.194 "A function that the compiler knows will never to return a value.
95     You can use (MISSING-ARG) as the initform for defstruct slots that
96     must always be supplied. This way the :TYPE slot option need not
97     include some arbitrary initial value like NIL."
98 heller 1.113 (error "A required &KEY or &OPTIONAL argument was not supplied."))
99    
100 lgorrie 1.197 ;;;; Hooks
101     ;;;
102     ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
103     ;;; simple indirection. The interface is more CLish than the Emacs
104     ;;; Lisp one.
105    
106     (defmacro add-hook (place function)
107 heller 1.222 "Add FUNCTION to the list of values on PLACE."
108 lgorrie 1.197 `(pushnew ,function ,place))
109    
110     (defun run-hook (functions &rest arguments)
111     "Call each of FUNCTIONS with ARGUMENTS."
112     (dolist (function functions)
113     (apply function arguments)))
114    
115     (defvar *new-connection-hook* '()
116     "This hook is run each time a connection is established.
117     The connection structure is given as the argument.
118     Backend code should treat the connection structure as opaque.")
119    
120     (defvar *connection-closed-hook* '()
121     "This hook is run when a connection is closed.
122     The connection as passed as an argument.
123     Backend code should treat the connection structure as opaque.")
124    
125     (defvar *pre-reply-hook* '()
126     "Hook run (without arguments) immediately before replying to an RPC.")
127    
128 lgorrie 1.96 ;;;; Connections
129     ;;;
130     ;;; Connection structures represent the network connections between
131     ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
132     ;;; streams that redirect to Emacs, and optionally a second socket
133     ;;; used solely to pipe user-output to Emacs (an optimization).
134     ;;;
135 lgorrie 1.90
136     (defstruct (connection
137 lgorrie 1.215 (:conc-name connection.)
138     (:print-function print-connection))
139 lgorrie 1.90 ;; Raw I/O stream of socket connection.
140 heller 1.113 (socket-io (missing-arg) :type stream :read-only t)
141 lgorrie 1.96 ;; Optional dedicated output socket (backending `user-output' slot).
142     ;; Has a slot so that it can be closed with the connection.
143     (dedicated-output nil :type (or stream null))
144 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
145 lgorrie 1.96 ;; redirected to Emacs.
146     (user-input nil :type (or stream null))
147     (user-output nil :type (or stream null))
148 heller 1.112 (user-io nil :type (or stream null))
149 lgorrie 1.194 ;; In multithreaded systems we delegate certain tasks to specific
150     ;; threads. The `reader-thread' is responsible for reading network
151     ;; requests from Emacs and sending them to the `control-thread'; the
152     ;; `control-thread' is responsible for dispatching requests to the
153     ;; threads that should handle them; the `repl-thread' is the one
154     ;; that evaluates REPL expressions. The control thread dispatches
155     ;; all REPL evaluations to the REPL thread and for other requests it
156     ;; spawns new threads.
157     reader-thread
158 heller 1.134 control-thread
159 lgorrie 1.173 repl-thread
160 lgorrie 1.194 ;; Callback functions:
161     ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
162     ;; from Emacs.
163     (serve-requests (missing-arg) :type function)
164     ;; (READ) is called to read and return one message from Emacs.
165 heller 1.113 (read (missing-arg) :type function)
166 lgorrie 1.194 ;; (SEND OBJECT) is called to send one message to Emacs.
167 heller 1.113 (send (missing-arg) :type function)
168 lgorrie 1.194 ;; (CLEANUP <this-connection>) is called when the connection is
169     ;; closed.
170 heller 1.113 (cleanup nil :type (or null function))
171 lgorrie 1.194 ;; Cache of macro-indentation information that has been sent to Emacs.
172     ;; This is used for preparing deltas to update Emacs's knowledge.
173     ;; Maps: symbol -> indentation-specification
174 lgorrie 1.157 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
175 lgorrie 1.194 ;; The list of packages represented in the cache:
176     (indentation-cache-packages '()))
177 lgorrie 1.215
178     (defun print-connection (conn stream depth)
179     (declare (ignore depth))
180     (print-unreadable-object (conn stream :type t :identity t)))
181 heller 1.115
182 lgorrie 1.157 (defvar *connections* '()
183     "List of all active connections, with the most recent at the front.")
184    
185 heller 1.112 (defvar *emacs-connection* nil
186 lgorrie 1.194 "The connection to Emacs currently in use.")
187 lgorrie 1.96
188 heller 1.115 (defvar *swank-state-stack* '()
189     "A list of symbols describing the current state. Used for debugging
190     and to detect situations where interrupts can be ignored.")
191 lgorrie 1.90
192 lgorrie 1.157 (defun default-connection ()
193     "Return the 'default' Emacs connection.
194 lgorrie 1.194 This connection can be used to talk with Emacs when no specific
195     connection is in use, i.e. *EMACS-CONNECTION* is NIL.
196    
197 lgorrie 1.157 The default connection is defined (quite arbitrarily) as the most
198     recently established one."
199 lgorrie 1.194 (first *connections*))
200 lgorrie 1.157
201 heller 1.112 (defslimefun state-stack ()
202 heller 1.115 "Return the value of *SWANK-STATE-STACK*."
203 heller 1.112 *swank-state-stack*)
204    
205 lgorrie 1.212 (define-condition slime-protocol-error (error)
206     ((condition :initarg :condition :reader slime-protocol-error.condition))
207 lgorrie 1.90 (:report (lambda (condition stream)
208 lgorrie 1.212 (format stream "~A" (slime-protocol-error.condition condition)))))
209 lgorrie 1.90
210 lgorrie 1.197 (add-hook *new-connection-hook* 'notify-backend-of-connection)
211     (defun notify-backend-of-connection (connection)
212 lgorrie 1.198 (emacs-connected (connection.user-io connection)))
213 lgorrie 1.197
214 lgorrie 1.96 ;;;; Helper macros
215    
216 lgorrie 1.174 (defmacro with-io-redirection ((connection) &body body)
217 lgorrie 1.194 "Execute BODY I/O redirection to CONNECTION.
218     If *REDIRECT-IO* is true then all standard I/O streams are redirected."
219 lgorrie 1.174 `(if *redirect-io*
220     (call-with-redirected-io ,connection (lambda () ,@body))
221     (progn ,@body)))
222    
223 heller 1.153 (defmacro with-connection ((connection) &body body)
224     "Execute BODY in the context of CONNECTION."
225     `(let ((*emacs-connection* ,connection))
226 lgorrie 1.157 (catch 'slime-toplevel
227     (with-io-redirection (*emacs-connection*)
228     (let ((*debugger-hook* #'swank-debugger-hook))
229     ,@body)))))
230 lgorrie 1.96
231 heller 1.103 (defmacro without-interrupts (&body body)
232     `(call-without-interrupts (lambda () ,@body)))
233 heller 1.112
234     (defmacro destructure-case (value &rest patterns)
235     "Dispatch VALUE to one of PATTERNS.
236     A cross between `case' and `destructuring-bind'.
237     The pattern syntax is:
238     ((HEAD . ARGS) . BODY)
239     The list of patterns is searched for a HEAD `eq' to the car of
240     VALUE. If one is found, the BODY is executed with ARGS bound to the
241     corresponding values in the CDR of VALUE."
242     (let ((operator (gensym "op-"))
243     (operands (gensym "rand-"))
244     (tmp (gensym "tmp-")))
245     `(let* ((,tmp ,value)
246     (,operator (car ,tmp))
247     (,operands (cdr ,tmp)))
248     (case ,operator
249     ,@(mapcar (lambda (clause)
250     (if (eq (car clause) t)
251     `(t ,@(cdr clause))
252     (destructuring-bind ((op &rest rands) &rest body)
253     clause
254     `(,op (destructuring-bind ,rands ,operands
255     . ,body)))))
256     patterns)
257     ,@(if (eq (caar (last patterns)) t)
258     '()
259     `((t (error "destructure-case failed: ~S" ,tmp))))))))
260 heller 1.242
261 lgorrie 1.157 (defmacro with-temp-package (var &body body)
262     "Execute BODY with VAR bound to a temporary package.
263     The package is deleted before returning."
264     `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
265     (unwind-protect (progn ,@body)
266     (delete-package ,var))))
267    
268 lgorrie 1.90 ;;;; TCP Server
269 dbarlow 1.28
270 heller 1.112 (defparameter *redirect-io* t
271     "When non-nil redirect Lisp standard I/O to Emacs.
272     Redirection is done while Lisp is processing a request for Emacs.")
273    
274 heller 1.94 (defvar *use-dedicated-output-stream* t)
275 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
276 heller 1.113 (defvar *log-events* nil)
277 heller 1.79
278 heller 1.178 (defun start-server (port-file &optional (style *communication-style*)
279 heller 1.133 dont-close)
280 lgorrie 1.212 "Start the server and write the listen port number to PORT-FILE.
281     This is the entry point for Emacs."
282 heller 1.101 (setup-server 0 (lambda (port) (announce-server-port port-file port))
283 heller 1.178 style dont-close))
284    
285 lgorrie 1.194 (defun create-server (&key (port default-server-port)
286 heller 1.178 (style *communication-style*)
287     dont-close)
288 lgorrie 1.212 "Start a SWANK server on PORT running in STYLE.
289     If DONT-CLOSE is true then the listen socket will accept multiple
290     connections, otherwise it will be closed after the first."
291 heller 1.178 (setup-server port #'simple-announce-function style dont-close))
292    
293 lgorrie 1.194 (defun create-swank-server (&optional (port default-server-port)
294 heller 1.178 (style *communication-style*)
295 heller 1.133 (announce-fn #'simple-announce-function)
296     dont-close)
297 heller 1.178 (setup-server port announce-fn style dont-close))
298 heller 1.101
299 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
300    
301 heller 1.133 (defun setup-server (port announce-fn style dont-close)
302 heller 1.111 (declare (type function announce-fn))
303 heller 1.119 (let* ((socket (create-socket *loopback-interface* port))
304 heller 1.106 (port (local-port socket)))
305     (funcall announce-fn port)
306 heller 1.179 (ecase style
307 heller 1.178 (:spawn
308     (spawn (lambda ()
309     (loop do (serve-connection socket :spawn dont-close)
310     while dont-close))
311     :name "Swank"))
312     ((:fd-handler :sigio)
313     (add-fd-handler socket
314     (lambda ()
315     (serve-connection socket style dont-close))))
316     ((nil)
317     (unwind-protect
318     (loop do (serve-connection socket style dont-close)
319     while dont-close)
320     (close-socket socket))))
321 heller 1.106 port))
322 lgorrie 1.96
323 heller 1.133 (defun serve-connection (socket style dont-close)
324 heller 1.106 (let ((client (accept-connection socket)))
325 heller 1.133 (unless dont-close
326     (close-socket socket))
327 heller 1.112 (let ((connection (create-connection client style)))
328 lgorrie 1.194 (run-hook *new-connection-hook* connection)
329 lgorrie 1.157 (push connection *connections*)
330 heller 1.112 (serve-requests connection))))
331    
332     (defun serve-requests (connection)
333 heller 1.115 "Read and process all requests on connections."
334 heller 1.112 (funcall (connection.serve-requests connection) connection))
335    
336 heller 1.94 (defun announce-server-port (file port)
337     (with-open-file (s file
338     :direction :output
339     :if-exists :overwrite
340     :if-does-not-exist :create)
341     (format s "~S~%" port))
342     (simple-announce-function port))
343 lgorrie 1.90
344 heller 1.115 (defun simple-announce-function (port)
345     (when *swank-debug-p*
346     (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
347    
348 heller 1.153 (defun open-streams (connection)
349 heller 1.115 "Return the 4 streams for IO redirection:
350 lgorrie 1.212 DEDICATED-OUTPUT INPUT OUTPUT IO"
351 heller 1.97 (multiple-value-bind (output-fn dedicated-output)
352 heller 1.153 (make-output-function connection)
353 lgorrie 1.157 (let ((input-fn
354     (lambda ()
355     (with-connection (connection)
356 lgorrie 1.206 (with-simple-restart (abort-read
357     "Abort reading input from Emacs.")
358 lgorrie 1.157 (read-user-input-from-emacs))))))
359 lgorrie 1.96 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
360 heller 1.101 (let ((out (or dedicated-output out)))
361     (let ((io (make-two-way-stream in out)))
362 lgorrie 1.208 (mapc #'make-stream-interactive (list in out io))
363 heller 1.112 (values dedicated-output in out io)))))))
364 lgorrie 1.90
365 heller 1.153 (defun make-output-function (connection)
366 lgorrie 1.96 "Create function to send user output to Emacs.
367     This function may open a dedicated socket to send output. It
368     returns two values: the output function, and the dedicated
369     stream (or NIL if none was created)."
370 lgorrie 1.90 (if *use-dedicated-output-stream*
371 heller 1.153 (let ((stream (open-dedicated-output-stream
372     (connection.socket-io connection))))
373 lgorrie 1.96 (values (lambda (string)
374 heller 1.97 (write-string string stream)
375 lgorrie 1.96 (force-output stream))
376     stream))
377 heller 1.153 (values (lambda (string)
378     (with-connection (connection)
379 lgorrie 1.157 (with-simple-restart
380     (abort "Abort sending output to Emacs.")
381     (send-to-emacs `(:read-output ,string)))))
382 lgorrie 1.96 nil)))
383 heller 1.97
384 lgorrie 1.90 (defun open-dedicated-output-stream (socket-io)
385     "Open a dedicated output connection to the Emacs on SOCKET-IO.
386     Return an output stream suitable for writing program output.
387    
388     This is an optimized way for Lisp to deliver output to Emacs."
389 heller 1.119 (let* ((socket (create-socket *loopback-interface* 0))
390 heller 1.94 (port (local-port socket)))
391 heller 1.112 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
392 heller 1.94 (accept-connection socket)))
393 lgorrie 1.90
394 heller 1.134 (defun handle-request (connection)
395 heller 1.115 "Read and process one request. The processing is done in the extend
396     of the toplevel restart."
397 heller 1.112 (assert (null *swank-state-stack*))
398 heller 1.242 (let ((*swank-state-stack* '(:handle-request))
399     (*debugger-hook* nil))
400 heller 1.134 (with-connection (connection)
401 lgorrie 1.157 (with-simple-restart (abort "Abort handling SLIME request.")
402     (read-from-emacs)))))
403 heller 1.97
404 heller 1.112 (defun current-socket-io ()
405     (connection.socket-io *emacs-connection*))
406    
407     (defun close-connection (c &optional condition)
408 heller 1.113 (let ((cleanup (connection.cleanup c)))
409     (when cleanup
410     (funcall cleanup c)))
411 heller 1.112 (close (connection.socket-io c))
412     (when (connection.dedicated-output c)
413 lgorrie 1.157 (close (connection.dedicated-output c)))
414 lgorrie 1.197 (setf *connections* (remove c *connections*))
415 lgorrie 1.217 (run-hook *connection-closed-hook* c)
416     (when condition
417     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)))
418 heller 1.112
419     (defmacro with-reader-error-handler ((connection) &body body)
420     `(handler-case (progn ,@body)
421 lgorrie 1.217 (slime-protocol-error (e)
422     (close-connection ,connection e))))
423 heller 1.112
424 heller 1.180 (defun simple-break ()
425     (with-simple-restart (continue "Continue from interrupt.")
426     (let ((*debugger-hook* #'swank-debugger-hook))
427     (invoke-debugger
428     (make-condition 'simple-error
429     :format-control "Interrupt from Emacs")))))
430    
431     ;;;;;; Thread based communication
432    
433 heller 1.204 (defvar *active-threads* '())
434    
435 heller 1.134 (defun read-loop (control-thread input-stream connection)
436     (with-reader-error-handler (connection)
437 heller 1.112 (loop (send control-thread (decode-message input-stream)))))
438    
439 heller 1.134 (defun dispatch-loop (socket-io connection)
440 heller 1.204 (let ((*emacs-connection* connection))
441 lgorrie 1.173 (loop (with-simple-restart (abort "Restart dispatch loop.")
442 heller 1.134 (loop (dispatch-event (receive) socket-io))))))
443 heller 1.112
444 heller 1.241 (defun repl-thread (connection)
445     (let ((thread (connection.repl-thread connection)))
446     (if (thread-alive-p thread)
447     thread
448     (setf (connection.repl-thread connection)
449     (spawn (lambda () (repl-loop connection))
450     :name "new-repl-thread")))))
451    
452     (defun find-worker-thread (id)
453     (etypecase id
454     ((member t)
455     (car *active-threads*))
456     ((member :repl-thread)
457     (repl-thread *emacs-connection*))
458     (fixnum
459     (find-thread id))))
460    
461 heller 1.204 (defun interrupt-worker-thread (id)
462 heller 1.241 (let ((thread (or (find-worker-thread id)
463     (repl-thread *emacs-connection*))))
464 heller 1.129 (interrupt-thread thread #'simple-break)))
465 heller 1.112
466 heller 1.204 (defun thread-for-evaluation (id)
467 heller 1.180 "Find or create a thread to evaluate the next request."
468     (let ((c *emacs-connection*))
469 heller 1.204 (etypecase id
470 heller 1.180 ((member t)
471     (spawn (lambda () (handle-request c)) :name "worker"))
472     ((member :repl-thread)
473 heller 1.241 (repl-thread c))
474 heller 1.180 (fixnum
475 heller 1.204 (find-thread id)))))
476 heller 1.180
477 heller 1.112 (defun dispatch-event (event socket-io)
478 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
479 heller 1.112 (log-event "DISPATCHING: ~S~%" event)
480     (destructure-case event
481 heller 1.204 ((:emacs-rex form package thread-id id)
482     (let ((thread (thread-for-evaluation thread-id)))
483     (push thread *active-threads*)
484     (send thread `(eval-for-emacs ,form ,package ,id))))
485 heller 1.112 ((:return thread &rest args)
486 heller 1.204 (let ((tail (member thread *active-threads*)))
487     (setq *active-threads* (nconc (ldiff *active-threads* tail)
488     (cdr tail))))
489 heller 1.112 (encode-message `(:return ,@args) socket-io))
490 heller 1.204 ((:emacs-interrupt thread-id)
491     (interrupt-worker-thread thread-id))
492     (((:debug :debug-condition :debug-activate :debug-return)
493     thread &rest args)
494     (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
495 heller 1.112 ((:read-string thread &rest args)
496 heller 1.204 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
497 heller 1.112 ((:read-aborted thread &rest args)
498 heller 1.204 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
499     ((:emacs-return-string thread-id tag string)
500     (send (find-thread thread-id) `(take-input ,tag ,string)))
501 lgorrie 1.159 (((:read-output :new-package :new-features :ed :%apply :indentation-update)
502 heller 1.112 &rest _)
503     (declare (ignore _))
504 heller 1.204 (encode-message event socket-io))
505     ))
506 heller 1.112
507 heller 1.153 (defun spawn-threads-for-connection (connection)
508 heller 1.180 (let* ((socket-io (connection.socket-io connection))
509     (control-thread (spawn (lambda ()
510 heller 1.241 (setq *debugger-hook* nil)
511 heller 1.180 (dispatch-loop socket-io connection))
512     :name "control-thread")))
513     (setf (connection.control-thread connection) control-thread)
514     (let ((reader-thread (spawn (lambda ()
515 heller 1.241 (setq *debugger-hook* nil)
516 heller 1.180 (read-loop control-thread socket-io
517     connection))
518     :name "reader-thread"))
519     (repl-thread (spawn (lambda () (repl-loop connection))
520     :name "repl-thread")))
521     (setf (connection.reader-thread connection) reader-thread)
522     (setf (connection.repl-thread connection) repl-thread)
523     connection)))
524 heller 1.153
525 lgorrie 1.236 (defun cleanup-connection-threads (connection)
526     (kill-thread (connection.control-thread connection))
527     (kill-thread (connection.repl-thread connection)))
528    
529 lgorrie 1.173 (defun repl-loop (connection)
530     (with-connection (connection)
531 heller 1.180 (loop (handle-request connection))))
532 heller 1.112
533 heller 1.122 (defun process-available-input (stream fn)
534     (loop while (and (open-stream-p stream)
535     (listen stream))
536     do (funcall fn)))
537    
538 heller 1.123 ;;;;;; Signal driven IO
539    
540 heller 1.112 (defun install-sigio-handler (connection)
541     (let ((client (connection.socket-io connection)))
542 heller 1.134 (flet ((handler ()
543     (cond ((null *swank-state-stack*)
544     (with-reader-error-handler (connection)
545     (process-available-input
546     client (lambda () (handle-request connection)))))
547     ((eq (car *swank-state-stack*) :read-next-form))
548     (t (process-available-input client #'read-from-emacs)))))
549 heller 1.123 (add-sigio-handler client #'handler)
550 heller 1.122 (handler))))
551 heller 1.112
552 heller 1.123 (defun deinstall-sigio-handler (connection)
553     (remove-sigio-handlers (connection.socket-io connection)))
554    
555     ;;;;;; SERVE-EVENT based IO
556    
557     (defun install-fd-handler (connection)
558     (let ((client (connection.socket-io connection)))
559     (flet ((handler ()
560 heller 1.134 (cond ((null *swank-state-stack*)
561     (with-reader-error-handler (connection)
562     (process-available-input
563     client (lambda () (handle-request connection)))))
564     ((eq (car *swank-state-stack*) :read-next-form))
565     (t (process-available-input client #'read-from-emacs)))))
566 heller 1.123 (encode-message '(:use-sigint-for-interrupt) client)
567     (setq *debugger-hook*
568     (lambda (c h)
569 heller 1.134 (with-reader-error-handler (connection)
570 heller 1.123 (block debugger
571 heller 1.134 (with-connection (connection)
572 heller 1.123 (swank-debugger-hook c h)
573     (return-from debugger))
574     (abort)))))
575     (add-fd-handler client #'handler)
576     (handler))))
577    
578     (defun deinstall-fd-handler (connection)
579     (remove-fd-handlers (connection.socket-io connection)))
580    
581     ;;;;;; Simple sequential IO
582 heller 1.112
583     (defun simple-serve-requests (connection)
584     (let ((socket-io (connection.socket-io connection)))
585     (encode-message '(:use-sigint-for-interrupt) socket-io)
586     (with-reader-error-handler (connection)
587 heller 1.134 (loop (handle-request connection)))))
588 heller 1.112
589     (defun read-from-socket-io ()
590     (let ((event (decode-message (current-socket-io))))
591     (log-event "DISPATCHING: ~S~%" event)
592     (destructure-case event
593 heller 1.149 ((:emacs-rex form package thread id)
594 heller 1.113 (declare (ignore thread))
595 heller 1.149 `(eval-for-emacs ,form ,package ,id))
596 heller 1.112 ((:emacs-interrupt thread)
597 heller 1.113 (declare (ignore thread))
598 heller 1.112 '(simple-break))
599     ((:emacs-return-string thread tag string)
600 heller 1.113 (declare (ignore thread))
601 heller 1.112 `(take-input ,tag ,string)))))
602    
603     (defun send-to-socket-io (event)
604     (log-event "DISPATCHING: ~S~%" event)
605 heller 1.204 (flet ((send (o) (without-interrupts
606     (encode-message o (current-socket-io)))))
607 heller 1.112 (destructure-case event
608 heller 1.115 (((:debug-activate :debug :debug-return :read-string :read-aborted)
609     thread &rest args)
610 heller 1.112 (declare (ignore thread))
611     (send `(,(car event) 0 ,@args)))
612     ((:return thread &rest args)
613 heller 1.225 (declare (ignore thread))
614 heller 1.112 (send `(:return ,@args)))
615 lgorrie 1.157 (((:read-output :new-package :new-features :debug-condition
616     :indentation-update :ed :%apply)
617 heller 1.112 &rest _)
618     (declare (ignore _))
619     (send event)))))
620    
621 heller 1.180 (defun initialize-streams-for-connection (connection)
622     (multiple-value-bind (dedicated in out io) (open-streams connection)
623     (setf (connection.dedicated-output connection) dedicated
624     (connection.user-io connection) io
625     (connection.user-output connection) out
626     (connection.user-input connection) in)
627     connection))
628    
629     (defun create-connection (socket-io style)
630     (initialize-streams-for-connection
631     (ecase style
632     (:spawn
633     (make-connection :socket-io socket-io
634     :read #'read-from-control-thread
635     :send #'send-to-control-thread
636 lgorrie 1.236 :serve-requests #'spawn-threads-for-connection
637     :cleanup #'cleanup-connection-threads))
638 heller 1.180 (:sigio
639     (make-connection :socket-io socket-io
640     :read #'read-from-socket-io
641     :send #'send-to-socket-io
642     :serve-requests #'install-sigio-handler
643     :cleanup #'deinstall-sigio-handler))
644     (:fd-handler
645     (make-connection :socket-io socket-io
646     :read #'read-from-socket-io
647     :send #'send-to-socket-io
648     :serve-requests #'install-fd-handler
649     :cleanup #'deinstall-fd-handler))
650     ((nil)
651     (make-connection :socket-io socket-io
652     :read #'read-from-socket-io
653     :send #'send-to-socket-io
654     :serve-requests #'simple-serve-requests)))))
655    
656 lgorrie 1.80
657 lgorrie 1.62 ;;;; IO to Emacs
658     ;;;
659 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
660     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
661     ;;; contains the appropriate streams, so all we have to do is make the
662     ;;; right bindings.
663    
664     ;;;;; Global I/O redirection framework
665     ;;;
666     ;;; Optionally, the top-level global bindings of the standard streams
667     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
668     ;;; redirect the streams into the connection, and they keep going into
669     ;;; that connection even if more are established. If the connection
670     ;;; handling the streams closes then another is chosen, or if there
671     ;;; are no connections then we revert to the original (real) streams.
672     ;;;
673     ;;; It is slightly tricky to assign the global values of standard
674     ;;; streams because they are often shadowed by dynamic bindings. We
675     ;;; solve this problem by introducing an extra indirection via synonym
676     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
677     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
678     ;;; variables, so they can always be assigned to affect a global
679     ;;; change.
680    
681     (defvar *globally-redirect-io* nil
682     "When non-nil globally redirect all standard streams to Emacs.")
683    
684     (defmacro setup-stream-indirection (stream-var)
685     "Setup redirection scaffolding for a global stream variable.
686     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
687    
688     1. Saves the value of *STANDARD-INPUT* in a variable called
689     *REAL-STANDARD-INPUT*.
690    
691     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
692     *STANDARD-INPUT*.
693    
694     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
695     *CURRENT-STANDARD-INPUT*.
696    
697     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
698 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
699     the effective global value even when *STANDARD-INPUT* is shadowed by a
700     dynamic binding."
701 lgorrie 1.197 (let ((real-stream-var (prefixed-var "REAL" stream-var))
702     (current-stream-var (prefixed-var "CURRENT" stream-var)))
703     `(progn
704     ;; Save the real stream value for the future.
705     (defvar ,real-stream-var ,stream-var)
706     ;; Define a new variable for the effective stream.
707     ;; This can be reassigned.
708     (defvar ,current-stream-var ,stream-var)
709     ;; Assign the real binding as a synonym for the current one.
710     (setq ,stream-var (make-synonym-stream ',current-stream-var)))))
711    
712     (eval-when (:compile-toplevel :load-toplevel :execute)
713     (defun prefixed-var (prefix variable-symbol)
714 lgorrie 1.200 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
715 lgorrie 1.197 (let ((basename (subseq (symbol-name variable-symbol) 1)))
716 lgorrie 1.200 (intern (format nil "*~A-~A" prefix basename) :swank))))
717 lgorrie 1.199
718 lgorrie 1.197 ;;;;; Global redirection setup
719    
720     (setup-stream-indirection *standard-output*)
721     (setup-stream-indirection *error-output*)
722     (setup-stream-indirection *trace-output*)
723     (setup-stream-indirection *standard-input*)
724     (setup-stream-indirection *debug-io*)
725     (setup-stream-indirection *query-io*)
726     (setup-stream-indirection *terminal-io*)
727    
728     (defparameter *standard-output-streams*
729     '(*standard-output* *error-output* *trace-output*)
730     "The symbols naming standard output streams.")
731    
732     (defparameter *standard-input-streams*
733     '(*standard-input*)
734     "The symbols naming standard input streams.")
735    
736     (defparameter *standard-io-streams*
737     '(*debug-io* *query-io* *terminal-io*)
738     "The symbols naming standard io streams.")
739    
740     (defun globally-redirect-io-to-connection (connection)
741     "Set the standard I/O streams to redirect to CONNECTION.
742     Assigns *CURRENT-<STREAM>* for all standard streams."
743     (dolist (o *standard-output-streams*)
744     (set (prefixed-var "CURRENT" o)
745     (connection.user-output connection)))
746     ;; FIXME: If we redirect standard input to Emacs then we get the
747     ;; regular Lisp top-level trying to read from our REPL.
748     ;;
749     ;; Perhaps the ideal would be for the real top-level to run in a
750     ;; thread with local bindings for all the standard streams. Failing
751     ;; that we probably would like to inhibit it from reading while
752     ;; Emacs is connected.
753     ;;
754     ;; Meanwhile we just leave *standard-input* alone.
755     #+NIL
756     (dolist (i *standard-input-streams*)
757     (set (prefixed-var "CURRENT" i)
758     (connection.user-input connection)))
759     (dolist (io *standard-io-streams*)
760     (set (prefixed-var "CURRENT" io)
761     (connection.user-io connection))))
762    
763     (defun revert-global-io-redirection ()
764     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
765     (dolist (stream-var (append *standard-output-streams*
766     *standard-input-streams*
767     *standard-io-streams*))
768     (set (prefixed-var "CURRENT" stream-var)
769     (symbol-value (prefixed-var "REAL" stream-var)))))
770    
771     ;;;;; Global redirection hooks
772    
773     (defvar *global-stdio-connection* nil
774     "The connection to which standard I/O streams are globally redirected.
775     NIL if streams are not globally redirected.")
776    
777     (defun maybe-redirect-global-io (connection)
778     "Consider globally redirecting to a newly-established CONNECTION."
779     (when (and *globally-redirect-io* (null *global-stdio-connection*))
780     (setq *global-stdio-connection* connection)
781     (globally-redirect-io-to-connection connection)))
782    
783     (defun update-redirection-after-close (closed-connection)
784     "Update redirection after a connection closes."
785     (when (eq *global-stdio-connection* closed-connection)
786     (if (and (default-connection) *globally-redirect-io*)
787     ;; Redirect to another connection.
788     (globally-redirect-io-to-connection (default-connection))
789     ;; No more connections, revert to the real streams.
790     (progn (revert-global-io-redirection)
791     (setq *global-stdio-connection* nil)))))
792    
793     (add-hook *new-connection-hook* 'maybe-redirect-global-io)
794     (add-hook *connection-closed-hook* 'update-redirection-after-close)
795    
796     ;;;;; Redirection during requests
797     ;;;
798     ;;; We always redirect the standard streams to Emacs while evaluating
799     ;;; an RPC. This is done with simple dynamic bindings.
800 dbarlow 1.28
801 lgorrie 1.90 (defun call-with-redirected-io (connection function)
802     "Call FUNCTION with I/O streams redirected via CONNECTION."
803 heller 1.111 (declare (type function function))
804 lgorrie 1.90 (let* ((io (connection.user-io connection))
805     (in (connection.user-input connection))
806     (out (connection.user-output connection))
807     (*standard-output* out)
808     (*error-output* out)
809     (*trace-output* out)
810     (*debug-io* io)
811     (*query-io* io)
812     (*standard-input* in)
813     (*terminal-io* io))
814     (funcall function)))
815    
816 heller 1.155 (defvar *log-io* *terminal-io*)
817    
818 heller 1.87 (defun log-event (format-string &rest args)
819     "Write a message to *terminal-io* when *log-events* is non-nil.
820     Useful for low level debugging."
821     (when *log-events*
822 heller 1.155 (apply #'format *log-io* format-string args)))
823 heller 1.87
824 heller 1.112 (defun read-from-emacs ()
825 dbarlow 1.28 "Read and process a request from Emacs."
826 heller 1.112 (apply #'funcall (funcall (connection.read *emacs-connection*))))
827    
828     (defun read-from-control-thread ()
829     (receive))
830 heller 1.46
831 heller 1.112 (defun decode-message (stream)
832 lgorrie 1.90 "Read an S-expression from STREAM using the SLIME protocol.
833 lgorrie 1.212 If a protocol error occurs then a SLIME-PROTOCOL-ERROR is signalled."
834 heller 1.112 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
835     (flet ((next-byte () (char-code (read-char stream t))))
836     (handler-case
837     (let* ((length (logior (ash (next-byte) 16)
838     (ash (next-byte) 8)
839     (next-byte)))
840     (string (make-string length))
841     (pos (read-sequence string stream)))
842     (assert (= pos length) ()
843     "Short read: length=~D pos=~D" length pos)
844     (let ((form (read-form string)))
845     (log-event "READ: ~A~%" string)
846     form))
847     (serious-condition (c)
848 lgorrie 1.212 (error (make-condition 'slime-protocol-error :condition c)))))))
849 dbarlow 1.28
850     (defun read-form (string)
851     (with-standard-io-syntax
852     (let ((*package* *swank-io-package*))
853     (read-from-string string))))
854    
855 lgorrie 1.50 (defvar *slime-features* nil
856     "The feature list that has been sent to Emacs.")
857    
858 heller 1.112 (defun send-to-emacs (object)
859     "Send OBJECT to Emacs."
860     (funcall (connection.send *emacs-connection*) object))
861 dbarlow 1.28
862 lgorrie 1.104 (defun send-oob-to-emacs (object)
863 heller 1.112 (send-to-emacs object))
864    
865     (defun send-to-control-thread (object)
866     (send (connection.control-thread *emacs-connection*) object))
867    
868     (defun encode-message (message stream)
869     (let* ((string (prin1-to-string-for-emacs message))
870     (length (1+ (length string))))
871     (log-event "WRITE: ~A~%" string)
872 heller 1.204 (loop for position from 16 downto 0 by 8
873     do (write-char (code-char (ldb (byte 8 position) length))
874     stream))
875     (write-string string stream)
876     (terpri stream)
877     (force-output stream)))
878 lgorrie 1.104
879 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
880 heller 1.31 (with-standard-io-syntax
881     (let ((*print-case* :downcase)
882 heller 1.185 (*print-readably* nil)
883 heller 1.31 (*print-pretty* nil)
884     (*package* *swank-io-package*))
885     (prin1-to-string object))))
886 dbarlow 1.28
887 heller 1.112 (defun force-user-output ()
888     (force-output (connection.user-io *emacs-connection*))
889     (force-output (connection.user-output *emacs-connection*)))
890    
891     (defun clear-user-input ()
892     (clear-input (connection.user-input *emacs-connection*)))
893 lgorrie 1.62
894 lgorrie 1.91 (defvar *read-input-catch-tag* 0)
895    
896 heller 1.232 (defun intern-catch-tag (tag)
897     ;; fixnums aren't eq in ABCL, so we use intern to create tags
898     (intern (format nil "~D" tag) :swank))
899    
900 heller 1.112 (defun read-user-input-from-emacs ()
901 lgorrie 1.62 (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
902 heller 1.117 (force-output)
903 heller 1.112 (send-to-emacs `(:read-string ,(current-thread)
904     ,*read-input-catch-tag*))
905 lgorrie 1.90 (let ((ok nil))
906 lgorrie 1.62 (unwind-protect
907 heller 1.232 (prog1 (catch (intern-catch-tag *read-input-catch-tag*)
908 heller 1.112 (loop (read-from-emacs)))
909 lgorrie 1.62 (setq ok t))
910     (unless ok
911 heller 1.112 (send-to-emacs `(:read-aborted ,(current-thread)
912     *read-input-catch-tag*)))))))
913 lgorrie 1.90
914 lgorrie 1.62 (defslimefun take-input (tag input)
915 heller 1.147 "Return the string INPUT to the continuation TAG."
916 heller 1.232 (throw (intern-catch-tag tag) input))
917 heller 1.126
918     (defslimefun connection-info ()
919     "Return a list of the form:
920 heller 1.203 \(PID IMPLEMENTATION-TYPE IMPLEMENTATION-NAME FEATURES)."
921 lgorrie 1.194 (list (getpid)
922 heller 1.126 (lisp-implementation-type)
923     (lisp-implementation-type-name)
924     (setq *slime-features* *features*)))
925 lgorrie 1.62
926    
927     ;;;; Reading and printing
928 dbarlow 1.28
929 heller 1.207 (defmacro define-special (name doc)
930     "Define a special variable NAME with doc string DOC.
931 heller 1.232 This is like defvar, but NAME will not be initialized."
932 heller 1.207 `(progn
933     (defvar ,name)
934 heller 1.240 (setf (documentation ',name 'variable) ,doc)))
935 heller 1.207
936     (define-special *buffer-package*
937     "Package corresponding to slime-buffer-package.
938 dbarlow 1.28
939 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
940 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
941    
942 heller 1.207 (define-special *buffer-readtable*
943     "Readtable associated with the current buffer")
944 heller 1.189
945     (defmacro with-buffer-syntax ((&rest _) &body body)
946     "Execute BODY with appropriate *package* and *readtable* bindings.
947    
948     This should be used for code that is conceptionally executed in an
949     Emacs buffer."
950     (destructuring-bind () _
951 lgorrie 1.221 `(let ((*package* *buffer-package*))
952     ;; Don't shadow *readtable* unnecessarily because that prevents
953     ;; the user from assigning to it.
954     (if (eq *readtable* *buffer-readtable*)
955     #1=(call-with-syntax-hooks (lambda () ,@body))
956     (let ((*readtable* *buffer-readtable*))
957     #1#)))))
958 heller 1.189
959 dbarlow 1.28 (defun from-string (string)
960     "Read string in the *BUFFER-PACKAGE*"
961 heller 1.189 (with-buffer-syntax ()
962     (let ((*read-suppress* nil))
963     (read-from-string string))))
964 lgorrie 1.60
965 lgorrie 1.219 ;;; FIXME! FOO::BAR will intern FOO in BAR.
966 heller 1.207 (defun parse-symbol (string &optional (package *package*))
967 heller 1.189 "Find the symbol named STRING.
968 heller 1.207 Return the symbol and a flag indicateing if the symbols was found."
969 lgorrie 1.194 (multiple-value-bind (sym pos) (let ((*package* keyword-package))
970 heller 1.190 (ignore-errors (read-from-string string)))
971     (if (and (symbolp sym) (eql (length string) pos))
972 heller 1.207 (if (find #\: string)
973     (find-symbol (string sym) (symbol-package sym))
974     (find-symbol (string sym) package))
975 heller 1.189 (values nil nil))))
976    
977 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
978     (multiple-value-bind (symbol status) (parse-symbol string package)
979     (if status
980     (values symbol status)
981     (error "Unknown symbol: ~A [in ~A]" string package))))
982    
983 heller 1.189 (defun parse-package (string)
984     "Find the package named STRING.
985     Return the package or nil."
986 heller 1.196 (multiple-value-bind (name pos)
987 heller 1.190 (if (zerop (length string))
988     (values :|| 0)
989 lgorrie 1.194 (let ((*package* keyword-package))
990 heller 1.190 (ignore-errors (read-from-string string))))
991 heller 1.196 (if (and (or (keywordp name) (stringp name))
992     (= (length string) pos))
993     (find-package name))))
994 heller 1.190
995 dbarlow 1.28 (defun to-string (string)
996     "Write string in the *BUFFER-PACKAGE*."
997 heller 1.189 (with-buffer-syntax ()
998 dbarlow 1.28 (prin1-to-string string)))
999    
1000 heller 1.53 (defun guess-package-from-string (name &optional (default-package *package*))
1001 dbarlow 1.28 (or (and name
1002 heller 1.189 (or (parse-package name)
1003 heller 1.153 (find-package (string-upcase name))
1004 heller 1.189 (parse-package (substitute #\- #\! name))))
1005 heller 1.53 default-package))
1006 dbarlow 1.28
1007 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1008 heller 1.189 "An alist mapping package names to readtables.")
1009    
1010     (defun guess-buffer-readtable (package-name &optional (default *readtable*))
1011     (let ((package (guess-package-from-string package-name)))
1012     (if package
1013     (or (cdr (assoc (package-name package) *readtable-alist*
1014     :test #'string=))
1015     default)
1016     default)))
1017    
1018 heller 1.172 (defun valid-operator-name-p (string)
1019     "Test if STRING names a function, macro, or special-operator."
1020 heller 1.207 (let ((symbol (parse-symbol string)))
1021 heller 1.172 (or (fboundp symbol)
1022     (macro-function symbol)
1023     (special-operator-p symbol))))
1024    
1025     (defslimefun arglist-for-echo-area (names)
1026 heller 1.148 "Return the arglist for the first function, macro, or special-op in NAMES."
1027 heller 1.207 (with-buffer-syntax ()
1028     (let ((name (find-if #'valid-operator-name-p names)))
1029 lgorrie 1.217 (if name (format-arglist-for-echo-area (parse-symbol name) name)))))
1030 heller 1.172
1031     (defun format-arglist-for-echo-area (symbol name)
1032     "Return SYMBOL's arglist as string for display in the echo area.
1033     Use the string NAME as operator name."
1034     (let ((arglist (arglist symbol)))
1035     (etypecase arglist
1036     ((member :not-available)
1037 lgorrie 1.217 nil)
1038 heller 1.172 (list
1039     (arglist-to-string (cons name arglist)
1040     (symbol-package symbol))))))
1041 heller 1.135
1042 heller 1.172 (defun arglist-to-string (arglist package)
1043 heller 1.147 "Print the list ARGLIST for display in the echo area.
1044     The argument name are printed without package qualifiers and
1045     pretty printing of (function foo) as #'foo is suppressed."
1046 heller 1.172 (etypecase arglist
1047     (null "()")
1048     (cons
1049     (with-output-to-string (*standard-output*)
1050     (with-standard-io-syntax
1051     (let ((*package* package)
1052     (*print-case* :downcase)
1053     (*print-pretty* t)
1054     (*print-circle* nil)
1055 heller 1.185 (*print-readably* nil)
1056 heller 1.172 (*print-level* 10)
1057     (*print-length* 20))
1058     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1059     (loop
1060     (let ((arg (pop arglist)))
1061     (etypecase arg
1062     (symbol (princ arg))
1063     (string (princ arg))
1064     (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1065     (princ (car arg))
1066     (write-char #\space)
1067     (pprint-fill *standard-output* (cdr arg) nil))))
1068     (when (null arglist) (return))
1069     (write-char #\space)
1070     (pprint-newline :fill))))))))))
1071 heller 1.135
1072     (defun test-print-arglist (list string)
1073 heller 1.172 (string= (arglist-to-string list (find-package :swank)) string))
1074 heller 1.135
1075 heller 1.141 ;; Should work:
1076     (assert (test-print-arglist '(function cons) "(function cons)"))
1077     (assert (test-print-arglist '(quote cons) "(quote cons)"))
1078 heller 1.144 (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
1079 heller 1.141 ;; Expected failure:
1080 heller 1.135 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
1081 lgorrie 1.217
1082     (defslimefun variable-desc-for-echo-area (variable-name)
1083     "Return a short description of VARIABLE-NAME, or NIL."
1084     (with-buffer-syntax ()
1085     (let ((sym (parse-symbol variable-name)))
1086     (if (and sym (boundp sym))
1087 heller 1.222 (let ((*print-pretty* nil) (*print-level* 4)
1088     (*print-length* 10) (*print-circle* t))
1089     (format nil "~A => ~A" sym (symbol-value sym)))))))
1090 heller 1.72
1091 heller 1.172 (defslimefun arglist-for-insertion (name)
1092 heller 1.207 (with-buffer-syntax ()
1093     (cond ((valid-operator-name-p name)
1094     (let ((arglist (arglist (parse-symbol name))))
1095     (etypecase arglist
1096     ((member :not-available)
1097     " <not available>")
1098     (list
1099 lgorrie 1.210 (arglist-to-string arglist *buffer-package*)))))
1100 heller 1.207 (t
1101     " <not available>"))))
1102 heller 1.172
1103 lgorrie 1.62
1104 lgorrie 1.218 ;;;; Evaluation
1105    
1106     (defun eval-in-emacs (form)
1107     "Execute FORM in Emacs."
1108     (destructuring-bind (fn &rest args) form
1109     (send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args))))
1110    
1111     (defun guess-buffer-package (string)
1112     "Return a package for STRING.
1113     Fall back to the the current if no such package exists."
1114     (or (guess-package-from-string string nil)
1115     *package*))
1116    
1117     (defun eval-for-emacs (form buffer-package id)
1118     "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
1119     Return the result to the continuation ID.
1120     Errors are trapped and invoke our debugger."
1121     (let ((*debugger-hook* #'swank-debugger-hook))
1122     (let (ok result)
1123     (unwind-protect
1124     (let ((*buffer-package* (guess-buffer-package buffer-package))
1125     (*buffer-readtable* (guess-buffer-readtable buffer-package)))
1126     (assert (packagep *buffer-package*))
1127     (assert (readtablep *buffer-readtable*))
1128     (setq result (eval form))
1129     (force-output)
1130     (run-hook *pre-reply-hook*)
1131     (setq ok t))
1132     (force-user-output)
1133     (send-to-emacs `(:return ,(current-thread)
1134     ,(if ok `(:ok ,result) '(:abort))
1135     ,id))))))
1136    
1137     (defun format-values-for-echo-area (values)
1138     (with-buffer-syntax ()
1139     (let ((*print-readably* nil))
1140 heller 1.242 (cond ((null values) "; No value")
1141     ((and (null (cdr values)) (integerp (car values)))
1142     (let ((i (car values)))
1143     (format nil "~D (#x~X, #o~O, #b~B)" i i i i)))
1144     (t (format nil "~{~S~^, ~}" values))))))
1145 lgorrie 1.218
1146     (defslimefun interactive-eval (string)
1147     (with-buffer-syntax ()
1148     (let ((values (multiple-value-list (eval (read-from-string string)))))
1149     (fresh-line)
1150     (force-output)
1151     (format-values-for-echo-area values))))
1152    
1153     (defun eval-region (string &optional package-update-p)
1154     "Evaluate STRING and return the result.
1155     If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
1156     change, then send Emacs an update."
1157     (let (- values)
1158     (unwind-protect
1159     (with-input-from-string (stream string)
1160     (loop for form = (read stream nil stream)
1161     until (eq form stream)
1162     do (progn
1163     (setq - form)
1164     (setq values (multiple-value-list (eval form)))
1165     (force-output))
1166     finally (progn
1167     (fresh-line)
1168     (force-output)
1169     (return (values values -)))))
1170     (when (and package-update-p (not (eq *package* *buffer-package*)))
1171     (send-to-emacs
1172     (list :new-package (package-name *package*) (package-string-for-prompt *package*)))))))
1173    
1174     (defun package-string-for-prompt (package)
1175     "Return the shortest nickname (or canonical name) of PACKAGE."
1176     (or (canonical-package-nickname package)
1177     (auto-abbreviated-package-name package)
1178     (shortest-package-nickname package)))
1179    
1180     (defun canonical-package-nickname (package)
1181     "Return the canonical package nickname, if any, of PACKAGE."
1182     (cdr (assoc (package-name package) *canonical-packge-nicknames* :test #'string=)))
1183    
1184     (defun auto-abbreviated-package-name (package)
1185     "Return an abbreviated 'name' for PACKAGE. N.B. this is not an actual package name or nickname."
1186     (when *auto-abbreviate-dotted-packages*
1187     (let ((last-dot (position #\. (package-name package) :from-end t)))
1188     (when last-dot (subseq (package-name package) (1+ last-dot))))))
1189    
1190     (defun shortest-package-nickname (package)
1191     "Return the shortest nickname (or canonical name) of PACKAGE."
1192     (loop for name in (cons (package-name package) (package-nicknames package))
1193     for shortest = name then (if (< (length name) (length shortest))
1194     name
1195     shortest)
1196     finally (return shortest)))
1197    
1198    
1199     (defslimefun interactive-eval-region (string)
1200     (with-buffer-syntax ()
1201     (format-values-for-echo-area (eval-region string))))
1202    
1203     (defslimefun re-evaluate-defvar (form)
1204     (with-buffer-syntax ()
1205     (let ((form (read-from-string form)))
1206     (destructuring-bind (dv name &optional value doc) form
1207     (declare (ignore value doc))
1208     (assert (eq dv 'defvar))
1209     (makunbound name)
1210     (prin1-to-string (eval form))))))
1211    
1212     (defvar *swank-pprint-circle* *print-circle*
1213     "*PRINT-CIRCLE* is bound to this value when pretty printing slime output.")
1214    
1215     (defvar *swank-pprint-case* *print-case*
1216     "*PRINT-CASE* is bound to this value when pretty printing slime output.")
1217    
1218     (defvar *swank-pprint-right-margin* *print-right-margin*
1219     "*PRINT-RIGHT-MARGIN* is bound to this value when pretty printing slime output.")
1220    
1221     (defvar *swank-pprint-escape* *print-escape*
1222     "*PRINT-ESCAPE* is bound to this value when pretty printing slime output.")
1223    
1224     (defvar *swank-pprint-level* *print-level*
1225     "*PRINT-LEVEL* is bound to this value when pretty printing slime output.")
1226    
1227     (defvar *swank-pprint-length* *print-length*
1228     "*PRINT-LENGTH* is bound to this value when pretty printing slime output.")
1229    
1230     (defun swank-pprint (list)
1231     "Bind some printer variables and pretty print each object in LIST."
1232     (with-buffer-syntax ()
1233     (let ((*print-pretty* t)
1234     (*print-case* *swank-pprint-case*)
1235     (*print-right-margin* *swank-pprint-right-margin*)
1236     (*print-circle* *swank-pprint-circle*)
1237     (*print-escape* *swank-pprint-escape*)
1238     (*print-level* *swank-pprint-level*)
1239     (*print-length* *swank-pprint-length*))
1240     (cond ((null list) "; No value")
1241     (t (with-output-to-string (*standard-output*)
1242     (dolist (o list)
1243     (pprint o)
1244     (terpri))))))))
1245    
1246     (defslimefun pprint-eval (string)
1247     (with-buffer-syntax ()
1248     (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1249    
1250     (defslimefun set-package (package)
1251 heller 1.243 "Set *package* to PACKAGE.
1252     Return its name and the string to use in the prompt."
1253 lgorrie 1.218 (let ((p (setq *package* (guess-package-from-string package))))
1254     (list (package-name p) (package-string-for-prompt p))))
1255    
1256     (defslimefun listener-eval (string)
1257     (clear-user-input)
1258     (with-buffer-syntax ()
1259     (multiple-value-bind (values last-form) (eval-region string t)
1260     (setq +++ ++ ++ + + last-form
1261     *** ** ** * * (car values)
1262     /// // // / / values)
1263     (cond ((null values) "; No value")
1264     (t
1265     (format nil "~{~S~^~%~}" values))))))
1266    
1267     (defslimefun ed-in-emacs (&optional what)
1268     "Edit WHAT in Emacs.
1269    
1270     WHAT can be:
1271     A filename (string),
1272     A list (FILENAME LINE [COLUMN]),
1273     A function name (symbol),
1274     nil."
1275     (let ((target
1276     (cond ((and (listp what) (pathnamep (first what)))
1277     (cons (canonicalize-filename (car what)) (cdr what)))
1278     ((pathnamep what)
1279     (canonicalize-filename what))
1280     (t what))))
1281     (send-oob-to-emacs `(:ed ,target))))
1282    
1283    
1284 lgorrie 1.62 ;;;; Debugger
1285 heller 1.47
1286 heller 1.38 (defun swank-debugger-hook (condition hook)
1287 lgorrie 1.177 "Debugger function for binding *DEBUGGER-HOOK*.
1288 lgorrie 1.62 Sends a message to Emacs declaring that the debugger has been entered,
1289     then waits to handle further requests from Emacs. Eventually returns
1290     after Emacs causes a restart to be invoked."
1291 heller 1.67 (declare (ignore hook))
1292 lgorrie 1.157 (flet ((debug-it () (debug-in-emacs condition)))
1293     (cond (*emacs-connection*
1294     (debug-it))
1295     ((default-connection)
1296     (with-connection ((default-connection))
1297     (debug-in-emacs condition))))))
1298 lgorrie 1.223
1299     (defvar *global-debugger* t
1300     "Non-nil means the Swank debugger hook will be installed globally.")
1301    
1302     (add-hook *new-connection-hook* 'install-debugger)
1303     (defun install-debugger (connection)
1304     (declare (ignore connection))
1305     (when *global-debugger*
1306     (setq *debugger-hook* #'swank-debugger-hook)))
1307 lgorrie 1.157
1308 lgorrie 1.212 ;;;;; Debugger loop
1309     ;;;
1310     ;;; These variables are dynamically bound during debugging.
1311     ;;;
1312     (defvar *swank-debugger-condition* nil
1313     "The condition being debugged.")
1314    
1315     (defvar *sldb-level* 0
1316     "The current level of recursive debugging.")
1317    
1318     (defvar *sldb-initial-frames* 20
1319     "The initial number of backtrace frames to send to Emacs.")
1320    
1321     (defvar *sldb-restarts* nil
1322     "The list of currenlty active restarts.")
1323    
1324 lgorrie 1.157 (defun debug-in-emacs (condition)
1325 heller 1.38 (let ((*swank-debugger-condition* condition)
1326 heller 1.138 (*sldb-restarts* (compute-restarts condition))
1327 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
1328     (symbol-value '*buffer-package*))
1329 heller 1.112 *package*))
1330     (*sldb-level* (1+ *sldb-level*))
1331 heller 1.138 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))
1332     (*print-readably* nil))
1333 lgorrie 1.157 (force-user-output)
1334     (call-with-debugging-environment
1335     (lambda () (sldb-loop *sldb-level*)))))
1336 lgorrie 1.80
1337 lgorrie 1.62 (defun sldb-loop (level)
1338 heller 1.119 (unwind-protect
1339     (catch 'sldb-enter-default-debugger
1340     (send-to-emacs
1341     (list* :debug (current-thread) *sldb-level*
1342     (debugger-info-for-emacs 0 *sldb-initial-frames*)))
1343 heller 1.117 (loop (catch 'sldb-loop-catcher
1344     (with-simple-restart (abort "Return to sldb level ~D." level)
1345     (send-to-emacs (list :debug-activate (current-thread)
1346     *sldb-level*))
1347     (handler-bind ((sldb-condition #'handle-sldb-condition))
1348 heller 1.119 (read-from-emacs))))))
1349     (send-to-emacs `(:debug-return ,(current-thread) ,level))))
1350 heller 1.117
1351 lgorrie 1.62 (defun handle-sldb-condition (condition)
1352     "Handle an internal debugger condition.
1353     Rather than recursively debug the debugger (a dangerous idea!), these
1354     conditions are simply reported."
1355     (let ((real-condition (original-condition condition)))
1356 heller 1.115 (send-to-emacs `(:debug-condition ,(current-thread)
1357     ,(princ-to-string real-condition))))
1358 lgorrie 1.62 (throw 'sldb-loop-catcher nil))
1359    
1360 heller 1.86 (defun safe-condition-message (condition)
1361     "Safely print condition to a string, handling any errors during
1362     printing."
1363 heller 1.147 (let ((*print-pretty* t))
1364     (handler-case
1365 lgorrie 1.188 (format-sldb-condition condition)
1366 heller 1.147 (error (cond)
1367     ;; Beware of recursive errors in printing, so only use the condition
1368     ;; if it is printable itself:
1369     (format nil "Unable to display error condition~@[: ~A~]"
1370     (ignore-errors (princ-to-string cond)))))))
1371 heller 1.86
1372     (defun debugger-condition-for-emacs ()
1373     (list (safe-condition-message *swank-debugger-condition*)
1374     (format nil " [Condition of type ~S]"
1375 lgorrie 1.188 (type-of *swank-debugger-condition*))
1376 heller 1.240 (condition-references *swank-debugger-condition*)
1377     (condition-extras *swank-debugger-condition*)))
1378 heller 1.86
1379 heller 1.138 (defun format-restarts-for-emacs ()
1380     "Return a list of restarts for *swank-debugger-condition* in a
1381     format suitable for Emacs."
1382     (loop for restart in *sldb-restarts*
1383     collect (list (princ-to-string (restart-name restart))
1384     (princ-to-string restart))))
1385    
1386     (defun frame-for-emacs (n frame)
1387 heller 1.86 (let* ((label (format nil " ~D: " n))
1388     (string (with-output-to-string (stream)
1389 heller 1.116 (let ((*print-pretty* *sldb-pprint-frames*)
1390     (*print-circle* t))
1391 heller 1.138 (princ label stream)
1392     (print-frame frame stream)))))
1393 heller 1.86 (subseq string (length label))))
1394    
1395 lgorrie 1.212 ;;;;; SLDB entry points
1396    
1397     (defslimefun sldb-break-with-default-debugger ()
1398     "Invoke the default debugger by returning from our debugger-loop."
1399     (throw 'sldb-enter-default-debugger nil))
1400    
1401 heller 1.138 (defslimefun backtrace (start end)
1402 heller 1.147 "Return a list ((I FRAME) ...) of frames from START to END.
1403     I is an integer describing and FRAME a string."
1404 heller 1.138 (loop for frame in (compute-backtrace start end)
1405     for i from start
1406     collect (list i (frame-for-emacs i frame))))
1407    
1408     (defslimefun debugger-info-for-emacs (start end)
1409     "Return debugger state, with stack frames from START to END.
1410     The result is a list:
1411     (condition ({restart}*) ({stack-frame}*)
1412     where
1413 heller 1.240 condition ::= (description type [extra])
1414 heller 1.138 restart ::= (name description)
1415     stack-frame ::= (number description)
1416 heller 1.240 extra ::= (:references
1417     condition---a pair of strings: message, and type. If show-source is
1418     not nil it is a frame number for which the source should be displayed.
1419 heller 1.138
1420     restart---a pair of strings: restart name, and description.
1421    
1422     stack-frame---a number from zero (the top), and a printed
1423     representation of the frame's call.
1424    
1425     Below is an example return value. In this case the condition was a
1426     division by zero (multi-line description), and only one frame is being
1427     fetched (start=0, end=1).
1428    
1429     ((\"Arithmetic error DIVISION-BY-ZERO signalled.
1430     Operation was KERNEL::DIVISION, operands (1 0).\"
1431     \"[Condition of type DIVISION-BY-ZERO]\")
1432     ((\"ABORT\" \"Return to Slime toplevel.\")
1433     (\"ABORT\" \"Return to Top-Level.\"))
1434     ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))"
1435     (list (debugger-condition-for-emacs)
1436     (format-restarts-for-emacs)
1437     (backtrace start end)))
1438    
1439     (defun nth-restart (index)
1440     (nth index *sldb-restarts*))
1441    
1442     (defslimefun invoke-nth-restart (index)
1443     (invoke-restart-interactively (nth-restart index)))
1444    
1445     (defslimefun sldb-abort ()
1446     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1447    
1448 lgorrie 1.62 (defslimefun sldb-continue ()
1449 heller 1.79 (continue))
1450 lgorrie 1.64
1451 heller 1.142 (defslimefun throw-to-toplevel ()
1452 lgorrie 1.194 "Use THROW to abort an RPC from Emacs.
1453     If we are not evaluating an RPC then ABORT instead."
1454     (ignore-errors (throw 'slime-toplevel nil))
1455     ;; If we get here then there was no catch. Try aborting as a fallback.
1456     ;; That makes the 'q' command in SLDB safer to use with threads.
1457     (abort))
1458 heller 1.142
1459 lgorrie 1.84 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
1460     "Invoke the Nth available restart.
1461     SLDB-LEVEL is the debug level when the request was made. If this
1462     has changed, ignore the request."
1463     (when (= sldb-level *sldb-level*)
1464     (invoke-nth-restart n)))
1465    
1466 lgorrie 1.64 (defslimefun eval-string-in-frame (string index)
1467 lgorrie 1.65 (to-string (eval-in-frame (from-string string) index)))
1468 lgorrie 1.62
1469 heller 1.138 (defslimefun pprint-eval-string-in-frame (string index)
1470     (swank-pprint
1471     (multiple-value-list
1472 heller 1.156 (eval-in-frame (from-string string) index))))
1473 heller 1.138
1474 heller 1.147 (defslimefun frame-locals-for-emacs (index)
1475     "Return a property list ((&key NAME ID VALUE) ...) describing
1476     the local variables in the frame INDEX."
1477 heller 1.242 (let* ((*print-readably* nil)
1478     (*print-pretty* *sldb-pprint-frames*)
1479     (*print-circle* t)
1480     (*package* (or (frame-package index) *package*)))
1481 heller 1.137 (mapcar (lambda (frame-locals)
1482     (destructuring-bind (&key name id value) frame-locals
1483 heller 1.242 (list :name (prin1-to-string name) :id id
1484 heller 1.137 :value (to-string value))))
1485 heller 1.147 (frame-locals index))))
1486 mbaringer 1.136
1487 heller 1.138 (defslimefun frame-catch-tags-for-emacs (frame-index)
1488 heller 1.147 (mapcar #'to-string (frame-catch-tags frame-index)))
1489 heller 1.139
1490     (defslimefun sldb-disassemble (index)
1491     (with-output-to-string (*standard-output*)
1492     (disassemble-frame index)))
1493 heller 1.138
1494 heller 1.147 (defslimefun sldb-return-from-frame (index string)
1495     (let ((form (from-string string)))
1496     (to-string (multiple-value-list (return-from-frame index form)))))
1497 heller 1.240
1498     (defslimefun sldb-break (name)
1499     (with-buffer-syntax ()
1500     (sldb-break-at-start (read-from-string name))))
1501 lgorrie 1.173
1502 lgorrie 1.62
1503 dbarlow 1.29 ;;;; Compilation Commands.
1504    
1505     (defvar *compiler-notes* '()
1506     "List of compiler notes for the last compilation unit.")
1507    
1508     (defun clear-compiler-notes ()
1509 lgorrie 1.61 (setf *compiler-notes* '()))
1510 dbarlow 1.29
1511     (defun canonicalize-filename (filename)
1512     (namestring (truename filename)))
1513    
1514 heller 1.31 (defslimefun compiler-notes-for-emacs ()
1515     "Return the list of compiler notes for the last compilation unit."
1516     (reverse *compiler-notes*))
1517    
1518 dbarlow 1.29 (defun measure-time-interval (fn)
1519     "Call FN and return the first return value and the elapsed time.
1520     The time is measured in microseconds."
1521 heller 1.111 (declare (type function fn))
1522 dbarlow 1.29 (let ((before (get-internal-real-time)))
1523     (values
1524     (funcall fn)
1525     (* (- (get-internal-real-time) before)
1526     (/ 1000000 internal-time-units-per-second)))))
1527    
1528 lgorrie 1.61 (defun record-note-for-condition (condition)
1529     "Record a note for a compiler-condition."
1530     (push (make-compiler-note condition) *compiler-notes*))
1531    
1532     (defun make-compiler-note (condition)
1533     "Make a compiler note data structure from a compiler-condition."
1534     (declare (type compiler-condition condition))
1535 heller 1.121 (list* :message (message condition)
1536     :severity (severity condition)
1537     :location (location condition)
1538 crhodes 1.213 :references (references condition)
1539 heller 1.121 (let ((s (short-message condition)))
1540     (if s (list :short-message s)))))
1541 lgorrie 1.32
1542 dbarlow 1.78 (defun swank-compiler (function)
1543 lgorrie 1.61 (clear-compiler-notes)
1544 lgorrie 1.186 (with-simple-restart (abort "Abort SLIME compilation.")
1545     (multiple-value-bind (result usecs)
1546     (handler-bind ((compiler-condition #'record-note-for-condition))
1547     (measure-time-interval function))
1548     (list (to-string result)
1549     (format nil "~,2F" (/ usecs 1000000.0))))))
1550 lgorrie 1.61
1551 heller 1.138 (defslimefun compile-file-for-emacs (filename load-p)
1552 dbarlow 1.78 "Compile FILENAME and, when LOAD-P, load the result.
1553     Record compiler notes signalled as `compiler-condition's."
1554 heller 1.228 (with-buffer-syntax ()
1555     (swank-compiler (lambda () (swank-compile-file filename load-p)))))
1556 dbarlow 1.78
1557 pseibel 1.224 (defslimefun compile-string-for-emacs (string buffer position directory)
1558 lgorrie 1.62 "Compile STRING (exerpted from BUFFER at POSITION).
1559     Record compiler notes signalled as `compiler-condition's."
1560 heller 1.189 (with-buffer-syntax ()
1561     (swank-compiler
1562     (lambda ()
1563 heller 1.225 (swank-compile-string string :buffer buffer :position position
1564     :directory directory)))))
1565 dbarlow 1.78
1566 lgorrie 1.167 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
1567 dbarlow 1.78 "Compile and load SYSTEM using ASDF.
1568     Record compiler notes signalled as `compiler-condition's."
1569 heller 1.171 (swank-compiler
1570     (lambda ()
1571     (apply #'operate-on-system system-name operation keywords))))
1572 dbarlow 1.78
1573 heller 1.171 (defun asdf-central-registry ()
1574     (when (find-package :asdf)
1575     (symbol-value (find-symbol (string :*central-registry*) :asdf))))
1576    
1577     (defslimefun list-all-systems-in-central-registry ()
1578     "Returns a list of all systems in ASDF's central registry."
1579     (loop for dir in (asdf-central-registry)
1580     for defaults = (eval dir)
1581     when defaults
1582     nconc (mapcar #'file-namestring
1583     (directory
1584     (make-pathname :defaults defaults
1585     :version :newest
1586     :type "asd"
1587 lgorrie 1.183 :name :wild
1588 heller 1.171 :case :local)))))
1589 heller 1.195
1590     (defun file-newer-p (new-file old-file)
1591     "Returns true if NEW-FILE is newer than OLD-FILE."
1592     (> (file-write-date new-file) (file-write-date old-file)))
1593    
1594     (defun requires-compile-p (source-file)
1595     (let ((fasl-file (probe-file (compile-file-pathname source-file))))
1596     (or (not fasl-file)
1597     (file-newer-p source-file fasl-file))))
1598    
1599     (defslimefun compile-file-if-needed (filename loadp)
1600     (cond ((requires-compile-p filename)
1601     (compile-file-for-emacs filename loadp))
1602     (loadp
1603     (load (compile-file-pathname filename))
1604     nil)))
1605    
1606    
1607     ;;;; Loading
1608    
1609     (defslimefun load-file (filename)
1610     (to-string (load filename)))
1611 heller 1.243
1612     (defslimefun load-file-set-package (filename &optional package)
1613     (load-file filename)
1614     (if package
1615     (set-package package)))
1616 heller 1.195
1617 lgorrie 1.62
1618 lgorrie 1.70 ;;;; Macroexpansion
1619 dbarlow 1.29
1620     (defun apply-macro-expander (expander string)
1621 heller 1.111 (declare (type function expander))
1622 heller 1.242 (with-buffer-syntax ()
1623     (swank-pprint (list (funcall expander (from-string string))))))
1624 dbarlow 1.29
1625     (defslimefun swank-macroexpand-1 (string)
1626     (apply-macro-expander #'macroexpand-1 string))
1627    
1628     (defslimefun swank-macroexpand (string)
1629     (apply-macro-expander #'macroexpand string))
1630    
1631 lgorrie 1.61 (defslimefun swank-macroexpand-all (string)
1632     (apply-macro-expander #'macroexpand-all string))
1633    
1634 heller 1.155 (defslimefun disassemble-symbol (name)
1635 heller 1.242 (with-buffer-syntax ()
1636     (with-output-to-string (*standard-output*)
1637     (let ((*print-readably* nil))
1638     (disassemble (fdefinition (from-string name)))))))
1639 heller 1.138
1640 lgorrie 1.62
1641 lgorrie 1.212 ;;;; Basic completion
1642 heller 1.38
1643 lgorrie 1.212 (defslimefun completions (string default-package-name)
1644     "Return a list of completions for a symbol designator STRING.
1645 heller 1.149
1646 lgorrie 1.212 The result is the list (COMPLETION-SET
1647     COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
1648     completions, and COMPLETED-PREFIX is the best (partial)
1649     completion of the input string.
1650 heller 1.108
1651 lgorrie 1.212 If STRING is package qualified the result list will also be
1652     qualified. If string is non-qualified the result strings are
1653     also not qualified and are considered relative to
1654     DEFAULT-PACKAGE-NAME.
1655 heller 1.130
1656 lgorrie 1.212 The way symbols are matched depends on the symbol designator's
1657     format. The cases are as follows:
1658     FOO - Symbols with matching prefix and accessible in the buffer package.
1659     PKG:FOO - Symbols with matching prefix and external in package PKG.
1660     PKG::FOO - Symbols with matching prefix and accessible in package PKG."
1661     (let ((completion-set (completion-set string default-package-name
1662     #'compound-prefix-match)))
1663     (list completion-set (longest-completion completion-set))))
1664 lgorrie 1.202
1665 lgorrie 1.212 (defslimefun simple-completions (string default-package-name)
1666     "Return a list of completions for a symbol designator STRING."
1667     (let ((completion-set (completion-set string default-package-name
1668     #'prefix-match-p)))
1669     (list completion-set (longest-common-prefix completion-set))))
1670 heller 1.130
1671 lgorrie 1.212 ;;;;; Find completion set
1672 lgorrie 1.162
1673 heller 1.130 (defun completion-set (string default-package-name matchp)
1674 lgorrie 1.212 "Return the set of completion-candidates as strings."
1675 heller 1.130 (multiple-value-bind (name package-name package internal-p)
1676     (parse-completion-arguments string default-package-name)
1677 heller 1.149 (let* ((symbols (and package
1678     (find-matching-symbols name
1679     package
1680     (and (not internal-p)
1681     package-name)
1682     matchp)))
1683 lgorrie 1.162 (packs (and (not package-name)
1684     (find-matching-packages name matchp)))
1685 heller 1.149 (converter (output-case-converter name))
1686 lgorrie 1.162 (strings
1687     (mapcar converter
1688     (nconc (mapcar #'symbol-name symbols) packs))))
1689 heller 1.149 (format-completion-set strings internal-p package-name))))
1690 heller 1.130
1691 lgorrie 1.212 (defun find-matching-symbols (string package external test)
1692     "Return a list of symbols in PACKAGE matching STRING.
1693     TEST is called with two strings. If EXTERNAL is true, only external
1694 lgorrie 1.202 symbols are returned."
1695     (let ((completions '())
1696     (converter (output-case-converter string)))
1697 lgorrie 1.212 (flet ((symbol-matches-p (symbol)
1698 lgorrie 1.202 (and (or (not external)
1699     (symbol-external-p symbol package))
1700 lgorrie 1.212 (funcall test string
1701     (funcall converter (symbol-name symbol))))))
1702 lgorrie 1.202 (do-symbols (symbol package)
1703 lgorrie 1.212 (when (symbol-matches-p symbol)
1704     (push symbol completions))))
1705     (remove-duplicates completions)))
1706    
1707     (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
1708     "True if SYMBOL is external in PACKAGE.
1709     If PACKAGE is not specified, the home package of SYMBOL is used."
1710     (multiple-value-bind (_ status)
1711     (find-symbol (symbol-name symbol) (or package (symbol-package symbol)))
1712     (declare (ignore _))
1713     (eq status :external)))
1714    
1715     (defun find-matching-packages (name matcher)
1716     "Return a list of package names matching NAME with MATCHER.
1717     MATCHER is a two-argument predicate."
1718     (let ((to-match (string-upcase name)))
1719     (remove-if-not (lambda (x) (funcall matcher to-match x))
1720     (mapcar (lambda (pkgname)
1721     (concatenate 'string pkgname ":"))
1722     (mapcar #'package-name (list-all-packages))))))
1723 lgorrie 1.202
1724 lgorrie 1.212 (defun parse-completion-arguments (string default-package-name)
1725     "Parse STRING as a symbol designator.
1726     Return these values:
1727     SYMBOL-NAME
1728     PACKAGE-NAME, or nil if the designator does not include an explicit package.
1729     PACKAGE, the package to complete in
1730     INTERNAL-P, if the symbol is qualified with `::'."
1731     (multiple-value-bind (name package-name internal-p)
1732     (tokenize-symbol-designator string)
1733     (let ((package (carefully-find-package package-name default-package-name)))
1734     (values name package-name package internal-p))))
1735 lgorrie 1.202
1736 lgorrie 1.212 (defun tokenize-symbol-designator (string)
1737     (values (let ((pos (position #\: string :from-end t)))
1738     (if pos (subseq string (1+ pos)) string))
1739     (let ((pos (position #\: string)))
1740     (if pos (subseq string 0 pos) nil))
1741     (search "::" string)))
1742 lgorrie 1.202
1743 lgorrie 1.212 (defun carefully-find-package (name default-package-name)
1744     "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
1745     *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil."
1746     (let ((string (cond ((equal name "") "KEYWORD")
1747     (t (or name default-package-name)))))
1748 lgorrie 1.220 (if string
1749     (guess-package-from-string string nil)
1750     *buffer-package*)))
1751 heller 1.38
1752 lgorrie 1.212 ;;;;; Format completion results
1753     ;;;
1754     ;;; We try to format results in the case as inputs. If you complete
1755     ;;; `FOO' then your result should include `FOOBAR' rather than
1756     ;;; `foobar'.
1757 lgorrie 1.70
1758 lgorrie 1.212 (defun format-completion-set (strings internal-p package-name)
1759     "Format a set of completion strings.
1760     Returns a list of completions with package qualifiers if needed."
1761     (mapcar (lambda (string)
1762     (format-completion-result string internal-p package-name))
1763     (sort strings #'string<)))
1764 lgorrie 1.42
1765 lgorrie 1.212 (defun format-completion-result (string internal-p package-name)
1766     (let ((prefix (cond (internal-p (format nil "~A::" package-name))
1767     (package-name (format nil "~A:" package-name))
1768     (t ""))))
1769     (values (concatenate 'string prefix string)
1770     (length prefix))))
1771 heller 1.130
1772 lgorrie 1.212 (defun output-case-converter (input)
1773     "Return a function to case convert strings for output.
1774     INPUT is used to guess the preferred case."
1775     (ecase (readtable-case *readtable*)
1776     (:upcase (if (some #'lower-case-p input) #'string-downcase #'identity))
1777     (:invert (lambda (output)
1778     (multiple-value-bind (lower upper) (determine-case output)
1779     (cond ((and lower upper) output)
1780     (lower (string-upcase output))
1781     (upper (string-downcase output))
1782     (t output)))))
1783     (:downcase (if (some #'upper-case-p input) #'string-upcase #'identity))
1784     (:preserve #'identity)))
1785    
1786     (defun determine-case (string)
1787     "Return two booleans LOWER and UPPER indicating whether STRING
1788     contains lower or upper case characters."
1789     (values (some #'lower-case-p string)
1790     (some #'upper-case-p string)))
1791    
1792    
1793     ;;;;; Compound-prefix matching
1794    
1795     (defun compound-prefix-match (prefix target)
1796     "Return true if PREFIX is a compound-prefix of TARGET.
1797     Viewing each of PREFIX and TARGET as a series of substrings delimited
1798     by hyphens, if each substring of PREFIX is a prefix of the
1799     corresponding substring in TARGET then we call PREFIX a
1800     compound-prefix of TARGET.
1801    
1802     Examples:
1803     \(compound-prefix-match \"foo\" \"foobar\") => t
1804     \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
1805     \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
1806     (declare (type simple-string prefix target))
1807     (loop for ch across prefix
1808     with tpos = 0
1809     always (and (< tpos (length target))
1810     (if (char= ch #\-)
1811     (setf tpos (position #\- target :start tpos))
1812     (char= ch (aref target tpos))))
1813     do (incf tpos)))
1814    
1815     (defun prefix-match-p (prefix string)
1816     "Return true if PREFIX is a prefix of STRING."
1817     (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
1818    
1819    
1820     ;;;;; Extending the input string by completion
1821    
1822     (defun longest-completion (completions)
1823     "Return the longest prefix for all COMPLETIONS.
1824     COMPLETIONS is a list of strings."
1825     (untokenize-completion
1826     (mapcar #'longest-common-prefix
1827     (transpose-lists (mapcar #'tokenize-completion completions)))))
1828    
1829     (defun tokenize-completion (string)
1830     "Return all substrings of STRING delimited by #\-."
1831     (loop with end
1832     for start = 0 then (1+ end)
1833     until (> start (length string))
1834     do (setq end (or (position #\- string :start start) (length string)))
1835     collect (subseq string start end)))
1836    
1837     (defun untokenize-completion (tokens)
1838     (format nil "~{~A~^-~}" tokens))
1839    
1840     (defun longest-common-prefix (strings)
1841     "Return the longest string that is a common prefix of STRINGS."
1842     (if (null strings)
1843     ""
1844     (flet ((common-prefix (s1 s2)
1845     (let ((diff-pos (mismatch s1 s2)))
1846     (if diff-pos (subseq s1 0 diff-pos) s1))))
1847     (reduce #'common-prefix strings))))
1848    
1849     (defun transpose-lists (lists)
1850     "Turn a list-of-lists on its side.
1851     If the rows are of unequal length, truncate uniformly to the shortest.
1852    
1853     For example:
1854     \(transpose-lists '((ONE TWO THREE) (1 2)))
1855     => ((ONE 1) (TWO 2))"
1856     ;; A cute function from PAIP p.574
1857     (if lists (apply #'mapcar #'list lists)))
1858    
1859    
1860     ;;;;; Completion Tests
1861    
1862     (defpackage :swank-completion-test
1863     (:use))
1864    
1865     (let ((*readtable* (copy-readtable *readtable*))
1866     (p (find-package :swank-completion-test)))
1867     (intern "foo" p)
1868     (intern "Foo" p)
1869     (intern "FOO" p)
1870     (setf (readtable-case *readtable*) :invert)
1871     (flet ((names (prefix)
1872     (sort (mapcar #'symbol-name
1873     (find-matching-symbols prefix p nil #'prefix-match-p))
1874     #'string<)))
1875     (assert (equal '("FOO") (names "f")))
1876     (assert (equal '("Foo" "foo") (names "F")))
1877     (assert (equal '("Foo") (names "Fo")))
1878     (assert (equal '("foo") (names "FO")))))
1879    
1880     ;;;; Fuzzy completion
1881 heller 1.38
1882 lgorrie 1.202 (defslimefun fuzzy-completions (string default-package-name &optional limit)
1883     "Return an (optionally limited to LIMIT best results) list of
1884     fuzzy completions for a symbol designator STRING. The list will
1885     be sorted by score, most likely match first.
1886    
1887     The result is a list of completion objects, where a completion
1888     object is:
1889     (COMPLETED-STRING SCORE (&rest CHUNKS))
1890     where a CHUNK is a description of a matched string of characters:
1891     (OFFSET STRING)
1892     For example, the top result for completing \"mvb\" in a package
1893     that uses COMMON-LISP would be something like:
1894     (\"multiple-value-bind\" 42.391666 ((0 \"mul\") (9 \"v\") (15 \"b\")))
1895    
1896     If STRING is package qualified the result list will also be
1897     qualified. If string is non-qualified the result strings are
1898     also not qualified and are considered relative to
1899     DEFAULT-PACKAGE-NAME.
1900    
1901     Which symbols are candidates for matching depends on the symbol
1902     designator's format. The cases are as follows:
1903     FOO - Symbols accessible in the buffer package.
1904     PKG:FOO - Symbols external in package PKG.
1905     PKG::FOO - Symbols accessible in package PKG."
1906     (fuzzy-completion-set string default-package-name limit))
1907    
1908 lgorrie 1.212 (defun fuzzy-completion-set (string default-package-name &optional limit)
1909     "Prepares list of completion objects, sorted by SCORE, of fuzzy
1910     completions of STRING in DEFAULT-PACKAGE-NAME. If LIMIT is set,
1911     only the top LIMIT results will be returned."
1912     (multiple-value-bind (name package-name package internal-p)
1913     (parse-completion-arguments string default-package-name)
1914     (let* ((symbols (and package
1915     (fuzzy-find-matching-symbols name
1916     package
1917     (and (not internal-p)
1918     package-name))))
1919     (packs (and (not package-name)
1920     (fuzzy-find-matching-packages name)))
1921     (converter (output-case-converter name))
1922     (results
1923     (sort (mapcar
1924     #'(lambda (result)
1925     (destructuring-bind (symbol-or-name score chunks) result
1926     (multiple-value-bind (name added-length)
1927     (format-completion-result
1928     (funcall converter
1929     (if (symbolp symbol-or-name)
1930     (symbol-name symbol-or-name)
1931     symbol-or-name))
1932     internal-p package-name)
1933     (list name score
1934     (mapcar
1935     #'(lambda (chunk)
1936     ;; fix up chunk positions to
1937     ;; account for possible added
1938     ;; package identifier
1939     (list (+ added-length (first chunk))
1940     (second chunk)))
1941     chunks)))))
1942     (nconc symbols packs))
1943     #'> :key #'second)))
1944     (when (and limit
1945     (> limit 0)
1946     (< limit (length results)))
1947     (setf (cdr (nthcdr (1- limit) results)) nil))
1948     results)))
1949    
1950     (defun fuzzy-find-matching-symbols (string package external)
1951     "Return a list of symbols in PACKAGE matching STRING using the
1952     fuzzy completion algorithm. If EXTERNAL is true, only external
1953     symbols are returned."
1954     (let ((completions '())
1955     (converter (output-case-converter string)))
1956     (flet ((symbol-match (symbol)
1957     (and (or (not external)
1958     (symbol-external-p symbol package))
1959     (compute-highest-scoring-completion
1960     string (funcall converter (symbol-name symbol)) #'char=))))
1961     (do-symbols (symbol package)
1962     (multiple-value-bind (result score) (symbol-match symbol)
1963     (when result
1964     (push (list symbol score result) completions)))))
1965     (remove-duplicates completions :key #'first)))
1966    
1967     (defun fuzzy-find-matching-packages (name)
1968     "Return a list of package names matching NAME using the fuzzy
1969     completion algorithm."
1970     (let ((converter (output-case-converter name)))
1971     (loop for package in (list-all-packages)
1972     for package-name = (concatenate 'string
1973     (funcall converter
1974     (package-name package))
1975     ":")
1976     for (result score) = (multiple-value-list
1977     (compute-highest-scoring-completion
1978     name package-name #'char=))
1979     if result collect (list package-name score result))))
1980    
1981 lgorrie 1.202 (defslimefun fuzzy-completion-selected (original-string completion)
1982     "This function is called by Slime when a fuzzy completion is
1983     selected by the user. It is for future expansion to make
1984     testing, say, a machine learning algorithm for completion scoring
1985     easier.
1986    
1987     ORIGINAL-STRING is the string the user completed from, and
1988     COMPLETION is the completion object (see docstring for
1989     SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
1990     user selected."
1991     (declare (ignore original-string completion))
1992     nil)
1993    
1994 lgorrie 1.212 ;;;;; Fuzzy completion core
1995 lgorrie 1.202
1996     (defparameter *fuzzy-recursion-soft-limit* 30
1997     "This is a soft limit for recursion in
1998     RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
1999     completing a string such as \"ZZZZZZ\" with a symbol named
2000     \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
2001     find all the ways it can match.
2002    
2003     Most natural language searches and symbols do not have this
2004     problem -- this is only here as a safeguard.")
2005    
2006 lgorrie 1.212 (defun compute-highest-scoring-completion (short full test)
2007     "Finds the highest scoring way to complete the abbreviation
2008     SHORT onto the string FULL, using TEST as a equality function for
2009     letters. Returns two values: The first being the completion
2010     chunks of the high scorer, and the second being the score."
2011     (let* ((scored-results
2012     (mapcar #'(lambda (result)
2013     (cons (score-completion result short full) result))
2014     (compute-most-completions short full test)))
2015     (winner (first (sort scored-results #'> :key #'first))))
2016     (values (rest winner) (first winner))))
2017    
2018     (defun compute-most-completions (short full test)
2019     "Finds most possible ways to complete FULL with the letters in SHORT.
2020     Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
2021     a list of (&rest CHUNKS), where each CHUNKS is a description of
2022     how a completion matches."
2023     (let ((*all-chunks* nil))
2024     (declare (special *all-chunks*))
2025     (recursively-compute-most-completions short full test 0 0 nil nil nil t)
2026     *all-chunks*))
2027    
2028 lgorrie 1.202 (defun recursively-compute-most-completions
2029     (short full test
2030     short-index initial-full-index
2031     chunks current-chunk current-chunk-pos
2032     recurse-p)
2033     "Recursively (if RECURSE-P is true) find /most/ possible ways
2034     to fuzzily map the letters in SHORT onto FULL, with TEST being a
2035     function to determine if two letters match.
2036    
2037     A chunk is a list of elements that have matched consecutively.
2038     When consecutive matches stop, it is coerced into a string,
2039     paired with the starting position of the chunk, and pushed onto
2040     CHUNKS.
2041    
2042     Whenever a letter matches, if RECURSE-P is true,
2043     RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
2044     one index ahead, to find other possibly higher scoring
2045     possibilities. If there are less than
2046     *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
2047     this call will also recurse.
2048    
2049     Once a word has been completely matched, the chunks are pushed
2050     onto the special variable *ALL-CHUNKS* and the function returns."
2051     (declare (special *all-chunks*))
2052     (flet ((short-cur ()
2053     "Returns the next letter from the abbreviation, or NIL
2054     if all have been used."
2055     (if (= short-index (length short))
2056     nil
2057     (aref short short-index)))
2058     (add-to-chunk (char pos)
2059     "Adds the CHAR at POS in FULL to the current chunk,
2060     marking the start position if it is empty."
2061     (unless current-chunk
2062     (setf current-chunk-pos pos))
2063     (push char current-chunk))
2064     (collect-chunk ()
2065     "Collects the current chunk to CHUNKS and prepares for
2066     a new chunk."
2067     (when current-chunk
2068     (push (list current-chunk-pos
2069     (coerce (reverse current-chunk) 'string)) chunks)
2070     (setf current-chunk nil
2071     current-chunk-pos nil))))
2072     ;; If there's an outstanding chunk coming in collect it. Since
2073     ;; we're recursively called on skipping an input character, the
2074     ;; chunk can't possibly continue on.
2075     (when current-chunk (collect-chunk))
2076     (do ((pos initial-full-index (1+ pos)))
2077     ((= pos (length full)))
2078     (let ((cur-char (aref full pos)))
2079     (if (and (short-cur)
2080     (funcall test cur-char (short-cur)))
2081     (progn
2082     (when recurse-p
2083     ;; Try other possibilities, limiting insanely deep
2084     ;; recursion somewhat.
2085     (recursively-compute-most-completions
2086     short full test short-index (1+ pos)
2087     chunks current-chunk current-chunk-pos
2088     (not (> (length *all-chunks*)
2089     *fuzzy-recursion-soft-limit*))))
2090     (incf short-index)
2091     (add-to-chunk cur-char pos))
2092     (collect-chunk))))
2093     (collect-chunk)
2094     ;; If we've exhausted the short characters we have a match.
2095     (if (short-cur)
2096     nil
2097     (let ((rev-chunks (reverse chunks)))
2098     (push rev-chunks *all-chunks*)
2099     rev-chunks))))
2100    
2101 lgorrie 1.212 ;;; XXX Debugging tool? Not called anywhere. -luke (11/Jul/2004)
2102 lgorrie 1.202 (defun compute-completion (short full test)
2103     "Finds the first way to complete FULL with the letters in SHORT.
2104     Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS non-recursively.
2105     Returns a list of one (&rest CHUNKS), where CHUNKS is a
2106     description of how the completion matched."
2107     (let ((*all-chunks* nil))
2108     (declare (special *all-chunks*))
2109     (recursively-compute-most-completions short full test 0 0 nil nil nil nil)
2110     *all-chunks*))
2111    
2112 lgorrie 1.212 ;;;;; Fuzzy completion scoring
2113    
2114 lgorrie 1.202 (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
2115     "Letters that are likely to be at the beginning of a symbol.
2116     Letters found after one of these prefixes will be scored as if
2117     they were at the beginning of ths symbol.")
2118     (defparameter *fuzzy-completion-symbol-suffixes* "*+->"
2119     "Letters that are likely to be at the end of a symbol.
2120     Letters found before one of these suffixes will be scored as if
2121     they were at the end of the symbol.")
2122     (defparameter *fuzzy-completion-word-separators* "-/."
2123     "Letters that separate different words in symbols. Letters
2124     after one of these symbols will be scores more highly than other
2125     letters.")
2126    
2127     (defun score-completion (completion short full)
2128     "Scores the completion chunks COMPLETION as a completion from
2129     the abbreviation SHORT to the full string FULL. COMPLETION is a
2130     list like:
2131     ((0 \"mul\") (9 \"v\") (15 \"b\"))
2132     Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
2133     would indicate that it completed as such (completed letters
2134     capitalized):
2135     MULtiple-Value-Bind
2136    
2137     Letters are given scores based on their position in the string.
2138     Letters at the beginning of a string or after a prefix letter at
2139     the beginning of a string are scored highest. Letters after a
2140     word separator such as #\- are scored next highest. Letters at
2141     the end of a string or before a suffix letter at the end of a
2142     string are scored medium, and letters anywhere else are scored
2143     low.
2144    
2145     If a letter is directly after another matched letter, and its
2146     intrinsic value in that position is less than a percentage of the
2147     previous letter's value, it will use that percentage instead.
2148    
2149     Finally, a small scaling factor is applied to favor shorter
2150     matches, all other things being equal."
2151     (flet ((score-chunk (chunk)
2152     (let ((initial-pos (first chunk))
2153     (str (second chunk)))
2154     (labels ((at-beginning-p (pos)
2155     (= pos 0))
2156     (after-prefix-p (pos)
2157     (and (= pos 1)
2158     (find (aref full 0)
2159     *fuzzy-completion-symbol-prefixes*)))
2160     (word-separator-p (pos)
2161     (find (aref full pos)
2162     *fuzzy-completion-word-separators*))
2163     (after-word-separator-p (pos)
2164     (find (aref full (1- pos))
2165     *fuzzy-completion-word-separators*))
2166     (at-end-p (pos)
2167     (= pos (1- (length full))))
2168     (before-suffix-p (pos)
2169     (and (= pos (- (length full) 2))
2170     (find (aref full (1- (length full)))
2171     *fuzzy-completion-symbol-suffixes*)))
2172     (score-or-percentage-of-previous
2173     (base-score pos chunk-pos)
2174     (if (zerop chunk-pos)
2175     base-score
2176     (max base-score
2177     (* (score-char (1- pos) (1- chunk-pos))
2178     0.85))))
2179     (score-char (pos chunk-pos)
2180     (score-or-percentage-of-previous
2181     (cond ((at-beginning-p pos) 10)
2182     ((after-prefix-p pos) 10)
2183     ((word-separator-p pos) 1)
2184     ((after-word-separator-p pos) 8)
2185     ((at-end-p pos) 6)
2186     ((before-suffix-p pos) 6)
2187     (t 1))
2188     pos chunk-pos)))
2189     (loop for chunk-pos below (length str)
2190     for pos from initial-pos
2191     summing (score-char pos chunk-pos))))))
2192     (let* ((chunk-scores (mapcar #'score-chunk completion))
2193     (length-score
2194     (/ 10 (coerce (1+ (- (length full) (length short)))
2195     'single-float))))
2196     (values
2197     (+ (apply #'+ chunk-scores) length-score)
2198     (list (mapcar #'list chunk-scores completion) length-score)))))
2199    
2200     (defun highlight-completion (completion full)
2201     "Given a chunk definition COMPLETION and the string FULL,
2202     HIGHLIGHT-COMPLETION will create a string that demonstrates where
2203     the completion matched in the string. Matches will be
2204     capitalized, while the rest of the string will be lower-case."
2205     (let ((highlit (string-downcase full)))
2206     (dolist (chunk completion)
2207     (setf highlit (string-upcase highlit
2208     :start (first chunk)
2209     :end (+ (first chunk)
2210     (length (second chunk))))))
2211     highlit))
2212    
2213     (defun format-fuzzy-completions (winners)
2214     "Given a list of completion objects such as on returned by
2215     FUZZY-COMPLETIONS, format the list into user-readable output."
2216     (let ((max-len
2217     (loop for winner in winners maximizing (length (first winner)))))
2218     (loop for (sym score result) in winners do
2219     (format t "~&~VA score ~8,2F ~A"
2220     max-len (highlight-completion result sym) score result))))
2221    
2222 lgorrie 1.69
2223 lgorrie 1.62 ;;;; Documentation
2224 heller 1.38
2225 heller 1.169 (defslimefun apropos-list-for-emacs (name &optional external-only
2226     case-sensitive package)
2227 heller 1.38 "Make an apropos search for Emacs.
2228     The result is a list of property lists."
2229 heller 1.130 (let ((package (if package
2230 lgorrie 1.186 (or (find-package (string-to-package-designator package))
2231 heller 1.130 (error "No such package: ~S" package)))))
2232     (mapcan (listify #'briefly-describe-symbol-for-emacs)
2233 heller 1.153 (sort (remove-duplicates
2234 heller 1.169 (apropos-symbols name external-only case-sensitive package))
2235 heller 1.130 #'present-symbol-before-p))))
2236 lgorrie 1.186
2237     (defun string-to-package-designator (string)
2238     "Return a package designator made from STRING.
2239     Uses READ to case-convert STRING."
2240     (let ((*package* *swank-io-package*))
2241     (read-from-string string)))
2242 lgorrie 1.61
2243     (defun briefly-describe-symbol-for-emacs (symbol)
2244     "Return a property list describing SYMBOL.
2245     Like `describe-symbol-for-emacs' but with at most one line per item."
2246 heller 1.226 (flet ((first-line (string)
2247 lgorrie 1.61 (let ((pos (position #\newline string)))
2248     (if (null pos) string (subseq string 0 pos)))))
2249 heller 1.67 (let ((desc (map-if #'stringp #'first-line
2250     (describe-symbol-for-emacs symbol))))
2251     (if desc
2252     (list* :designator (to-string symbol) desc)))))
2253 lgorrie 1.61
2254     (defun map-if (test fn &rest lists)
2255     "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
2256     Example:
2257     \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
2258 heller 1.111 (declare (type function test fn))
2259 lgorrie 1.61 (apply #'mapcar
2260     (lambda (x) (if (funcall test x) (funcall fn x) x))
2261     lists))
2262 heller 1.38
2263     (defun listify (f)
2264     "Return a function like F, but which returns any non-null value
2265     wrapped in a list."
2266 heller 1.111 (declare (type function f))
2267 heller 1.38 (lambda (x)
2268     (let ((y (funcall f x)))
2269     (and y (list y)))))
2270    
2271     (defun present-symbol-before-p (a b)
2272     "Return true if A belongs before B in a printed summary of symbols.
2273     Sorted alphabetically by package name and then symbol name, except
2274     that symbols accessible in the current package go first."
2275     (flet ((accessible (s)
2276     (find-symbol (symbol-name s) *buffer-package*)))
2277 lgorrie 1.42 (cond ((and (accessible a) (accessible b))
2278     (string< (symbol-name a) (symbol-name b)))
2279     ((accessible a) t)
2280     ((accessible b) nil)
2281     (t
2282     (string< (package-name (symbol-package a))
2283     (package-name (symbol-package b)))))))
2284 heller 1.38
2285 heller 1.169 (let ((regex-hash (make-hash-table :test #'equal)))
2286     (defun compiled-regex (regex-string)
2287     (or (gethash regex-string regex-hash)
2288     (setf (gethash regex-string regex-hash)
2289 heller 1.189 (if (zerop (length regex-string))
2290     (lambda (s) (check-type s string) t)
2291     (compile nil (nregex:regex-compile regex-string)))))))
2292 heller 1.169
2293     (defun apropos-matcher (string case-sensitive package external-only)
2294     (let* ((case-modifier (if case-sensitive #'string #'string-upcase))
2295     (regex (compiled-regex (funcall case-modifier string))))
2296     (lambda (symbol)
2297     (and (not (keywordp symbol))
2298     (if package (eq (symbol-package symbol) package) t)
2299     (if external-only (symbol-external-p symbol) t)
2300     (funcall regex (funcall case-modifier symbol))))))
2301    
2302     (defun apropos-symbols (string external-only case-sensitive package)
2303     (let ((result '())
2304     (matchp (apropos-matcher string case-sensitive package external-only)))
2305     (with-package-iterator (next (or package (list-all-packages))
2306     :external :internal)
2307     (loop
2308     (multiple-value-bind (morep symbol) (next)
2309     (cond ((not morep)
2310     (return))
2311     ((funcall matchp symbol)
2312     (push symbol result))))))
2313     result))
2314 lgorrie 1.62
2315 heller 1.207 (defun call-with-describe-settings (fn)
2316     (let ((*print-readably* nil))
2317     (funcall fn)))
2318    
2319     (defmacro with-describe-settings ((&rest _) &body body)
2320     (declare (ignore _))
2321     `(call-with-describe-settings (lambda () ,@body)))
2322    
2323 heller 1.138 (defun describe-to-string (object)
2324 heller 1.207 (with-describe-settings ()
2325 heller 1.189 (with-output-to-string (*standard-output*)
2326     (describe object))))
2327 lgorrie 1.62
2328     (defslimefun describe-symbol (symbol-name)
2329 heller 1.189 (with-buffer-syntax ()
2330 heller 1.207 (describe-to-string (parse-symbol-or-lose symbol-name))))
2331 lgorrie 1.62
2332 heller 1.189 (defslimefun describe-function (name)
2333     (with-buffer-syntax ()
2334 heller 1.207 (let ((symbol (parse-symbol-or-lose name)))
2335 heller 1.189 (describe-to-string (or (macro-function symbol)
2336     (symbol-function symbol))))))
2337 heller 1.138
2338 heller 1.147 (defslimefun describe-definition-for-emacs (name kind)
2339 heller 1.189 (with-buffer-syntax ()
2340 heller 1.207 (with-describe-settings ()
2341     (with-output-to-string (*standard-output*)
2342     (describe-definition (parse-symbol-or-lose name) kind)))))
2343 lgorrie 1.62
2344 heller 1.75 (defslimefun documentation-symbol (symbol-name &optional default)
2345 heller 1.189 (with-buffer-syntax ()
2346     (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
2347     (if foundp
2348     (let ((vdoc (documentation sym 'variable))
2349     (fdoc (documentation sym 'function)))
2350     (or (and (or vdoc fdoc)
2351     (concatenate 'string
2352     fdoc
2353     (and vdoc fdoc '(#\Newline #\Newline))
2354     vdoc))
2355     default))
2356 heller 1.75 default))))
2357 lgorrie 1.62
2358    
2359 heller 1.195 ;;;; Package Commands
2360 lgorrie 1.62
2361 heller 1.168 (defslimefun list-all-package-names (&optional include-nicknames)
2362     "Return a list of all package names.
2363     Include the nicknames if INCLUDE-NICKNAMES is true."
2364     (loop for package in (list-all-packages)
2365     collect (package-name package)
2366     when include-nicknames append (package-nicknames package)))
2367 heller 1.79
2368 heller 1.195
2369     ;;;; Tracing
2370    
2371 heller 1.79 ;; Use eval for the sake of portability...
2372     (defun tracedp (fspec)
2373     (member fspec (eval '(trace))))
2374    
2375     (defslimefun toggle-trace-fdefinition (fname-string)
2376     (let ((fname (from-string fname-string)))
2377     (cond ((tracedp fname)
2378     (eval `(untrace ,fname))
2379     (format nil "~S is now untraced." fname))
2380     (t
2381     (eval `(trace ,fname))
2382     (format nil "~S is now traced." fname)))))
2383 heller 1.38
2384     (defslimefun untrace-all ()
2385     (untrace))
2386    
2387 heller 1.195
2388     ;;;; Undefing
2389    
2390 heller 1.116 (defslimefun undefine-function (fname-string)
2391     (let ((fname (from-string fname-string)))
2392     (format nil "~S" (fmakunbound fname))))
2393    
2394 heller 1.102
2395 heller 1.110 ;;;; Profiling
2396    
2397     (defun profiledp (fspec)
2398     (member fspec (profiled-functions)))
2399    
2400     (defslimefun toggle-profile-fdefinition (fname-string)
2401     (let ((fname (from-string fname-string)))
2402     (cond ((profiledp fname)
2403     (unprofile fname)
2404     (format nil "~S is now unprofiled." fname))
2405     (t
2406     (profile fname)
2407     (format nil "~S is now profiled." fname)))))
2408    
2409    
2410 heller 1.102 ;;;; Source Locations
2411 heller 1.72
2412 heller 1.147 (defslimefun find-definitions-for-emacs (name)
2413     "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
2414     DSPEC is a string and LOCATION a source location. NAME is a string."
2415     (multiple-value-bind (sexp error)
2416     (ignore-errors (values (from-string name)))
2417 heller 1.149 (cond (error '())
2418 heller 1.147 (t (loop for (dspec loc) in (find-definitions sexp)
2419 heller 1.141 collect (list (to-string dspec) loc))))))
2420 heller 1.147
2421 heller 1.72 (defun alistify (list key test)
2422 heller 1.77 "Partition the elements of LIST into an alist. KEY extracts the key
2423 heller 1.72 from an element and TEST is used to compare keys."
2424 heller 1.111 (declare (type function key))
2425 heller 1.72 (let ((alist '()))
2426     (dolist (e list)
2427     (let* ((k (funcall key e))
2428     (probe (assoc k alist :test test)))
2429     (if probe
2430     (push e (cdr probe))
2431     (push (cons k (list e)) alist))))
2432     alist))
2433 heller 1.77
2434 heller 1.72 (defun location-position< (pos1 pos2)
2435     (cond ((and (position-p pos1) (position-p pos2))
2436     (< (position-pos pos1)
2437     (position-pos pos2)))
2438     (t nil)))
2439 heller 1.74
2440 heller 1.138 (defun partition (list test key)
2441     (declare (type function test key))
2442 heller 1.74 (loop for e in list
2443 heller 1.138 if (funcall test (funcall key e)) collect e into yes
2444 heller 1.74 else collect e into no
2445     finally (return (values yes no))))
2446 heller 1.77
2447 heller 1.138 (defstruct (xref (:conc-name xref.)
2448     (:type list))
2449     dspec location)
2450    
2451     (defun location-valid-p (location)
2452     (eq (car location) :location))
2453    
2454     (defun xref-buffer (xref)
2455     (location-buffer (xref.location xref)))
2456    
2457     (defun xref-position (xref)
2458     (location-buffer (xref.location xref)))
2459    
2460 heller 1.72 (defun group-xrefs (xrefs)
2461 heller 1.147 "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
2462     The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
2463 heller 1.138 (multiple-value-bind (resolved errors)
2464     (partition xrefs #'location-valid-p #'xref.location)
2465     (let ((alist (alistify resolved #'xref-buffer #'equal)))
2466     (append
2467     (loop for (buffer . list) in alist
2468     collect (cons (second buffer)
2469     (mapcar (lambda (xref)
2470     (cons (to-string (xref.dspec xref))
2471     (xref.location xref)))
2472     (sort list #'location-position<
2473     :key #'xref-position))))
2474     (if errors
2475     (list (cons "Unresolved"
2476     (mapcar (lambda (xref)
2477     (cons (to-string (xref.dspec xref))
2478     (xref.location xref)))
2479     errors))))))))
2480    
2481     (defslimefun xref (type symbol-name)
2482 lgorrie 1.212 (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
2483 heller 1.138 (group-xrefs
2484     (ecase type
2485     (:calls (who-calls symbol))
2486     (:references (who-references symbol))
2487     (:binds (who-binds symbol))
2488     (:sets (who-sets symbol))
2489     (:macroexpands (who-macroexpands symbol))
2490     (:specializes (who-specializes symbol))
2491     (:callers (list-callers symbol))
2492     (:callees (list-callees symbol))))))
2493 heller 1.72
2494 heller 1.102
2495     ;;;; Inspecting
2496    
2497 mbaringer 1.229 (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
2498     (butlast
2499     (loop
2500     for i in list
2501     collect (funcall callback i)
2502     collect ", ")))
2503    
2504 mbaringer 1.239 (defun inspector-princ (list)
2505     "Just like princ-to-string, but don't rewrite (function foo) as
2506     #'foo. Do NOT pass circular lists to this function."
2507     (with-output-to-string (as-string)
2508     (labels ((printer (object)
2509     (typecase object
2510     (null (princ nil as-string))
2511     (cons
2512     (write-char #\( as-string)
2513     (printer (car object))
2514     (loop
2515     for (head . tail) on (cdr object)
2516     do (write-char #\Space as-string)
2517     do (printer head)
2518     unless (listp tail)
2519     do (progn
2520     (write-string " . " as-string)
2521     (printer tail))
2522     and return t)
2523     (write-char #\) as-string))
2524     (t (princ object as-string)))))
2525     (printer list))))
2526    
2527 mbaringer 1.235 (defmethod inspect-for-emacs ((object cons) (inspector t))
2528     (declare (ignore inspector))
2529     (if (or (consp (cdr object))
2530     (null (cdr object)))
2531     (inspect-for-emacs-nontrivial-list object)
2532     (inspect-for-emacs-simple-cons object)))
2533 mbaringer 1.229
2534 mbaringer 1.235 (defun inspect-for-emacs-simple-cons (cons)
2535 mbaringer 1.231 (values "A cons cell."
2536 mbaringer 1.229 `("Car: " (:value ,(car cons))
2537     (:newline)
2538     "Cdr: " (:value ,(cdr cons)))))
2539    
2540 mbaringer 1.235 (defun inspect-for-emacs-nontrivial-list (list)
2541 mbaringer 1.229 (let ((circularp nil)
2542     (length 0)
2543     (seen (make-hash-table :test 'eq))
2544     (contents '()))
2545     (loop
2546     for cons on list
2547     when (gethash cons seen)
2548     do (setf circularp t) and
2549     do (return)
2550     do (push '(:newline) contents)
2551     do (push `(:value ,(car cons)) contents)
2552     do (setf (gethash cons seen) t)
2553     do (incf length))
2554     (if circularp
2555     (values "A circular list."
2556     `("Contents:"
2557     ,@(nreverse contents)))
2558     (values "A proper list."
2559     `("Length: " (:value ,length)
2560     (:newline)
2561     "Contents:"
2562     ,@(nreverse contents))))))
2563    
2564 mbaringer 1.235 (defmethod inspect-for-emacs ((ht hash-table) (inspector t))
2565     (declare (ignore inspector))
2566 mbaringer 1.231 (values "A hash table."
2567 mbaringer 1.229 `("Count: " (:value ,(hash-table-count ht))
2568     (:newline)
2569     "Size: " (:value ,(hash-table-size ht))
2570     (:newline)
2571     "Test: " (:value ,(hash-table-test ht))
2572     (:newline)
2573     "Rehash size: " (:value ,(hash-table-rehash-size ht))
2574     (:newline)
2575     "Rehash threshold: " (:value ,(hash-table-rehash-threshold ht))
2576     (:newline)
2577     "Contents:" (:newline)
2578     ,@(loop
2579     for key being the hash-keys of ht
2580     for value being the hash-values of ht
2581     collect `(:value ,key)
2582     collect " = "
2583     collect `(:value ,value)
2584 mbaringer 1.237 collect " "
2585 mbaringer 1.229 collect `(:newline)))))
2586    
2587 mbaringer 1.235 (defmethod inspect-for-emacs ((array array) (inspector t))
2588     (declare (ignore inspector))
2589 mbaringer 1.229 (values "An array."
2590     `("Dimensions: " (:value ,(array-dimensions array))
2591     (:newline)
2592 mbaringer 1.238 "Its element type is: " (:value ,(array-element-type array))
2593 mbaringer 1.229 (:newline)
2594     "Total size: " (:value ,(array-total-size array))
2595     (:newline)
2596     ,@(if (array-has-fill-pointer-p array)
2597 mbaringer 1.238 `("Its fill-pointer is " (:value ,(fill-pointer array)))
2598 mbaringer 1.229 `("No fill pointer."))
2599     (:newline)
2600     ,(if (adjustable-array-p array)
2601     "It is adjustable."
2602     "It is not adjustable.")
2603     (:newline)
2604     "Contents:" (:newline)
2605     ,@(loop
2606     with darray = (make-array (array-total-size array)
2607     :displaced-to array
2608     :displaced-index-offset 0
2609     :element-type (array-element-type array))
2610     for index upfrom 0
2611     for element across darray
2612     collect `(:value ,element)
2613     collect '(:newline)))))
2614    
2615 mbaringer 1.235 (defmethod inspect-for-emacs ((char character) (inspector t))
2616     (declare (ignore inspector))
2617 mbaringer 1.231 (values "A character."
2618 mbaringer 1.229 `("Char code: " (:value ,(char-code char))
2619     (:newline)
2620     "Lower cased: " (:value ,(char-downcase char))
2621     (:newline)
2622     "Upper cased: " (:value ,(char-upcase char))
2623     (:newline)
2624     ,@(when (get-macro-character char)
2625     `("In the current readtable (" (:value ,*readtable*) ") it is a macro character: "
2626     (:value ,(get-macro-character char))
2627     (:newline))))))
2628    
2629 mbaringer 1.235 (defmethod inspect-for-emacs ((symbol symbol) (inspector t))
2630     (declare (ignore inspector))
2631 mbaringer 1.229 (let ((internal-external (multiple-value-bind (symbol status)
2632     (intern (symbol-name symbol) (symbol-package symbol))
2633     (declare (ignore symbol))
2634     (ecase status
2635     ((:internal :inherited) :internal)
2636     (:external :external))))
2637     (package (when (find-package symbol)
2638     `("It names the package " (:value ,(find-package symbol)) (:newline))))
2639     (class (when (find-class symbol nil)
2640 mbaringer 1.239 `("It names the class " (:value ,(find-class symbol) ,(inspector-princ (class-name (find-class symbol))))
2641 mbaringer 1.235 " " (:action ,(format nil "[remove name ~S (does not affect class object)]" symbol)
2642     (lambda () (setf (find-class symbol) nil)))))))
2643 mbaringer 1.231 (values "A symbol."
2644 mbaringer 1.238 `("Its name is: " (:value ,(symbol-name symbol))
2645 mbaringer 1.229 (:newline)
2646     ;; check to see whether it is a global variable, a
2647     ;; constant, or a symbol macro.
2648     ,@(let ((documentation (when (documentation symbol 'variable)
2649     `((:newline)
2650     "Documentation:"
2651     (:newline)
2652     ,(documentation symbol 'variable)))))
2653     (cond
2654     ((constantp symbol)
2655     `("It is a constant of value: " (:value ,(symbol-value symbol)) ,@documentation))
2656     ((boundp symbol)
2657     `("It is a global variable bound to: " (:value ,(symbol-value symbol)) ,@documentation))
2658     ((nth-value 1 (macroexpand symbol))
2659     `("It is a symbol macro with expansion: " (:value ,(macroexpand symbol))))
2660     (t
2661     `("It is unbound."))))
2662     (:newline)
2663     ,@(if (fboundp symbol)
2664 mbaringer 1.237 (append
2665     (if (macro-function symbol)
2666     `("It a macro with macro-function: " (:value ,(macro-function symbol)))
2667     `("It is a function: " (:value ,(symbol-function symbol))))
2668     `(" " (:action "[make funbound]" ,(lambda () (fmakunbound symbol))))
2669     `((:newline))
2670     (when (documentation symbol 'function)
2671     `("Documentation:" (:newline) ,(documentation symbol 'function) (:newline)))
2672     (when (compiler-macro-function symbol)
2673 mbaringer 1.238 `("It also names the compiler macro: " (:value ,(compiler-macro-function symbol)) (:newline)))
2674 mbaringer 1.237 (when (documentation symbol 'compiler-macro)
2675     `("Documentation:" (:newline) ,(documentation symbol 'compiler-macro) (:newline))))
2676     `("It has no function value." (:newline)))
2677 mbaringer 1.229 "It is " ,(case internal-external
2678     (:internal "internal")
2679     (:external "external")) " to the package: " (:value ,(symbol-package symbol))
2680     ,@(when (eql :internal internal-external)
2681     `(" " (:action ,(with-output-to-string (export-label)
2682     (princ "[export from " export-label)
2683     (princ (package-name (symbol-package symbol)) export-label)
2684     (princ "]" export-label))
2685     ,(lambda () (export symbol (symbol-package symbol))))))
2686 asimon 1.234 (:newline)
2687 mbaringer 1.231 "Property list: " (:value ,(symbol-plist symbol))
2688 mbaringer 1.229 (:newline)
2689     ,@package
2690     ,@class))))
2691    
2692 mbaringer 1.235 (defmethod inspect-for-emacs ((f function) (inspector t))
2693     (declare (ignore inspector))
2694 mbaringer 1.231 (values "A function."
2695 mbaringer 1.229 `("Name: " (:value ,(function-name f)) (:newline)
2696 mbaringer 1.239 "Its argument list is: " ,(inspector-princ (arglist f))
2697 mbaringer 1.231 (:newline)
2698     ,@(when (documentation f t)
2699 mbaringer 1.239 `("Documentation:" (:newline) ,(documentation f t) (:newline)))
2700     ,@(when (and (function-name f)
2701    
2702     )))))
2703    
2704     (defun method-specializers-for-inspect (method)
2705     "Return a \"pretty\" list of the method's specializers. Normal
2706     specializers are replaced by the name of the class, eql
2707     specializers are replaced by `(eql ,object)."
2708     (mapcar (lambda (spec)
2709     (typecase spec
2710     (swank-mop:eql-specializer
2711     `(eql ,(swank-mop:eql-specializer-object spec)))
2712     (t (swank-mop:class-name spec))))
2713     (swank-mop:method-specializers method)))
2714    
2715     (defun method-for-inspect-value (method)
2716     "Returns a \"pretty\" list describing METHOD. The first element
2717     of the list is the name of generic-function method is
2718     specialiazed on, the second element is the method qualifiers,
2719     the rest of the list is the method's specialiazers (as per
2720     method-specializers-for-inspect)."
2721     (if (swank-mop:method-qualifiers method)
2722     (list*
2723     (swank-mop:generic-function-name (swank-mop:method-generic-function method))
2724     (let ((quals (swank-mop:method-qualifiers method)))
2725     (if (= 1 (length quals))
2726     (first quals)
2727     quals))
2728     (method-specializers-for-inspect method))
2729     (list*
2730     (swank-mop:generic-function-name (swank-mop:method-generic-function method))
2731     (method-specializers-for-inspect method))))
2732 mbaringer 1.231
2733 mbaringer 1.235 (defmethod inspect-for-emacs ((o standard-object) (inspector t))
2734     (declare (ignore inspector))
2735 mbaringer 1.231 (values "An object."
2736     `("Class: " (:value ,(class-of o))
2737     (:newline)
2738     "Slots:" (:newline)
2739     ,@(loop
2740     with direct-slots = (swank-mop:class-direct-slots (class-of o))
2741     for slot in (swank-mop:class-slots (class-of o))
2742     for slot-def = (or (find-if (lambda (a)
2743 mbaringer 1.239 ;; find the direct slot
2744     ;; with the same name
2745     ;; as SLOT (an
2746     ;; effective slot).
2747 mbaringer 1.231 (eql (swank-mop:slot-definition-name a)
2748     (swank-mop:slot-definition-name slot)))
2749     direct-slots)
2750     slot)
2751 mbaringer 1.239 collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
2752 mbaringer 1.231 collect " = "
2753     if (slot-boundp o (swank-mop:slot-definition-name slot-def))
2754     collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
2755     else
2756     collect "#<unbound>"
2757     collect '(:newline)))))
2758 mbaringer 1.229
2759 mbaringer 1.235 (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector t))
2760     (declare (ignore inspector))
2761 mbaringer 1.231 (values "A generic function."
2762 mbaringer 1.229 `("Name: " (:value ,(swank-mop:generic-function-name gf)) (:newline)
2763 mbaringer 1.239 "Its argument list is: " ,(inspector-princ (swank-mop:generic-function-lambda-list gf)) (:newline)
2764 mbaringer 1.229 "Documentation: " (:newline)
2765 mbaringer 1.239 ,(inspector-princ (documentation gf t)) (:newline)
2766 mbaringer 1.238 "Its method class is: " (:value ,(swank-mop:generic-function-method-class gf)) (:newline)
2767 mbaringer 1.229 "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline)
2768     "Methods: " (:newline)
2769     ,@(loop
2770     for method in (swank-mop:generic-function-methods gf)
2771 mbaringer 1.239 collect `(:value ,method ,(inspector-princ
2772     ;; drop the first element (the name of the generic function)
2773     (cdr (method-for-inspect-value method))))
2774 mbaringer 1.229 collect " "
2775     collect (let ((meth method))
2776     `(:action "[remove method]" ,(lambda () (remove-method gf meth))))
2777     collect '(:newline)))))
2778    
2779 mbaringer 1.235 (defmethod inspect-for-emacs ((method standard-method) (inspector t))
2780     (declare (ignore inspector))
2781 mbaringer 1.231 (values "A method."
2782 mbaringer 1.229 `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method)
2783 mbaringer 1.239 ,(inspector-princ
2784 mbaringer 1.229 (swank-mop:generic-function-name
2785     (swank-mop:method-generic-function method))))
2786 mbaringer 1.239 (:newline)
2787     ,@(when (documentation method t)
2788     `("Documentation:" (:newline) ,(documentation method t) (:newline)))
2789 mbaringer 1.229 "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
2790     (:newline)
2791 mbaringer 1.231 "Specializers: " (:value ,(swank-mop:method-specializers method)
2792 mbaringer 1.239 ,(inspector-princ (method-specializers-for-inspect method)))
2793 mbaringer 1.229 (:newline)
2794 mbaringer 1.235 "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
2795     (:newline)
2796     "Method function: " (:value ,(swank-mop:method-function method)))))
2797 mbaringer 1.229
2798 mbaringer 1.235 (defmethod inspect-for-emacs ((class standard-class) (inspector t))
2799     (declare (ignore inspector))
2800 mbaringer 1.231 (values "A class."
2801 mbaringer 1.229 `("Name: " (:value ,(class-name class))
2802     (:newline)
2803     "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
2804     (:newline)
2805     "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)
2806     (lambda (slot)
2807 mbaringer 1.239 `(:value ,slot ,(inspector-princ
2808 mbaringer 1.229 (swank-mop:slot-definition-name slot)))))
2809     (:newline)
2810 mbaringer 1.230 "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)
2811     (common-seperated-spec (swank-mop:class-slots class)
2812     (lambda (slot)
2813 mbaringer 1.239 `(:value ,slot ,(inspector-princ
2814 mbaringer 1.230 (swank-mop:slot-definition-name slot)))))
2815 mbaringer 1.237 '("#<N/A (class not finalized)>"))
2816 mbaringer 1.229 (:newline)
2817     ,@(when (documentation class t)
2818 mbaringer 1.239 `("Documentation:" (:newline)
2819     ,(documentation class t) (:newline)))
2820 mbaringer 1.229 "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
2821     (lambda (sub)
2822 mbaringer 1.239 `(:value ,sub ,(inspector-princ (class-name sub)))))
2823 mbaringer 1.229 (:newline)
2824 mbaringer 1.230 "Precedence List: " ,@(if (swank-mop:class-finalized-p class)
2825     (common-seperated-spec (swank-mop:class-precedence-list class)
2826     (lambda (class)
2827 mbaringer 1.239 `(:value ,class ,(inspector-princ (class-name class)))))
2828 mbaringer 1.237 '("#<N/A (class not finalized)>"))
2829 mbaringer 1.229 (:newline)
2830 mbaringer 1.239 ,@(when (swank-mop:specializer-direct-methods class)
2831     `("It is used as a direct specializer in the following methods:" (:newline)
2832     ,@(loop
2833     for method in (swank-mop:specializer-direct-methods class)
2834     collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
2835     collect '(:newline))))
2836 mbaringer 1.230 "Prototype: " ,(if (swank-mop:class-finalized-p class)
2837     `(:value ,(swank-mop:class-prototype class))
2838 mbaringer 1.237 '"#<N/A (class not finalized)>"))))
2839 mbaringer 1.229
2840 mbaringer 1.235 (defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) (inspector t))
2841     (declare (ignore inspector))
2842 mbaringer 1.231 (values "A slot."
2843 mbaringer 1.229 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
2844     (:newline)
2845     ,@(when (swank-mop:slot-definition-documentation slot)
2846 mbaringer 1.239 `("Documentation:" (:newline)
2847     (:value ,(swank-mop:slot-definition-documentation slot))
2848     (:newline)))
2849 mbaringer 1.237 "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
2850     "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
2851 mbaringer 1.229 `(:value ,(swank-mop:slot-definition-initform slot))
2852     "#<unspecified>") (:newline)
2853 mbaringer 1.237 "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
2854 mbaringer 1.229 (:newline))))
2855    
2856 mbaringer 1.235 (defmethod inspect-for-emacs ((package package) (inspector t))
2857     (declare (ignore inspector))
2858 mbaringer 1.229 (let ((internal-symbols '())
2859     (external-symbols '()))
2860     (do-symbols (sym package)
2861     (when (eq package (symbol-package sym))
2862     (push sym internal-symbols)
2863     (multiple-value-bind (symbol status)
2864     (intern (symbol-name sym) package)
2865     (declare (ignore symbol))
2866     (when (eql :external status)
2867     (push sym external-symbols)))))
2868     (setf internal-symbols (sort internal-symbols #'string-lessp)
2869     external-symbols (sort external-symbols #'string-lessp))
2870 mbaringer 1.231 (values "A package."
2871 mbaringer 1.229 `("Name: " (:value ,(package-name package))
2872     (:newline)
2873     "Nick names: " ,@(common-seperated-spec (sort (package-nicknames package) #'string-lessp))
2874     (:newline)
2875     ,@(when (documentation package t)
2876 mbaringer 1.239 `("Documentation:" (:newline)
2877     ,(documentation package t) (:newline)))
2878 mbaringer 1.229 "Use list: " ,@(common-seperated-spec (sort (package-use-list package) #'string-lessp :key #'package-name)
2879     (lambda (pack)
2880 mbaringer 1.239 `(:value ,pack ,(inspector-princ (package-name pack)))))
2881 mbaringer 1.229 (:newline)
2882     "Used by list: " ,@(common-seperated-spec (sort (package-used-by-list package) #'string-lessp :key #'package-name)
2883     (lambda (pack)