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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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