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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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