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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.497 - (hide annotations)
Fri Aug 24 13:55:25 2007 UTC (6 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.496: +42 -32 lines
	* slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.'
	(slime-sexp-at-point): Return results as a list of strings, rather
	than just one big string if called with arg > 1.
	(slime-parse-extended-operator-name): Wrapping some movement code
	in `ignore-errors'. Adapted to new return value of
	`slime-enclosing-form-specs'. Minor cosmetic changes.
	(slime-make-extended-operator-parser/look-ahead): Adapted to
	changes of the ``raw form spec'' format; returns a form of
	strings, instead of a string of a form.
	(slime-parse-extended-operator/declare): Simplified. Adapted to
	changes of the ``raw form spec'' format; passes decl-identifiers,
	or typespec-operators respectively, along the decl/type-spec.
	(%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp
	based approach.
	(%slime-nesting-until-point): New helper for
	`slime-parse-extended-operator/declare'.

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