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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.342 - (hide annotations)
Tue Sep 27 22:44:28 2005 UTC (8 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.341: +8 -1 lines
(start-server): Call initialize-multiprocessing before starting the
server and startup-idle-and-top-level-loops afterwards.  Calling
startup-idle-and-top-level-loops here shouldn't be a problem because
start-server is only invoked at startup via stdin.

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