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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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