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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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