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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.357 - (hide annotations)
Tue Jan 17 20:28:57 2006 UTC (8 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.356: +65 -49 lines
(spawn-threads-for-connection): Fix a race condition: Don't accept
input before all threads are ready.

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