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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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