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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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