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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.468 - (hide annotations)
Sun Apr 8 12:15:25 2007 UTC (7 years ago) by mbaringer
Branch: MAIN
Changes since 1.467: +167 -110 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 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
1366     and is tokenized accordingly. The result is returned in three
1367     values: The package identifier part, the actual symbol identifier
1368     part, and a flag if the STRING represents a symbol that is
1369     internal to the package identifier part. (Notice that the flag is
1370     also true with an empty package identifier part, as the STRING is
1371     considered to represent a symbol internal to some current package.)"
1372 heller 1.245 (let ((package (let ((pos (position #\: string)))
1373     (if pos (subseq string 0 pos) nil)))
1374     (symbol (let ((pos (position #\: string :from-end t)))
1375     (if pos (subseq string (1+ pos)) string)))
1376 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
1377 heller 1.245 (values symbol package internp)))
1378    
1379 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1380 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
1381 mkoeppe 1.370 (let ((package nil)
1382     (token (make-array (length string) :element-type 'character
1383     :fill-pointer 0))
1384     (backslash nil)
1385     (vertical nil)
1386     (internp nil))
1387     (loop for char across string
1388     do (cond
1389     (backslash
1390     (vector-push-extend char token)
1391     (setq backslash nil))
1392     ((char= char #\\) ; Quotes next character, even within |...|
1393     (setq backslash t))
1394     ((char= char #\|)
1395     (setq vertical t))
1396     (vertical
1397     (vector-push-extend char token))
1398     ((char= char #\:)
1399     (if package
1400     (setq internp t)
1401     (setq package token
1402     token (make-array (length string)
1403     :element-type 'character
1404     :fill-pointer 0))))
1405     (t
1406     (vector-push-extend (casify-char char) token))))
1407 mbaringer 1.467 (values token package (or (not package) internp))))
1408 mkoeppe 1.370
1409     (defun casify-char (char)
1410     "Convert CHAR accoring to readtable-case."
1411 heller 1.245 (ecase (readtable-case *readtable*)
1412 mkoeppe 1.370 (:preserve char)
1413     (:upcase (char-upcase char))
1414     (:downcase (char-downcase char))
1415     (:invert (if (upper-case-p char)
1416     (char-downcase char)
1417     (char-upcase char)))))
1418 heller 1.245
1419 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1420 heller 1.189 "Find the symbol named STRING.
1421 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1422 mkoeppe 1.370 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1423 heller 1.277 (let ((package (cond ((string= pname "") keyword-package)
1424 mkoeppe 1.370 (pname (find-package pname))
1425 heller 1.277 (t package))))
1426     (if package
1427 mkoeppe 1.370 (find-symbol sname package)
1428 heller 1.277 (values nil nil)))))
1429 heller 1.189
1430 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1431     (multiple-value-bind (symbol status) (parse-symbol string package)
1432     (if status
1433     (values symbol status)
1434 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
1435 heller 1.207
1436 heller 1.245 ;; FIXME: interns the name
1437 heller 1.189 (defun parse-package (string)
1438     "Find the package named STRING.
1439     Return the package or nil."
1440 heller 1.196 (multiple-value-bind (name pos)
1441 heller 1.190 (if (zerop (length string))
1442     (values :|| 0)
1443 heller 1.407 (let ((*package* *swank-io-package*))
1444 heller 1.190 (ignore-errors (read-from-string string))))
1445 heller 1.407 (and name
1446     (or (symbolp name)
1447     (stringp name))
1448     (= (length string) pos)
1449     (find-package name))))
1450 heller 1.190
1451 heller 1.458 (defun unparse-name (string)
1452     "Print the name STRING according to the current printer settings."
1453     ;; this is intended for package or symbol names
1454     (subseq (prin1-to-string (make-symbol string)) 2))
1455    
1456 heller 1.459 (defun guess-package (string)
1457     "Guess which package corresponds to STRING.
1458     Return nil if no package matches."
1459     (or (find-package string)
1460     (parse-package string)
1461     (if (find #\! string) ; for SBCL
1462     (guess-package (substitute #\- #\! string)))))
1463 dbarlow 1.28
1464 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1465 heller 1.189 "An alist mapping package names to readtables.")
1466    
1467 heller 1.459 (defun guess-buffer-readtable (package-name)
1468     (let ((package (guess-package package-name)))
1469     (or (and package
1470     (cdr (assoc (package-name package) *readtable-alist*
1471     :test #'string=)))
1472     *readtable*)))
1473 heller 1.189
1474 lgorrie 1.280 (defun valid-operator-symbol-p (symbol)
1475 heller 1.459 "Is SYMBOL the name of a function, a macro, or a special-operator?"
1476 lgorrie 1.280 (or (fboundp symbol)
1477     (macro-function symbol)
1478     (special-operator-p symbol)))
1479    
1480 heller 1.172 (defun valid-operator-name-p (string)
1481 heller 1.459 "Is STRING the name of a function, macro, or special-operator?"
1482 heller 1.207 (let ((symbol (parse-symbol string)))
1483 lgorrie 1.280 (valid-operator-symbol-p symbol)))
1484 heller 1.172
1485 lgorrie 1.284
1486     ;;;; Arglists
1487    
1488 mkoeppe 1.387 (defun find-valid-operator-name (names)
1489     "As a secondary result, returns its index."
1490     (let ((index
1491     (position-if (lambda (name)
1492     (or (consp name)
1493     (valid-operator-name-p name)))
1494     names)))
1495     (if index
1496     (values (elt names index) index)
1497     (values nil nil))))
1498    
1499 mkoeppe 1.365 (defslimefun arglist-for-echo-area (names &key print-right-margin
1500 mkoeppe 1.372 print-lines arg-indices)
1501 heller 1.148 "Return the arglist for the first function, macro, or special-op in NAMES."
1502 lgorrie 1.246 (handler-case
1503     (with-buffer-syntax ()
1504 mkoeppe 1.387 (multiple-value-bind (name which)
1505     (find-valid-operator-name names)
1506 mkoeppe 1.365 (when which
1507 mkoeppe 1.387 (let ((arg-index (and arg-indices (elt arg-indices which))))
1508 mkoeppe 1.365 (multiple-value-bind (form operator-name)
1509     (operator-designator-to-form name)
1510     (let ((*print-right-margin* print-right-margin))
1511     (format-arglist-for-echo-area
1512     form operator-name
1513     :print-right-margin print-right-margin
1514 mkoeppe 1.372 :print-lines print-lines
1515 mkoeppe 1.369 :highlight (and arg-index
1516     (not (zerop arg-index))
1517 mkoeppe 1.365 ;; don't highlight the operator
1518     arg-index))))))))
1519 lgorrie 1.246 (error (cond)
1520     (format nil "ARGLIST: ~A" cond))))
1521 heller 1.172
1522 mkoeppe 1.362 (defun operator-designator-to-form (name)
1523     (etypecase name
1524     (cons
1525     (destructure-case name
1526 mkoeppe 1.382 ((:make-instance class-name operator-name &rest args)
1527 mkoeppe 1.374 (let ((parsed-operator-name (parse-symbol operator-name)))
1528 mkoeppe 1.382 (values `(,parsed-operator-name ,@args ',(parse-symbol class-name))
1529 mkoeppe 1.374 operator-name)))
1530 mkoeppe 1.362 ((:defmethod generic-name)
1531     (values `(defmethod ,(parse-symbol generic-name))
1532     'defmethod))))
1533     (string
1534     (values `(,(parse-symbol name))
1535     name))))
1536    
1537 heller 1.266 (defun clean-arglist (arglist)
1538     "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1539     (cond ((null arglist) '())
1540     ((member (car arglist) '(&whole &environment))
1541     (clean-arglist (cddr arglist)))
1542     ((eq (car arglist) '&aux)
1543     '())
1544     (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1545    
1546 mkoeppe 1.387 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1547     provided-args ; list of the provided actual arguments
1548     required-args ; list of the required arguments
1549     optional-args ; list of the optional arguments
1550     key-p ; whether &key appeared
1551     keyword-args ; list of the keywords
1552     rest ; name of the &rest or &body argument (if any)
1553     body-p ; whether the rest argument is a &body
1554     allow-other-keys-p ; whether &allow-other-keys appeared
1555     aux-args ; list of &aux variables
1556     known-junk ; &whole, &environment
1557     unknown-junk) ; unparsed stuff
1558    
1559     (defun print-arglist (arglist &key operator highlight)
1560     (let ((index 0)
1561     (need-space nil))
1562     (labels ((print-arg (arg)
1563 heller 1.389 (typecase arg
1564 mkoeppe 1.387 (arglist ; destructuring pattern
1565     (print-arglist arg))
1566     (optional-arg
1567     (princ (encode-optional-arg arg)))
1568     (keyword-arg
1569     (let ((enc-arg (encode-keyword-arg arg)))
1570     (etypecase enc-arg
1571     (symbol (princ enc-arg))
1572     ((cons symbol)
1573     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1574     (princ (car enc-arg))
1575     (write-char #\space)
1576     (pprint-fill *standard-output* (cdr enc-arg) nil)))
1577     ((cons cons)
1578     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1579     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1580     (prin1 (caar enc-arg))
1581     (write-char #\space)
1582     (print-arg (keyword-arg.arg-name arg)))
1583     (unless (null (cdr enc-arg))
1584     (write-char #\space))
1585     (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1586     (t ; required formal or provided actual arg
1587     (princ arg))))
1588     (print-space ()
1589     (ecase need-space
1590     ((nil))
1591     ((:miser)
1592     (write-char #\space)
1593     (pprint-newline :miser))
1594     ((t)
1595     (write-char #\space)
1596     (pprint-newline :fill)))
1597     (setq need-space t))
1598     (print-with-space (obj)
1599     (print-space)
1600     (print-arg obj))
1601     (print-with-highlight (arg &optional (index-ok-p #'=))
1602     (print-space)
1603     (cond
1604     ((and highlight (funcall index-ok-p index highlight))
1605     (princ "===> ")
1606     (print-arg arg)
1607     (princ " <==="))
1608     (t
1609     (print-arg arg)))
1610     (incf index)))
1611     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1612     (when operator
1613     (print-with-highlight operator)
1614     (setq need-space :miser))
1615     (mapc #'print-with-highlight
1616     (arglist.provided-args arglist))
1617     (mapc #'print-with-highlight
1618     (arglist.required-args arglist))
1619     (when (arglist.optional-args arglist)
1620     (print-with-space '&optional)
1621     (mapc #'print-with-highlight
1622     (arglist.optional-args arglist)))
1623     (when (arglist.key-p arglist)
1624     (print-with-space '&key)
1625     (mapc #'print-with-space
1626     (arglist.keyword-args arglist)))
1627     (when (arglist.allow-other-keys-p arglist)
1628     (print-with-space '&allow-other-keys))
1629     (cond ((not (arglist.rest arglist)))
1630     ((arglist.body-p arglist)
1631     (print-with-space '&body)
1632     (print-with-highlight (arglist.rest arglist) #'<=))
1633     (t
1634     (print-with-space '&rest)
1635     (print-with-highlight (arglist.rest arglist) #'<=)))
1636     (mapc #'print-with-space
1637     (arglist.unknown-junk arglist))))))
1638    
1639 mkoeppe 1.372 (defun decoded-arglist-to-string (arglist package
1640     &key operator print-right-margin
1641     print-lines highlight)
1642     "Print the decoded ARGLIST for display in the echo area. The
1643     argument name are printed without package qualifiers and pretty
1644     printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
1645     non-nil, it must be the index of an argument; highlight this argument.
1646     If OPERATOR is non-nil, put it in front of the arglist."
1647     (with-output-to-string (*standard-output*)
1648     (with-standard-io-syntax
1649     (let ((*package* package) (*print-case* :downcase)
1650     (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1651     (*print-level* 10) (*print-length* 20)
1652     (*print-right-margin* print-right-margin)
1653     (*print-lines* print-lines))
1654 mkoeppe 1.387 (print-arglist arglist :operator operator :highlight highlight)))))
1655 mkoeppe 1.372
1656 lgorrie 1.217 (defslimefun variable-desc-for-echo-area (variable-name)
1657     "Return a short description of VARIABLE-NAME, or NIL."
1658     (with-buffer-syntax ()
1659     (let ((sym (parse-symbol variable-name)))
1660     (if (and sym (boundp sym))
1661 heller 1.222 (let ((*print-pretty* nil) (*print-level* 4)
1662     (*print-length* 10) (*print-circle* t))
1663     (format nil "~A => ~A" sym (symbol-value sym)))))))
1664 heller 1.72
1665 mkoeppe 1.387 (defun decode-required-arg (arg)
1666     "ARG can be a symbol or a destructuring pattern."
1667     (etypecase arg
1668     (symbol arg)
1669     (list (decode-arglist arg))))
1670    
1671     (defun encode-required-arg (arg)
1672     (etypecase arg
1673     (symbol arg)
1674     (arglist (encode-arglist arg))))
1675    
1676 lgorrie 1.284 (defstruct (keyword-arg
1677     (:conc-name keyword-arg.)
1678     (:constructor make-keyword-arg (keyword arg-name default-arg)))
1679     keyword
1680     arg-name
1681     default-arg)
1682    
1683 heller 1.276 (defun decode-keyword-arg (arg)
1684     "Decode a keyword item of formal argument list.
1685     Return three values: keyword, argument name, default arg."
1686     (cond ((symbolp arg)
1687 lgorrie 1.284 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1688     arg
1689     nil))
1690 heller 1.276 ((and (consp arg)
1691     (consp (car arg)))
1692 lgorrie 1.284 (make-keyword-arg (caar arg)
1693 mkoeppe 1.387 (decode-required-arg (cadar arg))
1694 lgorrie 1.284 (cadr arg)))
1695 heller 1.276 ((consp arg)
1696 lgorrie 1.284 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1697     (car arg)
1698     (cadr arg)))
1699 heller 1.276 (t
1700 mbaringer 1.399 (abort-request "Bad keyword item of formal argument list"))))
1701 heller 1.276
1702 lgorrie 1.284 (defun encode-keyword-arg (arg)
1703 mkoeppe 1.387 (cond
1704     ((arglist-p (keyword-arg.arg-name arg))
1705     ;; Destructuring pattern
1706     (let ((keyword/name (list (keyword-arg.keyword arg)
1707     (encode-required-arg
1708     (keyword-arg.arg-name arg)))))
1709     (if (keyword-arg.default-arg arg)
1710     (list keyword/name
1711     (keyword-arg.default-arg arg))
1712     (list keyword/name))))
1713     ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1714     keyword-package)
1715     (keyword-arg.keyword arg))
1716     (if (keyword-arg.default-arg arg)
1717     (list (keyword-arg.arg-name arg)
1718     (keyword-arg.default-arg arg))
1719     (keyword-arg.arg-name arg)))
1720     (t
1721     (let ((keyword/name (list (keyword-arg.keyword arg)
1722     (keyword-arg.arg-name arg))))
1723     (if (keyword-arg.default-arg arg)
1724     (list keyword/name
1725     (keyword-arg.default-arg arg))
1726     (list keyword/name))))))
1727 heller 1.276
1728     (progn
1729 lgorrie 1.284 (assert (equalp (decode-keyword-arg 'x)
1730 lgorrie 1.285 (make-keyword-arg :x 'x nil)))
1731 lgorrie 1.284 (assert (equalp (decode-keyword-arg '(x t))
1732 lgorrie 1.285 (make-keyword-arg :x 'x t)))
1733     (assert (equalp (decode-keyword-arg '((:x y)))
1734 lgorrie 1.284 (make-keyword-arg :x 'y nil)))
1735 lgorrie 1.285 (assert (equalp (decode-keyword-arg '((:x y) t))
1736 lgorrie 1.284 (make-keyword-arg :x 'y t))))
1737    
1738     (defstruct (optional-arg
1739     (:conc-name optional-arg.)
1740     (:constructor make-optional-arg (arg-name default-arg)))
1741     arg-name
1742     default-arg)
1743 heller 1.276
1744     (defun decode-optional-arg (arg)
1745     "Decode an optional item of a formal argument list.
1746 lgorrie 1.284 Return an OPTIONAL-ARG structure."
1747 heller 1.276 (etypecase arg
1748 lgorrie 1.284 (symbol (make-optional-arg arg nil))
1749 mkoeppe 1.387 (list (make-optional-arg (decode-required-arg (car arg))
1750     (cadr arg)))))
1751 lgorrie 1.284
1752     (defun encode-optional-arg (optional-arg)
1753 mkoeppe 1.387 (if (or (optional-arg.default-arg optional-arg)
1754     (arglist-p (optional-arg.arg-name optional-arg)))
1755     (list (encode-required-arg
1756     (optional-arg.arg-name optional-arg))
1757 lgorrie 1.284 (optional-arg.default-arg optional-arg))
1758     (optional-arg.arg-name optional-arg)))
1759 heller 1.276
1760     (progn
1761 lgorrie 1.284 (assert (equalp (decode-optional-arg 'x)
1762     (make-optional-arg 'x nil)))
1763     (assert (equalp (decode-optional-arg '(x t))
1764     (make-optional-arg 'x t))))
1765 heller 1.276
1766 mkoeppe 1.372 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1767 lgorrie 1.280
1768     (defun decode-arglist (arglist)
1769 lgorrie 1.284 "Parse the list ARGLIST and return an ARGLIST structure."
1770 lgorrie 1.280 (let ((mode nil)
1771     (result (make-arglist)))
1772     (dolist (arg arglist)
1773 lgorrie 1.284 (cond
1774 mkoeppe 1.372 ((eql mode '&unknown-junk)
1775     ;; don't leave this mode -- we don't know how the arglist
1776     ;; after unknown lambda-list keywords is interpreted
1777     (push arg (arglist.unknown-junk result)))
1778 lgorrie 1.284 ((eql arg '&allow-other-keys)
1779     (setf (arglist.allow-other-keys-p result) t))
1780     ((eql arg '&key)
1781     (setf (arglist.key-p result) t
1782     mode arg))
1783 mkoeppe 1.372 ((member arg '(&optional &rest &body &aux))
1784     (setq mode arg))
1785     ((member arg '(&whole &environment))
1786     (setq mode arg)
1787     (push arg (arglist.known-junk result)))
1788 lgorrie 1.284 ((member arg lambda-list-keywords)
1789 mkoeppe 1.372 (setq mode '&unknown-junk)
1790     (push arg (arglist.unknown-junk result)))
1791 lgorrie 1.284 (t
1792 mkoeppe 1.372 (ecase mode
1793 lgorrie 1.280 (&key
1794     (push (decode-keyword-arg arg)
1795     (arglist.keyword-args result)))
1796     (&optional
1797     (push (decode-optional-arg arg)
1798     (arglist.optional-args result)))
1799     (&body
1800     (setf (arglist.body-p result) t
1801     (arglist.rest result) arg))
1802     (&rest
1803     (setf (arglist.rest result) arg))
1804 mkoeppe 1.372 (&aux
1805     (push (decode-optional-arg arg)
1806     (arglist.aux-args result)))
1807 lgorrie 1.280 ((nil)
1808 mkoeppe 1.387 (push (decode-required-arg arg)
1809     (arglist.required-args result)))
1810 lgorrie 1.284 ((&whole &environment)
1811 mkoeppe 1.372 (setf mode nil)
1812     (push arg (arglist.known-junk result)))))))
1813     (nreversef (arglist.required-args result))
1814     (nreversef (arglist.optional-args result))
1815     (nreversef (arglist.keyword-args result))
1816     (nreversef (arglist.aux-args result))
1817     (nreversef (arglist.known-junk result))
1818     (nreversef (arglist.unknown-junk result))
1819 lgorrie 1.280 result))
1820    
1821 lgorrie 1.284 (defun encode-arglist (decoded-arglist)
1822 mkoeppe 1.387 (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
1823 lgorrie 1.284 (when (arglist.optional-args decoded-arglist)
1824     '(&optional))
1825     (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1826     (when (arglist.key-p decoded-arglist)
1827     '(&key))
1828     (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1829     (when (arglist.allow-other-keys-p decoded-arglist)
1830     '(&allow-other-keys))
1831     (cond ((not (arglist.rest decoded-arglist))
1832     '())
1833     ((arglist.body-p decoded-arglist)
1834     `(&body ,(arglist.rest decoded-arglist)))
1835     (t
1836 mkoeppe 1.372 `(&rest ,(arglist.rest decoded-arglist))))
1837     (when (arglist.aux-args decoded-arglist)
1838     `(&aux ,(arglist.aux-args decoded-arglist)))
1839     (arglist.known-junk decoded-arglist)
1840     (arglist.unknown-junk decoded-arglist)))
1841 lgorrie 1.284
1842 lgorrie 1.280 (defun arglist-keywords (arglist)
1843     "Return the list of keywords in ARGLIST.
1844     As a secondary value, return whether &allow-other-keys appears."
1845     (let ((decoded-arglist (decode-arglist arglist)))
1846     (values (arglist.keyword-args decoded-arglist)
1847     (arglist.allow-other-keys-p decoded-arglist))))
1848    
1849     (defun methods-keywords (methods)
1850     "Collect all keywords in the arglists of METHODS.
1851     As a secondary value, return whether &allow-other-keys appears somewhere."
1852     (let ((keywords '())
1853     (allow-other-keys nil))
1854     (dolist (method methods)
1855     (multiple-value-bind (kw aok)
1856     (arglist-keywords
1857     (swank-mop:method-lambda-list method))
1858 lgorrie 1.284 (setq keywords (remove-duplicates (append keywords kw)
1859     :key #'keyword-arg.keyword)
1860 lgorrie 1.280 allow-other-keys (or allow-other-keys aok))))
1861     (values keywords allow-other-keys)))
1862    
1863     (defun generic-function-keywords (generic-function)
1864     "Collect all keywords in the methods of GENERIC-FUNCTION.
1865     As a secondary value, return whether &allow-other-keys appears somewhere."
1866     (methods-keywords
1867     (swank-mop:generic-function-methods generic-function)))
1868    
1869 crhodes 1.376 (defun applicable-methods-keywords (generic-function arguments)
1870 lgorrie 1.280 "Collect all keywords in the methods of GENERIC-FUNCTION that are
1871     applicable for argument of CLASSES. As a secondary value, return
1872     whether &allow-other-keys appears somewhere."
1873 crhodes 1.376 (methods-keywords
1874     (multiple-value-bind (amuc okp)
1875     (swank-mop:compute-applicable-methods-using-classes
1876     generic-function (mapcar #'class-of arguments))
1877     (if okp
1878     amuc
1879     (compute-applicable-methods generic-function arguments)))))
1880 lgorrie 1.280
1881     (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1882     (with-output-to-string (*standard-output*)
1883     (with-standard-io-syntax
1884     (let ((*package* package) (*print-case* :downcase)
1885     (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1886     (*print-level* 10) (*print-length* 20))
1887 mkoeppe 1.387 (print-decoded-arglist-as-template decoded-arglist
1888     :prefix prefix
1889     :suffix suffix)))))
1890    
1891     (defun print-decoded-arglist-as-template (decoded-arglist &key
1892     (prefix "(") (suffix ")"))
1893     (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1894     (let ((first-p t))
1895     (flet ((space ()
1896     (unless first-p
1897     (write-char #\space)
1898     (pprint-newline :fill))
1899     (setq first-p nil))
1900     (print-arg-or-pattern (arg)
1901     (etypecase arg
1902     (symbol (princ arg))
1903     (string (princ arg))
1904     (list (princ arg))
1905     (arglist (print-decoded-arglist-as-template arg)))))
1906     (dolist (arg (arglist.required-args decoded-arglist))
1907     (space)
1908     (print-arg-or-pattern arg))
1909     (dolist (arg (arglist.optional-args decoded-arglist))
1910     (space)
1911     (princ "[")
1912     (print-arg-or-pattern (optional-arg.arg-name arg))
1913     (princ "]"))
1914     (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1915     (space)
1916     (let ((arg-name (keyword-arg.arg-name keyword-arg))
1917     (keyword (keyword-arg.keyword keyword-arg)))
1918     (format t "~W "
1919     (if (keywordp keyword) keyword `',keyword))
1920     (print-arg-or-pattern arg-name)))
1921     (when (and (arglist.rest decoded-arglist)
1922     (or (not (arglist.keyword-args decoded-arglist))
1923     (arglist.allow-other-keys-p decoded-arglist)))
1924     (if (arglist.body-p decoded-arglist)
1925     (pprint-newline :mandatory)
1926     (space))
1927     (format t "~A..." (arglist.rest decoded-arglist)))))
1928     (pprint-newline :fill)))
1929 lgorrie 1.280
1930     (defgeneric extra-keywords (operator &rest args)
1931 lgorrie 1.284 (:documentation "Return a list of extra keywords of OPERATOR (a
1932 mkoeppe 1.360 symbol) when applied to the (unevaluated) ARGS.
1933     As a secondary value, return whether other keys are allowed.
1934     As a tertiary value, return the initial sublist of ARGS that was needed
1935     to determine the extra keywords."))
1936 lgorrie 1.280
1937     (defmethod extra-keywords (operator &rest args)
1938     ;; default method
1939     (declare (ignore args))
1940     (let ((symbol-function (symbol-function operator)))
1941     (if (typep symbol-function 'generic-function)
1942     (generic-function-keywords symbol-function)
1943     nil)))
1944    
1945 crhodes 1.376 (defun class-from-class-name-form (class-name-form)
1946     (when (and (listp class-name-form)
1947     (= (length class-name-form) 2)
1948     (eq (car class-name-form) 'quote))
1949     (let* ((class-name (cadr class-name-form))
1950     (class (find-class class-name nil)))
1951     (when (and class
1952     (not (swank-mop:class-finalized-p class)))
1953     ;; Try to finalize the class, which can fail if
1954     ;; superclasses are not defined yet
1955     (handler-case (swank-mop:finalize-inheritance class)
1956     (program-error (c)
1957     (declare (ignore c)))))
1958     class)))
1959    
1960     (defun extra-keywords/slots (class)
1961     (multiple-value-bind (slots allow-other-keys-p)
1962     (if (swank-mop:class-finalized-p class)
1963     (values (swank-mop:class-slots class) nil)
1964     (values (swank-mop:class-direct-slots class) t))
1965     (let ((slot-init-keywords
1966     (loop for slot in slots append
1967     (mapcar (lambda (initarg)
1968     (make-keyword-arg
1969     initarg
1970     (swank-mop:slot-definition-name slot)
1971     (swank-mop:slot-definition-initform slot)))
1972     (swank-mop:slot-definition-initargs slot)))))
1973     (values slot-init-keywords allow-other-keys-p))))
1974    
1975 mkoeppe 1.374 (defun extra-keywords/make-instance (operator &rest args)
1976     (declare (ignore operator))
1977 lgorrie 1.280 (unless (null args)
1978 crhodes 1.376 (let* ((class-name-form (car args))
1979     (class (class-from-class-name-form class-name-form)))
1980     (when class
1981     (multiple-value-bind (slot-init-keywords class-aokp)
1982     (extra-keywords/slots class)
1983     (multiple-value-bind (allocate-instance-keywords ai-aokp)
1984     (applicable-methods-keywords
1985     #'allocate-instance (list class))
1986     (multiple-value-bind (initialize-instance-keywords ii-aokp)
1987     (applicable-methods-keywords
1988     #'initialize-instance (list (swank-mop:class-prototype class)))
1989     (multiple-value-bind (shared-initialize-keywords si-aokp)
1990     (applicable-methods-keywords
1991     #'shared-initialize (list (swank-mop:class-prototype class) t))
1992     (values (append slot-init-keywords
1993     allocate-instance-keywords
1994     initialize-instance-keywords
1995     shared-initialize-keywords)
1996     (or class-aokp ai-aokp ii-aokp si-aokp)
1997     (list class-name-form))))))))))
1998    
1999     (defun extra-keywords/change-class (operator &rest args)
2000     (declare (ignore operator))
2001     (unless (null args)
2002     (let* ((class-name-form (car args))
2003     (class (class-from-class-name-form class-name-form)))
2004     (when class
2005     (multiple-value-bind (slot-init-keywords class-aokp)
2006     (extra-keywords/slots class)
2007     (declare (ignore class-aokp))
2008     (multiple-value-bind (shared-initialize-keywords si-aokp)
2009     (applicable-methods-keywords
2010     #'shared-initialize (list (swank-mop:class-prototype class) t))
2011     ;; FIXME: much as it would be nice to include the
2012     ;; applicable keywords from
2013     ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
2014     ;; how to do it: so we punt, always declaring
2015     ;; &ALLOW-OTHER-KEYS.
2016     (declare (ignore si-aokp))
2017     (values (append slot-init-keywords shared-initialize-keywords)
2018     t
2019     (list class-name-form))))))))
2020 mkoeppe 1.374
2021 mkoeppe 1.375 (defmacro multiple-value-or (&rest forms)
2022     (if (null forms)
2023     nil
2024     (let ((first (first forms))
2025     (rest (rest forms)))
2026     `(let* ((values (multiple-value-list ,first))
2027     (primary-value (first values)))
2028     (if primary-value
2029     (values-list values)
2030     (multiple-value-or ,@rest))))))
2031    
2032 mkoeppe 1.374 (defmethod extra-keywords ((operator (eql 'make-instance))
2033     &rest args)
2034 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2035     (call-next-method)))
2036 mkoeppe 1.374
2037     (defmethod extra-keywords ((operator (eql 'make-condition))
2038     &rest args)
2039 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2040     (call-next-method)))
2041 mkoeppe 1.374
2042     (defmethod extra-keywords ((operator (eql 'error))
2043     &rest args)
2044 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2045     (call-next-method)))
2046 mkoeppe 1.374
2047     (defmethod extra-keywords ((operator (eql 'signal))
2048     &rest args)
2049 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2050     (call-next-method)))
2051 mkoeppe 1.374
2052     (defmethod extra-keywords ((operator (eql 'warn))
2053     &rest args)
2054 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2055     (call-next-method)))
2056 mkoeppe 1.374
2057     (defmethod extra-keywords ((operator (eql 'cerror))
2058     &rest args)
2059 mkoeppe 1.381 (multiple-value-bind (keywords aok determiners)
2060     (apply #'extra-keywords/make-instance operator
2061     (cdr args))
2062     (if keywords
2063     (values keywords aok
2064     (cons (car args) determiners))
2065     (call-next-method))))
2066 heller 1.276
2067 crhodes 1.376 (defmethod extra-keywords ((operator (eql 'change-class))
2068     &rest args)
2069 mkoeppe 1.385 (multiple-value-bind (keywords aok determiners)
2070     (apply #'extra-keywords/change-class operator (cdr args))
2071     (if keywords
2072     (values keywords aok
2073     (cons (car args) determiners))
2074     (call-next-method))))
2075 crhodes 1.376
2076 mkoeppe 1.387 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
2077     "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
2078     (when keywords
2079     (setf (arglist.key-p decoded-arglist) t)
2080     (setf (arglist.keyword-args decoded-arglist)
2081     (remove-duplicates
2082     (append (arglist.keyword-args decoded-arglist)
2083     keywords)
2084     :key #'keyword-arg.keyword)))
2085     (setf (arglist.allow-other-keys-p decoded-arglist)
2086     (or (arglist.allow-other-keys-p decoded-arglist)
2087     allow-other-keys-p)))
2088    
2089 lgorrie 1.284 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
2090 mkoeppe 1.360 "Determine extra keywords from the function call FORM, and modify
2091     DECODED-ARGLIST to include them. As a secondary return value, return
2092     the initial sublist of ARGS that was needed to determine the extra
2093     keywords. As a tertiary return value, return whether any enrichment
2094     was done."
2095     (multiple-value-bind (extra-keywords extra-aok determining-args)
2096 lgorrie 1.284 (apply #'extra-keywords form)
2097     ;; enrich the list of keywords with the extra keywords
2098 mkoeppe 1.387 (enrich-decoded-arglist-with-keywords decoded-arglist
2099     extra-keywords extra-aok)
2100 mkoeppe 1.360 (values decoded-arglist
2101     determining-args
2102     (or extra-keywords extra-aok))))
2103 lgorrie 1.284
2104 mkoeppe 1.387 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
2105     (:documentation
2106     "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2107     ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2108     If the arglist is not available, return :NOT-AVAILABLE."))
2109    
2110     (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2111     (let ((arglist (arglist operator-form)))
2112     (etypecase arglist
2113     ((member :not-available)
2114     :not-available)
2115     (list
2116     (let ((decoded-arglist (decode-arglist arglist)))
2117     (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2118     (cons operator-form
2119     argument-forms)))))))
2120    
2121     (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2122     argument-forms)
2123 mkoeppe 1.393 (declare (ignore argument-forms))
2124 mkoeppe 1.387 (multiple-value-bind (decoded-arglist determining-args)
2125     (call-next-method)
2126     (let ((first-arg (first (arglist.required-args decoded-arglist)))
2127     (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2128     (when (and (arglist-p first-arg) (arglist-p open-arglist))
2129     (enrich-decoded-arglist-with-keywords
2130     first-arg
2131     (arglist.keyword-args open-arglist)
2132     nil)))
2133     (values decoded-arglist determining-args t)))
2134    
2135 mkoeppe 1.391 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
2136     argument-forms)
2137     (let ((function-name-form (car argument-forms)))
2138     (when (and (listp function-name-form)
2139     (= (length function-name-form) 2)
2140     (member (car function-name-form) '(quote function)))
2141     (let ((function-name (cadr function-name-form)))
2142     (when (valid-operator-symbol-p function-name)
2143     (let ((function-arglist
2144     (compute-enriched-decoded-arglist function-name
2145     (cdr argument-forms))))
2146     (return-from compute-enriched-decoded-arglist
2147     (values (make-arglist :required-args
2148     (list 'function)
2149     :optional-args
2150     (append
2151     (mapcar #'(lambda (arg)
2152     (make-optional-arg arg nil))
2153     (arglist.required-args function-arglist))
2154     (arglist.optional-args function-arglist))
2155     :key-p
2156     (arglist.key-p function-arglist)
2157     :keyword-args
2158     (arglist.keyword-args function-arglist)
2159     :rest
2160     'args
2161     :allow-other-keys-p
2162     (arglist.allow-other-keys-p function-arglist))
2163     (list function-name-form)
2164     t)))))))
2165     (call-next-method))
2166    
2167 heller 1.172 (defslimefun arglist-for-insertion (name)
2168 heller 1.207 (with-buffer-syntax ()
2169 lgorrie 1.280 (let ((symbol (parse-symbol name)))
2170     (cond
2171     ((and symbol
2172     (valid-operator-name-p name))
2173 mkoeppe 1.387 (let ((decoded-arglist
2174     (compute-enriched-decoded-arglist symbol nil)))
2175     (if (eql decoded-arglist :not-available)
2176     :not-available
2177     (decoded-arglist-to-template-string decoded-arglist
2178     *buffer-package*))))
2179 lgorrie 1.280 (t
2180     :not-available)))))
2181    
2182 lgorrie 1.284 (defvar *remove-keywords-alist*
2183     '((:test :test-not)
2184     (:test-not :test)))
2185    
2186 lgorrie 1.280 (defun remove-actual-args (decoded-arglist actual-arglist)
2187     "Remove from DECODED-ARGLIST the arguments that have already been
2188     provided in ACTUAL-ARGLIST."
2189     (loop while (and actual-arglist
2190     (arglist.required-args decoded-arglist))
2191     do (progn (pop actual-arglist)
2192     (pop (arglist.required-args decoded-arglist))))
2193     (loop while (and actual-arglist
2194     (arglist.optional-args decoded-arglist))
2195     do (progn (pop actual-arglist)
2196     (pop (arglist.optional-args decoded-arglist))))
2197     (loop for keyword in actual-arglist by #'cddr
2198 lgorrie 1.284 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
2199 lgorrie 1.280 do (setf (arglist.keyword-args decoded-arglist)
2200 lgorrie 1.284 (remove-if (lambda (kw)
2201     (or (eql kw keyword)
2202     (member kw keywords-to-remove)))
2203     (arglist.keyword-args decoded-arglist)
2204     :key #'keyword-arg.keyword))))
2205 lgorrie 1.280
2206 mkoeppe 1.360 (defgeneric form-completion (operator-form argument-forms &key remove-args))
2207 mkoeppe 1.319
2208 mkoeppe 1.360 (defmethod form-completion (operator-form argument-forms &key (remove-args t))
2209 mkoeppe 1.319 (when (and (symbolp operator-form)
2210     (valid-operator-symbol-p operator-form))
2211 mkoeppe 1.387 (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2212     (compute-enriched-decoded-arglist operator-form argument-forms)
2213     (etypecase decoded-arglist
2214 mkoeppe 1.319 ((member :not-available)
2215     :not-available)
2216 mkoeppe 1.387 (arglist
2217     (cond
2218     (remove-args
2219     ;; get rid of formal args already provided
2220     (remove-actual-args decoded-arglist argument-forms))
2221     (t
2222     ;; replace some formal args by determining actual args
2223     (remove-actual-args decoded-arglist determining-args)
2224     (setf (arglist.provided-args decoded-arglist)
2225     determining-args)))
2226     (return-from form-completion
2227     (values decoded-arglist any-enrichment))))))
2228 mkoeppe 1.319 :not-available)
2229    
2230     (defmethod form-completion ((operator-form (eql 'defmethod))
2231 mkoeppe 1.360 argument-forms &key (remove-args t))
2232 mkoeppe 1.319 (when (and (listp argument-forms)
2233     (not (null argument-forms)) ;have generic function name
2234     (notany #'listp (rest argument-forms))) ;don't have arglist yet
2235     (let* ((gf-name (first argument-forms))
2236     (gf (and (or (symbolp gf-name)
2237     (and (listp gf-name)
2238     (eql (first gf-name) 'setf)))
2239     (fboundp gf-name)
2240     (fdefinition gf-name))))
2241     (when (typep gf 'generic-function)
2242     (let ((arglist (arglist gf)))
2243     (etypecase arglist
2244     ((member :not-available))
2245     (list
2246     (return-from form-completion
2247 mkoeppe 1.384 (values (make-arglist :provided-args (if remove-args
2248     nil
2249     (list gf-name))
2250     :required-args (list arglist)
2251 mkoeppe 1.360 :rest "body" :body-p t)
2252     t))))))))
2253 mkoeppe 1.319 (call-next-method))
2254    
2255 mkoeppe 1.360 (defun read-incomplete-form-from-string (form-string)
2256     (with-buffer-syntax ()
2257     (handler-case
2258     (read-from-string form-string)
2259     (reader-error (c)
2260     (declare (ignore c))
2261     nil)
2262     (stream-error (c)
2263     (declare (ignore c))
2264     nil))))
2265    
2266 lgorrie 1.280 (defslimefun complete-form (form-string)
2267     "Read FORM-STRING in the current buffer package, then complete it
2268     by adding a template for the missing arguments."
2269 mkoeppe 1.360 (let ((form (read-incomplete-form-from-string form-string)))
2270     (when (consp form)
2271     (let ((operator-form (first form))
2272     (argument-forms (rest form)))
2273     (let ((form-completion
2274     (form-completion operator-form argument-forms)))
2275     (unless (eql form-completion :not-available)
2276     (return-from complete-form
2277     (decoded-arglist-to-template-string form-completion
2278     *buffer-package*
2279     :prefix ""))))))
2280     :not-available))
2281    
2282 mkoeppe 1.364 (defun format-arglist-for-echo-area (form operator-name
2283 mkoeppe 1.372 &key print-right-margin print-lines
2284     highlight)
2285 mkoeppe 1.360 "Return the arglist for FORM as a string."
2286     (when (consp form)
2287 mbaringer 1.397 (destructuring-bind (operator-form &rest argument-forms)
2288     form
2289 mkoeppe 1.372 (let ((form-completion
2290     (form-completion operator-form argument-forms
2291     :remove-args nil)))
2292     (unless (eql form-completion :not-available)
2293     (return-from format-arglist-for-echo-area
2294     (decoded-arglist-to-string
2295     form-completion
2296     *package*
2297     :operator operator-name
2298     :print-right-margin print-right-margin
2299     :print-lines print-lines
2300     :highlight highlight))))))
2301 mkoeppe 1.360 nil)
2302 heller 1.172
2303 mkoeppe 1.386 (defun keywords-of-operator (operator)
2304     "Return a list of KEYWORD-ARGs that OPERATOR accepts.
2305     This function is useful for writing EXTRA-KEYWORDS methods for
2306     user-defined functions which are declared &ALLOW-OTHER-KEYS and which
2307     forward keywords to OPERATOR."
2308     (let ((arglist (form-completion operator nil
2309     :remove-args nil)))
2310     (unless (eql arglist :not-available)
2311     (values
2312     (arglist.keyword-args arglist)
2313     (arglist.allow-other-keys-p arglist)))))
2314    
2315 mkoeppe 1.387 (defun arglist-ref (decoded-arglist operator &rest indices)
2316     (cond
2317     ((null indices) decoded-arglist)
2318     ((not (arglist-p decoded-arglist)) nil)
2319     (t
2320     (let ((index (first indices))
2321     (args (append (and operator
2322     (list operator))
2323     (arglist.required-args decoded-arglist)
2324     (arglist.optional-args decoded-arglist))))
2325     (when (< index (length args))
2326     (let ((arg (elt args index)))
2327     (apply #'arglist-ref arg nil (rest indices))))))))
2328    
2329     (defslimefun completions-for-keyword (names keyword-string arg-indices)
2330 mkoeppe 1.404 (with-buffer-syntax ()
2331     (multiple-value-bind (name index)
2332     (find-valid-operator-name names)
2333     (when name
2334     (let* ((form (operator-designator-to-form name))
2335     (operator-form (first form))
2336     (argument-forms (rest form))
2337     (arglist
2338     (form-completion operator-form argument-forms
2339     :remove-args nil)))
2340     (unless (eql arglist :not-available)
2341     (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2342     (arglist (apply #'arglist-ref arglist operator-form indices)))
2343     (when (and arglist (arglist-p arglist))
2344     ;; It would be possible to complete keywords only if we
2345     ;; are in a keyword position, but it is not clear if we
2346     ;; want that.
2347     (let* ((keywords
2348     (mapcar #'keyword-arg.keyword
2349     (arglist.keyword-args arglist)))
2350     (keyword-name
2351     (tokenize-symbol keyword-string))
2352     (matching-keywords
2353     (find-matching-symbols-in-list keyword-name keywords
2354     #'compound-prefix-match))
2355 mbaringer 1.411 (converter (completion-output-symbol-converter keyword-string))
2356 mkoeppe 1.404 (strings
2357     (mapcar converter
2358     (mapcar #'symbol-name matching-keywords)))
2359     (completion-set
2360     (format-completion-set strings nil "")))
2361     (list completion-set
2362     (longest-completion completion-set)))))))))))
2363 mkoeppe 1.362
2364    
2365 mkoeppe 1.373 (defun arglist-to-string (arglist package &key print-right-margin highlight)
2366     (decoded-arglist-to-string (decode-arglist arglist)
2367     package
2368     :print-right-margin print-right-margin
2369     :highlight highlight))
2370    
2371 heller 1.388 (defun test-print-arglist ()
2372     (flet ((test (list string)
2373     (let* ((p (find-package :swank))
2374     (actual (arglist-to-string list p)))
2375     (unless (string= actual string)
2376 heller 1.389 (warn "Test failed: ~S => ~S~% Expected: ~S"
2377     list actual string)))))
2378 heller 1.388 (test '(function cons) "(function cons)")
2379     (test '(quote cons) "(quote cons)")
2380     (test '(&key (function #'+)) "(&key (function #'+))")
2381     (test '(&whole x y z) "(y z)")
2382     (test '(x &aux y z) "(x)")
2383     (test '(x &environment env y) "(x y)")
2384     (test '(&key ((function f))) "(&key ((function f)))")))
2385 mkoeppe 1.373
2386 heller 1.388 (test-print-arglist)
2387 mkoeppe 1.373
2388 lgorrie 1.62
2389 mkoeppe 1.323 ;;;; Recording and accessing results of computations
2390    
2391     (defvar *record-repl-results* t
2392     "Non-nil means that REPL results are saved for later lookup.")
2393    
2394     (defvar *object-to-presentation-id*
2395 mkoeppe 1.326 (make-weak-key-hash-table :test 'eq)
2396 mkoeppe 1.323 "Store the mapping of objects to numeric identifiers")
2397    
2398     (defvar *presentation-id-to-object*
2399 heller 1.331 (make-weak-value-hash-table :test 'eql)
2400 mkoeppe 1.323 "Store the mapping of numeric identifiers to objects")
2401    
2402     (defun clear-presentation-tables ()
2403     (clrhash *object-to-presentation-id*)
2404     (clrhash *presentation-id-to-object*))
2405    
2406     (defvar *presentation-counter* 0 "identifier counter")
2407    
2408 mkoeppe 1.392 (defvar *nil-surrogate* (make-symbol "nil-surrogate"))
2409    
2410 mbaringer 1.397 ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
2411     ;; rest of slime isn't thread safe either), do we really care?
2412 heller 1.331 (defun save-presented-object (object)
2413     "Save OBJECT and return the assigned id.
2414     If OBJECT was saved previously return the old id."
2415 mkoeppe 1.392 (let ((object (if (null object) *nil-surrogate* object)))
2416     ;; We store *nil-surrogate* instead of nil, to distinguish it from
2417     ;; an object that was garbage collected.
2418     (or (gethash object *object-to-presentation-id*)
2419     (let ((id (incf *presentation-counter*)))
2420     (setf (gethash id *presentation-id-to-object*) object)
2421     (setf (gethash object *object-to-presentation-id*) id)
2422     id))))
2423 mkoeppe 1.323
2424     (defun lookup-presented-object (id)
2425 heller 1.331 "Retrieve the object corresponding to ID.
2426 heller 1.337 The secondary value indicates the absence of an entry."
2427 mkoeppe 1.394 (etypecase id
2428     (integer
2429     ;;
2430     (multiple-value-bind (object foundp)
2431     (gethash id *presentation-id-to-object*)
2432     (cond
2433     ((eql object *nil-surrogate*)
2434     ;; A stored nil object
2435     (values nil t))
2436     ((null object)
2437     ;; Object that was replaced by nil in the weak hash table
2438     ;; when the object was garbage collected.
2439     (values nil nil))
2440     (t
2441     (values object foundp)))))
2442     (cons
2443     (destructure-case id
2444 mkoeppe 1.462 ((:frame-var thread-id frame index)
2445     (declare (ignore thread-id)) ; later
2446 mkoeppe 1.394 (handler-case
2447     (frame-var-value frame index)
2448     (t (condition)
2449     (declare (ignore condition))
2450 mkoeppe 1.395 (values nil nil))
2451     (:no-error (value)
2452     (values value t))))
2453 mkoeppe 1.394 ((:inspected-part part-index)
2454 mbaringer 1.397 (declare (special *inspectee-parts*))
2455 mkoeppe 1.394 (if (< part-index (length *inspectee-parts*))
2456     (values (inspector-nth-part part-index) t)
2457     (values nil nil)))))))
2458 mkoeppe 1.323
2459     (defslimefun get-repl-result (id)
2460     "Get the result of the previous REPL evaluation with ID."
2461 heller 1.331 (multiple-value-bind (object foundp) (lookup-presented-object id)
2462     (cond (foundp object)
2463 mbaringer 1.399 (t (abort-request "Attempt to access unrecorded object (id ~D)." id)))))
2464 mkoeppe 1.323
2465     (defslimefun clear-repl-results ()
2466     "Forget the results of all previous REPL evaluations."
2467     (clear-presentation-tables)
2468     t)
2469    
2470    
2471 lgorrie 1.218 ;;;; Evaluation
2472    
2473 heller 1.278 (defvar *pending-continuations* '()
2474     "List of continuations for Emacs. (thread local)")
2475    
2476 lgorrie 1.218 (defun guess-buffer-package (string)
2477     "Return a package for STRING.
2478     Fall back to the the current if no such package exists."
2479 heller 1.459 (or (and string (guess-package string))
2480 lgorrie 1.218 *package*))
2481    
2482     (defun eval-for-emacs (form buffer-package id)
2483 mbaringer 1.466 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2484 lgorrie 1.218 Return the result to the continuation ID.
2485     Errors are trapped and invoke our debugger."
2486 heller 1.281 (call-with-debugger-hook
2487     #'swank-debugger-hook
2488     (lambda ()
2489 mbaringer 1.399 (let (ok result reason)
2490 heller 1.281 (unwind-protect
2491     (let ((*buffer-package* (guess-buffer-package buffer-package))
2492     (*buffer-readtable* (guess-buffer-readtable buffer-package))
2493 heller 1.331 (*pending-continuations* (cons id *pending-continuations*)))
2494 heller 1.293 (check-type *buffer-package* package)
2495     (check-type *buffer-readtable* readtable)
2496 heller 1.353 ;; APPLY would be cleaner than EVAL.
2497     ;;(setq result (apply (car form) (cdr form)))
2498 mbaringer 1.399 (handler-case
2499     (progn
2500     (setq result (eval form))
2501     (run-hook *pre-reply-hook*)
2502     (finish-output)
2503     (setq ok t))
2504     (request-abort (c)
2505     (setf ok nil
2506     reason (list (slot-value c 'swank-backend::reason))))))
2507 heller 1.281 (force-user-output)
2508     (send-to-emacs `(:return ,(current-thread)
2509 mbaringer 1.399 ,(if ok
2510     `(:ok ,result)
2511     `(:abort ,@reason))
2512 heller 1.281 ,id)))))))
2513 lgorrie 1.218
2514 heller 1.337 (defvar *echo-area-prefix* "=> "
2515     "A prefix that `format-values-for-echo-area' should use.")
2516    
2517 lgorrie 1.218 (defun format-values-for-echo-area (values)
2518     (with-buffer-syntax ()
2519     (let ((*print-readably* nil))
2520 heller 1.242 (cond ((null values) "; No value")
2521     ((and (null (cdr values)) (integerp (car values)))
2522     (let ((i (car values)))
2523 heller 1.337 (format nil "~A~D (#x~X, #o~O, #b~B)"
2524     *echo-area-prefix* i i i i)))
2525 heller 1.456 (t (with-output-to-string (s)
2526 heller 1.458 (pprint-logical-block (s () :prefix *echo-area-prefix*)
2527 heller 1.456 (format s "~{~S~^, ~}" values))))))))
2528 lgorrie 1.218
2529     (defslimefun interactive-eval (string)
2530 heller 1.331 (with-buffer-syntax ()
2531     (let ((values (multiple-value-list (eval (from-string string)))))
2532     (fresh-line)
2533 heller 1.339 (finish-output)
2534 heller 1.332 (format-values-for-echo-area values))))
2535 lgorrie 1.218
2536 heller 1.278 (defslimefun eval-and-grab-output (string)
2537     (with-buffer-syntax ()
2538     (let* ((s (make-string-output-stream))
2539     (*standard-output* s)
2540 heller 1.293 (values (multiple-value-list (eval (from-string string)))))
2541 heller 1.278 (list (get-output-stream-string s)
2542     (format nil "~{~S~^~%~}" values)))))
2543    
2544 heller 1.331 ;;; XXX do we need this stuff? What is it good for?
2545 aruttenberg 1.298 (defvar *slime-repl-advance-history* nil
2546     "In the dynamic scope of a single form typed at the repl, is set to nil to