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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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