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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.418 - (hide annotations)
Sun Nov 19 21:27:35 2006 UTC (7 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.417: +34 -33 lines
(compile-file-for-emacs): Use guess-external-format.


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