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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.348 - (hide annotations)
Sun Oct 23 08:47:54 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.347: +10 -7 lines
* swank-backend.lisp (install-debugger-globally): new interface
function

* swank.lisp (install-debugger): call install-debugger-globally

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