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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.502 - (hide annotations)
Tue Aug 28 08:24:54 2007 UTC (6 years, 7 months ago) by mkoeppe
Branch: MAIN
Changes since 1.501: +5 -26 lines
Remove the ID argument from :write-string protocol messages.
Everything, except for rigid-indentation tricks, can be achieved by
using :write-string in conjunction with :presentation-start and
:presentation-end.

	* swank.lisp (present-in-emacs): Unused, removed.

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