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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.405 - (hide annotations)
Mon Oct 16 19:58:45 2006 UTC (7 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.404: +46 -43 lines
Clean up global IO redirection.
(setup-stream-indirection): Turn macro into a
function and delay initialization after user init files are
loaded, so that we do nothing if *globally-redirect-io* is nil.
(*after-init-hook*, run-after-init-hook, init-global-stream-redirection): New.

(parse-symbol-or-lose): Lose loudly and early (instead of failing
silently).
1 heller 1.311 ;;; -*- outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-
2 dbarlow 1.27 ;;;
3 lgorrie 1.194 ;;; This code has been placed in the Public Domain. All warranties
4     ;;; are disclaimed.
5 dbarlow 1.27 ;;;
6 lgorrie 1.194 ;;;; swank.lisp
7 dbarlow 1.27 ;;;
8 lgorrie 1.194 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9     ;;; code in this file is purely portable Common Lisp. We do require a
10     ;;; smattering of non-portable functions in order to write the server,
11     ;;; so we have defined them in `swank-backend.lisp' and implemented
12     ;;; them separately for each Lisp implementation. These extensions are
13     ;;; available to us here via the `SWANK-BACKEND' package.
14 heller 1.26
15 heller 1.58 (defpackage :swank
16 heller 1.138 (:use :common-lisp :swank-backend)
17 lgorrie 1.152 (:export #:startup-multiprocessing
18 heller 1.138 #:start-server
19     #:create-swank-server
20 heller 1.178 #:create-server
21 heller 1.138 #:ed-in-emacs
22 lgorrie 1.157 #:print-indentation-lossage
23 lgorrie 1.177 #:swank-debugger-hook
24 heller 1.405 #:run-after-init-hook
25 lgorrie 1.194 ;; These are user-configurable variables:
26 lgorrie 1.152 #:*communication-style*
27     #:*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 heller 1.264 (defvar *coding-system* ':iso-latin-1-unix)
185    
186 lgorrie 1.90 (defstruct (connection
187 lgorrie 1.215 (:conc-name connection.)
188     (:print-function print-connection))
189 lgorrie 1.90 ;; Raw I/O stream of socket connection.
190 heller 1.113 (socket-io (missing-arg) :type stream :read-only t)
191 lgorrie 1.96 ;; Optional dedicated output socket (backending `user-output' slot).
192     ;; Has a slot so that it can be closed with the connection.
193     (dedicated-output nil :type (or stream null))
194 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
195 lgorrie 1.96 ;; redirected to Emacs.
196     (user-input nil :type (or stream null))
197     (user-output nil :type (or stream null))
198 heller 1.112 (user-io nil :type (or stream null))
199 lgorrie 1.194 ;; In multithreaded systems we delegate certain tasks to specific
200     ;; threads. The `reader-thread' is responsible for reading network
201     ;; requests from Emacs and sending them to the `control-thread'; the
202     ;; `control-thread' is responsible for dispatching requests to the
203     ;; threads that should handle them; the `repl-thread' is the one
204     ;; that evaluates REPL expressions. The control thread dispatches
205     ;; all REPL evaluations to the REPL thread and for other requests it
206     ;; spawns new threads.
207     reader-thread
208 heller 1.134 control-thread
209 lgorrie 1.173 repl-thread
210 lgorrie 1.194 ;; Callback functions:
211     ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
212     ;; from Emacs.
213     (serve-requests (missing-arg) :type function)
214     ;; (READ) is called to read and return one message from Emacs.
215 heller 1.113 (read (missing-arg) :type function)
216 lgorrie 1.194 ;; (SEND OBJECT) is called to send one message to Emacs.
217 heller 1.113 (send (missing-arg) :type function)
218 lgorrie 1.194 ;; (CLEANUP <this-connection>) is called when the connection is
219     ;; closed.
220 heller 1.113 (cleanup nil :type (or null function))
221 lgorrie 1.194 ;; Cache of macro-indentation information that has been sent to Emacs.
222     ;; This is used for preparing deltas to update Emacs's knowledge.
223     ;; Maps: symbol -> indentation-specification
224 lgorrie 1.157 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
225 lgorrie 1.194 ;; The list of packages represented in the cache:
226 heller 1.261 (indentation-cache-packages '())
227     ;; The communication style used.
228     (communication-style nil :type (member nil :spawn :sigio :fd-handler))
229 heller 1.264 ;; The coding system for network streams.
230     (external-format *coding-system* :type (member :iso-latin-1-unix
231     :emacs-mule-unix
232 heller 1.331 :utf-8-unix
233     :euc-jp-unix)))
234 lgorrie 1.215
235     (defun print-connection (conn stream depth)
236     (declare (ignore depth))
237     (print-unreadable-object (conn stream :type t :identity t)))
238 heller 1.115
239 lgorrie 1.157 (defvar *connections* '()
240     "List of all active connections, with the most recent at the front.")
241    
242 heller 1.112 (defvar *emacs-connection* nil
243 lgorrie 1.194 "The connection to Emacs currently in use.")
244 lgorrie 1.96
245 heller 1.115 (defvar *swank-state-stack* '()
246     "A list of symbols describing the current state. Used for debugging
247     and to detect situations where interrupts can be ignored.")
248 lgorrie 1.90
249 lgorrie 1.157 (defun default-connection ()
250     "Return the 'default' Emacs connection.
251 lgorrie 1.194 This connection can be used to talk with Emacs when no specific
252     connection is in use, i.e. *EMACS-CONNECTION* is NIL.
253    
254 lgorrie 1.157 The default connection is defined (quite arbitrarily) as the most
255     recently established one."
256 lgorrie 1.194 (first *connections*))
257 lgorrie 1.157
258 heller 1.112 (defslimefun state-stack ()
259 heller 1.115 "Return the value of *SWANK-STATE-STACK*."
260 heller 1.112 *swank-state-stack*)
261    
262 heller 1.390 ;; A conditions to include backtrace information
263     (define-condition swank-error (error)
264     ((condition :initarg :condition :reader swank-error.condition)
265     (backtrace :initarg :backtrace :reader swank-error.backtrace))
266 lgorrie 1.90 (:report (lambda (condition stream)
267 heller 1.390 (princ (swank-error.condition condition) stream))))
268    
269     (defun make-swank-error (condition)
270     (let ((bt (ignore-errors
271     (call-with-debugging-environment
272     (lambda ()(backtrace 0 nil))))))
273     (make-condition 'swank-error :condition condition :backtrace bt)))
274 lgorrie 1.90
275 lgorrie 1.197 (add-hook *new-connection-hook* 'notify-backend-of-connection)
276     (defun notify-backend-of-connection (connection)
277 heller 1.261 (declare (ignore connection))
278     (emacs-connected))
279 lgorrie 1.197
280 heller 1.343
281 lgorrie 1.96 ;;;; Helper macros
282    
283 lgorrie 1.174 (defmacro with-io-redirection ((connection) &body body)
284 lgorrie 1.194 "Execute BODY I/O redirection to CONNECTION.
285     If *REDIRECT-IO* is true then all standard I/O streams are redirected."
286 heller 1.293 `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
287 lgorrie 1.174
288 heller 1.293 (defun maybe-call-with-io-redirection (connection fun)
289     (if *redirect-io*
290     (call-with-redirected-io connection fun)
291     (funcall fun)))
292    
293 heller 1.153 (defmacro with-connection ((connection) &body body)
294     "Execute BODY in the context of CONNECTION."
295 heller 1.293 `(call-with-connection ,connection (lambda () ,@body)))
296    
297     (defun call-with-connection (connection fun)
298     (let ((*emacs-connection* connection))
299 heller 1.340 (with-io-redirection (*emacs-connection*)
300 heller 1.357 (call-with-debugger-hook #'swank-debugger-hook fun))))
301 lgorrie 1.96
302 heller 1.103 (defmacro without-interrupts (&body body)
303     `(call-without-interrupts (lambda () ,@body)))
304 heller 1.112
305     (defmacro destructure-case (value &rest patterns)
306     "Dispatch VALUE to one of PATTERNS.
307     A cross between `case' and `destructuring-bind'.
308     The pattern syntax is:
309     ((HEAD . ARGS) . BODY)
310     The list of patterns is searched for a HEAD `eq' to the car of
311     VALUE. If one is found, the BODY is executed with ARGS bound to the
312     corresponding values in the CDR of VALUE."
313     (let ((operator (gensym "op-"))
314     (operands (gensym "rand-"))
315     (tmp (gensym "tmp-")))
316     `(let* ((,tmp ,value)
317     (,operator (car ,tmp))
318     (,operands (cdr ,tmp)))
319 heller 1.250 (case ,operator
320     ,@(loop for (pattern . body) in patterns collect
321     (if (eq pattern t)
322     `(t ,@body)
323     (destructuring-bind (op &rest rands) pattern
324     `(,op (destructuring-bind ,rands ,operands
325     ,@body)))))
326     ,@(if (eq (caar (last patterns)) t)
327     '()
328     `((t (error "destructure-case failed: ~S" ,tmp))))))))
329 heller 1.242
330 lgorrie 1.157 (defmacro with-temp-package (var &body body)
331     "Execute BODY with VAR bound to a temporary package.
332     The package is deleted before returning."
333     `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
334 heller 1.250 (unwind-protect (progn ,@body)
335     (delete-package ,var))))
336 lgorrie 1.157
337 heller 1.266 (defvar *log-events* nil)
338 heller 1.278 (defvar *log-output* *error-output*)
339 heller 1.356 (defvar *event-history* (make-array 40 :initial-element nil)
340     "A ring buffer to record events for better error messages.")
341     (defvar *event-history-index* 0)
342     (defvar *enable-event-history* t)
343 heller 1.266
344     (defun log-event (format-string &rest args)
345     "Write a message to *terminal-io* when *log-events* is non-nil.
346     Useful for low level debugging."
347 heller 1.356 (when *enable-event-history*
348     (setf (aref *event-history* *event-history-index*)
349 heller 1.357 (format nil "~?" format-string args))
350 heller 1.356 (setf *event-history-index*
351     (mod (1+ *event-history-index*) (length *event-history*))))
352 heller 1.266 (when *log-events*
353 heller 1.278 (apply #'format *log-output* format-string args)
354     (force-output *log-output*)))
355 heller 1.266
356 heller 1.356 (defun event-history-to-list ()
357     "Return the list of events (older events first)."
358     (let ((arr *event-history*)
359     (idx *event-history-index*))
360     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
361    
362     (defun dump-event-history (stream)
363     (dolist (e (event-history-to-list))
364     (dump-event e stream)))
365    
366     (defun dump-event (event stream)
367     (cond ((stringp event)
368     (write-string (escape-non-ascii event) stream))
369     ((null event))
370     (t (format stream "Unexpected event: ~A~%" event))))
371    
372     (defun escape-non-ascii (string)
373     "Return a string like STRING but with non-ascii chars escaped."
374     (cond ((ascii-string-p string) string)
375     (t (with-output-to-string (out)
376     (loop for c across string do
377     (cond ((ascii-char-p c) (write-char c out))
378     (t (format out "\\x~4,'0X" (char-code c)))))))))
379    
380     (defun ascii-string-p (o)
381     (and (stringp o)
382     (every #'ascii-char-p o)))
383    
384     (defun ascii-char-p (c)
385     (<= (char-code c) 127))
386    
387 heller 1.343
388 lgorrie 1.90 ;;;; TCP Server
389 dbarlow 1.28
390 heller 1.377 (defvar *use-dedicated-output-stream* nil
391 mbaringer 1.313 "When T swank will attempt to create a second connection to
392     Emacs which is used just to send output.")
393 heller 1.352
394 mbaringer 1.313 (defvar *dedicated-output-stream-port* 0
395 heller 1.330 "Which port we should use for the dedicated output stream.")
396    
397 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
398 heller 1.79
399 heller 1.352 (defvar *dedicated-output-stream-buffering*
400     (if (eq *communication-style* :spawn) :full :none)
401     "The buffering scheme that should be used for the output stream.
402     Valid values are :none, :line, and :full.")
403    
404 heller 1.264 (defun start-server (port-file &key (style *communication-style*)
405     dont-close (external-format *coding-system*))
406 lgorrie 1.212 "Start the server and write the listen port number to PORT-FILE.
407     This is the entry point for Emacs."
408 heller 1.342 (when (eq style :spawn)
409     (initialize-multiprocessing))
410 heller 1.101 (setup-server 0 (lambda (port) (announce-server-port port-file port))
411 heller 1.342 style dont-close external-format)
412     (when (eq style :spawn)
413     (startup-idle-and-top-level-loops)))
414 heller 1.178
415 lgorrie 1.194 (defun create-server (&key (port default-server-port)
416 heller 1.178 (style *communication-style*)
417 heller 1.264 dont-close (external-format *coding-system*))
418 lgorrie 1.212 "Start a SWANK server on PORT running in STYLE.
419     If DONT-CLOSE is true then the listen socket will accept multiple
420     connections, otherwise it will be closed after the first."
421 heller 1.264 (setup-server port #'simple-announce-function style dont-close
422     external-format))
423 heller 1.178
424 lgorrie 1.194 (defun create-swank-server (&optional (port default-server-port)
425 heller 1.178 (style *communication-style*)
426 heller 1.133 (announce-fn #'simple-announce-function)
427 heller 1.264 dont-close (external-format *coding-system*))
428     (setup-server port announce-fn style dont-close external-format))
429 heller 1.101
430 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
431    
432 heller 1.264 (defun setup-server (port announce-fn style dont-close external-format)
433 heller 1.111 (declare (type function announce-fn))
434 heller 1.119 (let* ((socket (create-socket *loopback-interface* port))
435 heller 1.106 (port (local-port socket)))
436     (funcall announce-fn port)
437 heller 1.264 (flet ((serve ()
438     (serve-connection socket style dont-close external-format)))
439     (ecase style
440     (:spawn
441 heller 1.390 (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
442 heller 1.264 :name "Swank"))
443     ((:fd-handler :sigio)
444     (add-fd-handler socket (lambda () (serve))))
445 heller 1.349 ((nil) (loop do (serve) while dont-close)))
446 heller 1.264 port)))
447 lgorrie 1.96
448 heller 1.264 (defun serve-connection (socket style dont-close external-format)
449 dcrosher 1.368 (let ((closed-socket-p nil))
450     (unwind-protect
451     (let ((client (accept-authenticated-connection
452     socket :external-format external-format)))
453     (unless dont-close
454     (close-socket socket)
455     (setf closed-socket-p t))
456     (let ((connection (create-connection client style external-format)))
457     (run-hook *new-connection-hook* connection)
458     (push connection *connections*)
459     (serve-requests connection)))
460     (unless (or dont-close closed-socket-p)
461     (close-socket socket)))))
462 heller 1.112
463 lgorrie 1.296 (defun accept-authenticated-connection (&rest args)
464     (let ((new (apply #'accept-connection args))
465 dcrosher 1.368 (success nil))
466     (unwind-protect
467     (let ((secret (slime-secret)))
468     (when secret
469     (set-stream-timeout new 20)
470     (let ((first-val (decode-message new)))
471     (unless (and (stringp first-val) (string= first-val secret))
472     (error "Incoming connection doesn't know the password."))))
473     (set-stream-timeout new nil)
474     (setf success t))
475     (unless success
476     (close new :abort t)))
477 lgorrie 1.296 new))
478    
479     (defun slime-secret ()
480     "Finds the magic secret from the user's home directory. Returns nil
481     if the file doesn't exist; otherwise the first line of the file."
482     (with-open-file (in
483 lgorrie 1.297 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
484 lgorrie 1.296 :if-does-not-exist nil)
485     (and in (read-line in nil ""))))
486    
487 heller 1.112 (defun serve-requests (connection)
488 heller 1.115 "Read and process all requests on connections."
489 heller 1.112 (funcall (connection.serve-requests connection) connection))
490    
491 heller 1.94 (defun announce-server-port (file port)
492     (with-open-file (s file
493     :direction :output
494 lgorrie 1.296 :if-exists :error
495 heller 1.94 :if-does-not-exist :create)
496     (format s "~S~%" port))
497     (simple-announce-function port))
498 lgorrie 1.90
499 heller 1.115 (defun simple-announce-function (port)
500     (when *swank-debug-p*
501 heller 1.303 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)
502     (force-output *debug-io*)))
503 heller 1.115
504 heller 1.153 (defun open-streams (connection)
505 heller 1.115 "Return the 4 streams for IO redirection:
506 lgorrie 1.212 DEDICATED-OUTPUT INPUT OUTPUT IO"
507 heller 1.97 (multiple-value-bind (output-fn dedicated-output)
508 heller 1.153 (make-output-function connection)
509 lgorrie 1.157 (let ((input-fn
510     (lambda ()
511     (with-connection (connection)
512 lgorrie 1.206 (with-simple-restart (abort-read
513     "Abort reading input from Emacs.")
514 lgorrie 1.157 (read-user-input-from-emacs))))))
515 lgorrie 1.96 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
516 heller 1.101 (let ((out (or dedicated-output out)))
517     (let ((io (make-two-way-stream in out)))
518 lgorrie 1.208 (mapc #'make-stream-interactive (list in out io))
519 heller 1.112 (values dedicated-output in out io)))))))
520 lgorrie 1.90
521 heller 1.153 (defun make-output-function (connection)
522 lgorrie 1.96 "Create function to send user output to Emacs.
523     This function may open a dedicated socket to send output. It
524     returns two values: the output function, and the dedicated
525     stream (or NIL if none was created)."
526 lgorrie 1.90 (if *use-dedicated-output-stream*
527 heller 1.153 (let ((stream (open-dedicated-output-stream
528 heller 1.264 (connection.socket-io connection)
529     (connection.external-format connection))))
530 lgorrie 1.96 (values (lambda (string)
531 heller 1.97 (write-string string stream)
532 lgorrie 1.96 (force-output stream))
533     stream))
534 heller 1.153 (values (lambda (string)
535     (with-connection (connection)
536 lgorrie 1.157 (with-simple-restart
537     (abort "Abort sending output to Emacs.")
538 heller 1.339 (send-to-emacs `(:write-string ,string)))))
539 lgorrie 1.96 nil)))
540 heller 1.97
541 heller 1.264 (defun open-dedicated-output-stream (socket-io external-format)
542 lgorrie 1.90 "Open a dedicated output connection to the Emacs on SOCKET-IO.
543     Return an output stream suitable for writing program output.
544    
545     This is an optimized way for Lisp to deliver output to Emacs."
546 dcrosher 1.368 (let ((socket (create-socket *loopback-interface*
547     *dedicated-output-stream-port*)))
548     (unwind-protect
549     (let ((port (local-port socket)))
550     (encode-message `(:open-dedicated-output-stream ,port) socket-io)
551     (let ((dedicated (accept-authenticated-connection
552     socket :external-format external-format
553     :buffering *dedicated-output-stream-buffering*
554     :timeout 30)))
555     (close-socket socket)
556     (setf socket nil)
557     dedicated))
558     (when socket
559     (close-socket socket)))))
560 lgorrie 1.90
561 heller 1.134 (defun handle-request (connection)
562 dcrosher 1.368 "Read and process one request. The processing is done in the extent
563 heller 1.115 of the toplevel restart."
564 heller 1.112 (assert (null *swank-state-stack*))
565 heller 1.357 (let ((*swank-state-stack* '(:handle-request)))
566 heller 1.134 (with-connection (connection)
567 heller 1.340 (with-simple-restart (abort-request "Abort handling SLIME request.")
568 lgorrie 1.157 (read-from-emacs)))))
569 heller 1.97
570 heller 1.112 (defun current-socket-io ()
571     (connection.socket-io *emacs-connection*))
572    
573 heller 1.390 (defun close-connection (c &optional condition backtrace)
574     (format *debug-io* "~&;; swank:close-connection: ~A~%" condition)
575 heller 1.113 (let ((cleanup (connection.cleanup c)))
576     (when cleanup
577     (funcall cleanup c)))
578 heller 1.112 (close (connection.socket-io c))
579     (when (connection.dedicated-output c)
580 lgorrie 1.157 (close (connection.dedicated-output c)))
581 lgorrie 1.197 (setf *connections* (remove c *connections*))
582 lgorrie 1.217 (run-hook *connection-closed-hook* c)
583 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
584 heller 1.356 (finish-output *debug-io*)
585     (format *debug-io* "~&;; Event history start:~%")
586     (dump-event-history *debug-io*)
587     (format *debug-io* ";; Event history end.~%~
588 heller 1.390 ;; Backtrace:~%~{~A~%~}~
589 heller 1.356 ;; Connection to Emacs lost. [~%~
590     ;; condition: ~A~%~
591     ;; type: ~S~%~
592     ;; encoding: ~S style: ~S dedicated: ~S]~%"
593 heller 1.390 backtrace
594 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
595     (type-of condition)
596     (connection.external-format c)
597     (connection.communication-style c)
598     *use-dedicated-output-stream*)
599 heller 1.266 (finish-output *debug-io*)))
600 heller 1.112
601     (defmacro with-reader-error-handler ((connection) &body body)
602 heller 1.390 (let ((con (gensym)))
603     `(let ((,con ,connection))
604     (handler-case
605     (progn ,@body)
606     (swank-error (e)
607     (close-connection ,con
608     (swank-error.condition e)
609     (swank-error.backtrace e)))))))
610 heller 1.112
611 heller 1.343 (defslimefun simple-break ()
612 heller 1.180 (with-simple-restart (continue "Continue from interrupt.")
613 heller 1.357 (call-with-debugger-hook
614     #'swank-debugger-hook
615     (lambda ()
616     (invoke-debugger
617     (make-condition 'simple-error
618     :format-control "Interrupt from Emacs")))))
619 heller 1.343 nil)
620 heller 1.180
621     ;;;;;; Thread based communication
622    
623 heller 1.204 (defvar *active-threads* '())
624    
625 heller 1.134 (defun read-loop (control-thread input-stream connection)
626     (with-reader-error-handler (connection)
627 heller 1.112 (loop (send control-thread (decode-message input-stream)))))
628    
629 heller 1.134 (defun dispatch-loop (socket-io connection)
630 heller 1.204 (let ((*emacs-connection* connection))
631 heller 1.266 (handler-case
632     (loop (dispatch-event (receive) socket-io))
633     (error (e)
634     (close-connection connection e)))))
635 heller 1.112
636 heller 1.241 (defun repl-thread (connection)
637     (let ((thread (connection.repl-thread connection)))
638 heller 1.357 (when (not thread)
639     (log-event "ERROR: repl-thread is nil"))
640     (assert thread)
641     (cond ((thread-alive-p thread)
642     thread)
643     (t
644     (setf (connection.repl-thread connection)
645     (spawn-repl-thread connection "new-repl-thread"))))))
646 heller 1.241
647     (defun find-worker-thread (id)
648     (etypecase id
649     ((member t)
650     (car *active-threads*))
651     ((member :repl-thread)
652     (repl-thread *emacs-connection*))
653     (fixnum
654     (find-thread id))))
655    
656 heller 1.204 (defun interrupt-worker-thread (id)
657 heller 1.241 (let ((thread (or (find-worker-thread id)
658     (repl-thread *emacs-connection*))))
659 heller 1.129 (interrupt-thread thread #'simple-break)))
660 heller 1.112
661 heller 1.204 (defun thread-for-evaluation (id)
662 heller 1.180 "Find or create a thread to evaluate the next request."
663     (let ((c *emacs-connection*))
664 heller 1.204 (etypecase id
665 heller 1.180 ((member t)
666 heller 1.274 (spawn-worker-thread c))
667 heller 1.180 ((member :repl-thread)
668 heller 1.241 (repl-thread c))
669 heller 1.180 (fixnum
670 heller 1.204 (find-thread id)))))
671 heller 1.274
672     (defun spawn-worker-thread (connection)
673     (spawn (lambda ()
674 heller 1.288 (with-bindings *default-worker-thread-bindings*
675     (handle-request connection)))
676 heller 1.274 :name "worker"))
677    
678 heller 1.291 (defun spawn-repl-thread (connection name)
679     (spawn (lambda ()
680     (with-bindings *default-worker-thread-bindings*
681     (repl-loop connection)))
682     :name name))
683    
684 heller 1.112 (defun dispatch-event (event socket-io)
685 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
686 heller 1.112 (log-event "DISPATCHING: ~S~%" event)
687     (destructure-case event
688 heller 1.204 ((:emacs-rex form package thread-id id)
689     (let ((thread (thread-for-evaluation thread-id)))
690     (push thread *active-threads*)
691     (send thread `(eval-for-emacs ,form ,package ,id))))
692 heller 1.112 ((:return thread &rest args)
693 heller 1.204 (let ((tail (member thread *active-threads*)))
694     (setq *active-threads* (nconc (ldiff *active-threads* tail)
695     (cdr tail))))
696 heller 1.112 (encode-message `(:return ,@args) socket-io))
697 heller 1.204 ((:emacs-interrupt thread-id)
698     (interrupt-worker-thread thread-id))
699     (((:debug :debug-condition :debug-activate :debug-return)
700     thread &rest args)
701     (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
702 heller 1.112 ((:read-string thread &rest args)
703 heller 1.204 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
704 mkoeppe 1.327 ((:y-or-n-p thread &rest args)
705     (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
706 heller 1.112 ((:read-aborted thread &rest args)
707 heller 1.204 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
708     ((:emacs-return-string thread-id tag string)
709     (send (find-thread thread-id) `(take-input ,tag ,string)))
710 heller 1.281 ((:eval thread &rest args)
711     (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
712     ((:emacs-return thread-id tag value)
713     (send (find-thread thread-id) `(take-input ,tag ,value)))
714 heller 1.339 (((:write-string :presentation-start :presentation-end
715     :new-package :new-features :ed :%apply :indentation-update
716     :eval-no-wait :background-message)
717 heller 1.112 &rest _)
718     (declare (ignore _))
719 heller 1.281 (encode-message event socket-io))))
720 heller 1.112
721 heller 1.153 (defun spawn-threads-for-connection (connection)
722 heller 1.357 (macrolet ((without-debugger-hook (&body body)
723     `(call-with-debugger-hook nil (lambda () ,@body))))
724     (let* ((socket-io (connection.socket-io connection))
725     (control-thread (spawn (lambda ()
726     (without-debugger-hook
727     (dispatch-loop socket-io connection)))
728     :name "control-thread")))
729     (setf (connection.control-thread connection) control-thread)
730     (let ((reader-thread (spawn (lambda ()
731     (let ((go (receive)))
732     (assert (eq go 'accept-input)))
733     (without-debugger-hook
734     (read-loop control-thread socket-io
735     connection)))
736     :name "reader-thread"))
737     (repl-thread (spawn-repl-thread connection "repl-thread")))
738     (setf (connection.repl-thread connection) repl-thread)
739     (setf (connection.reader-thread connection) reader-thread)
740     (send reader-thread 'accept-input)
741     connection))))
742 heller 1.153
743 lgorrie 1.236 (defun cleanup-connection-threads (connection)
744 heller 1.266 (let ((threads (list (connection.repl-thread connection)
745     (connection.reader-thread connection)
746     (connection.control-thread connection))))
747     (dolist (thread threads)
748 heller 1.357 (when (and thread
749     (thread-alive-p thread)
750     (not (equal (current-thread) thread)))
751 heller 1.266 (kill-thread thread)))))
752 lgorrie 1.236
753 lgorrie 1.173 (defun repl-loop (connection)
754 heller 1.390 (loop (handle-request connection)))
755 heller 1.112
756 heller 1.122 (defun process-available-input (stream fn)
757 heller 1.396 (loop while (input-available-p stream)
758 heller 1.122 do (funcall fn)))
759    
760 heller 1.396 (defun input-available-p (stream)
761     ;; return true iff we can read from STREAM without waiting or if we
762     ;; hit EOF
763     (let ((c (read-char-no-hang stream nil :eof)))
764     (cond ((not c) nil)
765     ((eq c :eof) t)
766     (t
767     (unread-char c stream)
768     t))))
769    
770 heller 1.123 ;;;;;; Signal driven IO
771    
772 heller 1.112 (defun install-sigio-handler (connection)
773     (let ((client (connection.socket-io connection)))
774 heller 1.134 (flet ((handler ()
775     (cond ((null *swank-state-stack*)
776     (with-reader-error-handler (connection)
777     (process-available-input
778     client (lambda () (handle-request connection)))))
779     ((eq (car *swank-state-stack*) :read-next-form))
780     (t (process-available-input client #'read-from-emacs)))))
781 heller 1.123 (add-sigio-handler client #'handler)
782 heller 1.122 (handler))))
783 heller 1.112
784 heller 1.123 (defun deinstall-sigio-handler (connection)
785     (remove-sigio-handlers (connection.socket-io connection)))
786    
787     ;;;;;; SERVE-EVENT based IO
788    
789     (defun install-fd-handler (connection)
790     (let ((client (connection.socket-io connection)))
791     (flet ((handler ()
792 heller 1.134 (cond ((null *swank-state-stack*)
793     (with-reader-error-handler (connection)
794     (process-available-input
795     client (lambda () (handle-request connection)))))
796     ((eq (car *swank-state-stack*) :read-next-form))
797 heller 1.357 (t
798     (process-available-input client #'read-from-emacs)))))
799 heller 1.396 ;;;; handle sigint
800     ;;(install-debugger-globally
801     ;; (lambda (c h)
802     ;; (with-reader-error-handler (connection)
803     ;; (block debugger
804     ;; (with-connection (connection)
805     ;; (swank-debugger-hook c h)
806     ;; (return-from debugger))
807     ;; (abort)))))
808 heller 1.123 (add-fd-handler client #'handler)
809     (handler))))
810    
811     (defun deinstall-fd-handler (connection)
812     (remove-fd-handlers (connection.socket-io connection)))
813    
814     ;;;;;; Simple sequential IO
815 heller 1.112
816     (defun simple-serve-requests (connection)
817 heller 1.390 (unwind-protect
818     (with-simple-restart (close-connection "Close SLIME connection")
819     (with-reader-error-handler (connection)
820     (loop
821     (handle-request connection))))
822     (close-connection connection)))
823 heller 1.357
824 heller 1.112 (defun read-from-socket-io ()
825     (let ((event (decode-message (current-socket-io))))
826     (log-event "DISPATCHING: ~S~%" event)
827     (destructure-case event
828 heller 1.149 ((:emacs-rex form package thread id)
829 heller 1.113 (declare (ignore thread))
830 heller 1.149 `(eval-for-emacs ,form ,package ,id))
831 heller 1.112 ((:emacs-interrupt thread)
832 heller 1.113 (declare (ignore thread))
833 heller 1.112 '(simple-break))
834     ((:emacs-return-string thread tag string)
835 heller 1.113 (declare (ignore thread))
836 heller 1.281 `(take-input ,tag ,string))
837     ((:emacs-return thread tag value)
838     (declare (ignore thread))
839     `(take-input ,tag ,value)))))
840 heller 1.112
841     (defun send-to-socket-io (event)
842     (log-event "DISPATCHING: ~S~%" event)
843 heller 1.269 (flet ((send (o)
844     (without-interrupts
845     (encode-message o (current-socket-io)))))
846 heller 1.112 (destructure-case event
847 heller 1.281 (((:debug-activate :debug :debug-return :read-string :read-aborted
848 mkoeppe 1.327 :y-or-n-p :eval)
849 heller 1.115 thread &rest args)
850 heller 1.112 (declare (ignore thread))
851     (send `(,(car event) 0 ,@args)))
852     ((:return thread &rest args)
853 heller 1.225 (declare (ignore thread))
854 heller 1.112 (send `(:return ,@args)))
855 heller 1.339 (((:write-string :new-package :new-features :debug-condition
856     :presentation-start :presentation-end
857     :indentation-update :ed :%apply :eval-no-wait
858     :background-message)
859 heller 1.112 &rest _)
860     (declare (ignore _))
861     (send event)))))
862    
863 heller 1.180 (defun initialize-streams-for-connection (connection)
864     (multiple-value-bind (dedicated in out io) (open-streams connection)
865     (setf (connection.dedicated-output connection) dedicated
866     (connection.user-io connection) io
867     (connection.user-output connection) out
868     (connection.user-input connection) in)
869     connection))
870    
871 heller 1.264 (defun create-connection (socket-io style external-format)
872 dcrosher 1.368 (let ((success nil))
873     (unwind-protect
874     (let ((c (ecase style
875     (:spawn
876     (make-connection :socket-io socket-io
877     :read #'read-from-control-thread
878     :send #'send-to-control-thread
879     :serve-requests #'spawn-threads-for-connection
880     :cleanup #'cleanup-connection-threads))
881     (:sigio
882     (make-connection :socket-io socket-io
883     :read #'read-from-socket-io
884     :send #'send-to-socket-io
885     :serve-requests #'install-sigio-handler
886     :cleanup #'deinstall-sigio-handler))
887     (:fd-handler
888     (make-connection :socket-io socket-io
889     :read #'read-from-socket-io
890     :send #'send-to-socket-io
891     :serve-requests #'install-fd-handler
892     :cleanup #'deinstall-fd-handler))
893     ((nil)
894     (make-connection :socket-io socket-io
895     :read #'read-from-socket-io
896     :send #'send-to-socket-io
897     :serve-requests #'simple-serve-requests)))))
898     (setf (connection.communication-style c) style)
899     (setf (connection.external-format c) external-format)
900     (initialize-streams-for-connection c)
901     (setf success t)
902     c)
903     (unless success
904     (close socket-io :abort t)))))
905 heller 1.180
906 lgorrie 1.80
907 lgorrie 1.62 ;;;; IO to Emacs
908     ;;;
909 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
910     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
911     ;;; contains the appropriate streams, so all we have to do is make the
912     ;;; right bindings.
913    
914     ;;;;; Global I/O redirection framework
915     ;;;
916     ;;; Optionally, the top-level global bindings of the standard streams
917     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
918     ;;; redirect the streams into the connection, and they keep going into
919     ;;; that connection even if more are established. If the connection
920     ;;; handling the streams closes then another is chosen, or if there
921     ;;; are no connections then we revert to the original (real) streams.
922     ;;;
923     ;;; It is slightly tricky to assign the global values of standard
924     ;;; streams because they are often shadowed by dynamic bindings. We
925     ;;; solve this problem by introducing an extra indirection via synonym
926     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
927     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
928     ;;; variables, so they can always be assigned to affect a global
929     ;;; change.
930    
931 heller 1.405 (defvar *globally-redirect-io* nil
932 lgorrie 1.197 "When non-nil globally redirect all standard streams to Emacs.")
933    
934 heller 1.405 ;;;;; Global redirection setup
935    
936     (defvar *saved-global-streams* '()
937     "A plist to save and restore redirected stream objects.
938     E.g. the value for '*standard-output* holds the stream object
939     for *standard-output* before we install our redirection.")
940    
941     (defun setup-stream-indirection (stream-var &optional stream)
942 lgorrie 1.197 "Setup redirection scaffolding for a global stream variable.
943     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
944    
945 heller 1.405 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
946 lgorrie 1.197
947     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
948     *STANDARD-INPUT*.
949    
950     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
951     *CURRENT-STANDARD-INPUT*.
952    
953     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
954 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
955     the effective global value even when *STANDARD-INPUT* is shadowed by a
956     dynamic binding."
957 heller 1.405 (let ((current-stream-var (prefixed-var '#:current stream-var))
958     (stream (or stream (symbol-value stream-var))))
959     ;; Save the real stream value for the future.
960     (setf (getf *saved-global-streams* stream-var) stream)
961     ;; Define a new variable for the effective stream.
962     ;; This can be reassigned.
963     (proclaim `(special ,current-stream-var))
964     (set current-stream-var stream)
965     ;; Assign the real binding as a synonym for the current one.
966     (set stream-var (make-synonym-stream current-stream-var))))
967    
968     (defun prefixed-var (prefix variable-symbol)
969     "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
970     (let ((basename (subseq (symbol-name variable-symbol) 1)))
971     (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
972 lgorrie 1.199
973 heller 1.405 (defvar *standard-output-streams*
974 lgorrie 1.197 '(*standard-output* *error-output* *trace-output*)
975     "The symbols naming standard output streams.")
976    
977 heller 1.405 (defvar *standard-input-streams*
978 lgorrie 1.197 '(*standard-input*)
979     "The symbols naming standard input streams.")
980    
981 heller 1.405 (defvar *standard-io-streams*
982 lgorrie 1.197 '(*debug-io* *query-io* *terminal-io*)
983     "The symbols naming standard io streams.")
984    
985 heller 1.405 (defun init-global-stream-redirection ()
986     (when *globally-redirect-io*
987     (mapc #'setup-stream-indirection
988     (append *standard-output-streams*
989     *standard-input-streams*
990     *standard-io-streams*))))
991    
992     (add-hook *after-init-hook* 'init-global-stream-redirection)
993    
994 lgorrie 1.197 (defun globally-redirect-io-to-connection (connection)
995     "Set the standard I/O streams to redirect to CONNECTION.
996     Assigns *CURRENT-<STREAM>* for all standard streams."
997     (dolist (o *standard-output-streams*)
998 dcrosher 1.363 (set (prefixed-var '#:current o)
999 lgorrie 1.197 (connection.user-output connection)))
1000     ;; FIXME: If we redirect standard input to Emacs then we get the
1001     ;; regular Lisp top-level trying to read from our REPL.
1002     ;;
1003     ;; Perhaps the ideal would be for the real top-level to run in a
1004     ;; thread with local bindings for all the standard streams. Failing
1005     ;; that we probably would like to inhibit it from reading while
1006     ;; Emacs is connected.
1007     ;;
1008     ;; Meanwhile we just leave *standard-input* alone.
1009     #+NIL
1010     (dolist (i *standard-input-streams*)
1011 dcrosher 1.363 (set (prefixed-var '#:current i)
1012 lgorrie 1.197 (connection.user-input connection)))
1013     (dolist (io *standard-io-streams*)
1014 dcrosher 1.363 (set (prefixed-var '#:current io)
1015 lgorrie 1.197 (connection.user-io connection))))
1016    
1017     (defun revert-global-io-redirection ()
1018     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1019     (dolist (stream-var (append *standard-output-streams*
1020     *standard-input-streams*
1021     *standard-io-streams*))
1022 dcrosher 1.363 (set (prefixed-var '#:current stream-var)
1023 heller 1.405 (getf *saved-global-streams* stream-var))))
1024 lgorrie 1.197
1025     ;;;;; Global redirection hooks
1026    
1027     (defvar *global-stdio-connection* nil
1028     "The connection to which standard I/O streams are globally redirected.
1029     NIL if streams are not globally redirected.")
1030    
1031     (defun maybe-redirect-global-io (connection)
1032     "Consider globally redirecting to a newly-established CONNECTION."
1033     (when (and *globally-redirect-io* (null *global-stdio-connection*))
1034     (setq *global-stdio-connection* connection)
1035     (globally-redirect-io-to-connection connection)))
1036    
1037     (defun update-redirection-after-close (closed-connection)
1038     "Update redirection after a connection closes."
1039     (when (eq *global-stdio-connection* closed-connection)
1040     (if (and (default-connection) *globally-redirect-io*)
1041     ;; Redirect to another connection.
1042     (globally-redirect-io-to-connection (default-connection))
1043     ;; No more connections, revert to the real streams.
1044     (progn (revert-global-io-redirection)
1045     (setq *global-stdio-connection* nil)))))
1046    
1047     (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1048     (add-hook *connection-closed-hook* 'update-redirection-after-close)
1049    
1050     ;;;;; Redirection during requests
1051     ;;;
1052     ;;; We always redirect the standard streams to Emacs while evaluating
1053     ;;; an RPC. This is done with simple dynamic bindings.
1054 dbarlow 1.28
1055 lgorrie 1.90 (defun call-with-redirected-io (connection function)
1056     "Call FUNCTION with I/O streams redirected via CONNECTION."
1057 heller 1.111 (declare (type function function))
1058 lgorrie 1.90 (let* ((io (connection.user-io connection))
1059     (in (connection.user-input connection))
1060     (out (connection.user-output connection))
1061     (*standard-output* out)
1062     (*error-output* out)
1063 mkoeppe 1.318 (*trace-output* out)
1064 lgorrie 1.90 (*debug-io* io)
1065     (*query-io* io)
1066     (*standard-input* in)
1067     (*terminal-io* io))
1068     (funcall function)))
1069    
1070 heller 1.112 (defun read-from-emacs ()
1071 dbarlow 1.28 "Read and process a request from Emacs."
1072 heller 1.112 (apply #'funcall (funcall (connection.read *emacs-connection*))))
1073    
1074     (defun read-from-control-thread ()
1075     (receive))
1076 heller 1.46
1077 heller 1.112 (defun decode-message (stream)
1078 heller 1.390 "Read an S-expression from STREAM using the SLIME protocol."
1079 heller 1.112 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1080 heller 1.390 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1081     (let* ((length (decode-message-length stream))
1082     (string (make-string length))
1083     (pos (read-sequence string stream)))
1084     (assert (= pos length) ()
1085     "Short read: length=~D pos=~D" length pos)
1086     (log-event "READ: ~S~%" string)
1087     (read-form string)))))
1088 heller 1.264
1089     (defun decode-message-length (stream)
1090     (let ((buffer (make-string 6)))
1091     (dotimes (i 6)
1092     (setf (aref buffer i) (read-char stream)))
1093     (parse-integer buffer :radix #x10)))
1094 dbarlow 1.28
1095     (defun read-form (string)
1096     (with-standard-io-syntax
1097     (let ((*package* *swank-io-package*))
1098     (read-from-string string))))
1099    
1100 lgorrie 1.50 (defvar *slime-features* nil
1101     "The feature list that has been sent to Emacs.")
1102    
1103 heller 1.112 (defun send-to-emacs (object)
1104     "Send OBJECT to Emacs."
1105     (funcall (connection.send *emacs-connection*) object))
1106 dbarlow 1.28
1107 lgorrie 1.104 (defun send-oob-to-emacs (object)
1108 heller 1.112 (send-to-emacs object))
1109    
1110     (defun send-to-control-thread (object)
1111     (send (connection.control-thread *emacs-connection*) object))
1112    
1113     (defun encode-message (message stream)
1114     (let* ((string (prin1-to-string-for-emacs message))
1115 heller 1.330 (length (length string)))
1116 heller 1.112 (log-event "WRITE: ~A~%" string)
1117 mkoeppe 1.315 (let ((*print-pretty* nil))
1118     (format stream "~6,'0x" length))
1119 heller 1.204 (write-string string stream)
1120 heller 1.330 ;;(terpri stream)
1121 heller 1.357 (finish-output stream)))
1122 lgorrie 1.104
1123 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
1124 heller 1.31 (with-standard-io-syntax
1125     (let ((*print-case* :downcase)
1126 heller 1.185 (*print-readably* nil)
1127 heller 1.31 (*print-pretty* nil)
1128     (*package* *swank-io-package*))
1129     (prin1-to-string object))))
1130 dbarlow 1.28
1131 heller 1.112 (defun force-user-output ()
1132 heller 1.344 (force-output (connection.user-io *emacs-connection*))
1133 heller 1.343 (finish-output (connection.user-output *emacs-connection*)))
1134 heller 1.112
1135     (defun clear-user-input ()
1136     (clear-input (connection.user-input *emacs-connection*)))
1137 lgorrie 1.62
1138 lgorrie 1.91 (defvar *read-input-catch-tag* 0)
1139    
1140 heller 1.232 (defun intern-catch-tag (tag)
1141     ;; fixnums aren't eq in ABCL, so we use intern to create tags
1142     (intern (format nil "~D" tag) :swank))
1143    
1144 heller 1.112 (defun read-user-input-from-emacs ()
1145 heller 1.281 (let ((tag (incf *read-input-catch-tag*)))
1146 heller 1.117 (force-output)
1147 heller 1.281 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1148 lgorrie 1.90 (let ((ok nil))
1149 lgorrie 1.62 (unwind-protect
1150 heller 1.281 (prog1 (catch (intern-catch-tag tag)
1151 heller 1.112 (loop (read-from-emacs)))
1152 lgorrie 1.62 (setq ok t))
1153     (unless ok
1154 heller 1.281 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1155 mkoeppe 1.327
1156 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1157 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1158     (let ((tag (incf *read-input-catch-tag*))
1159 heller 1.330 (question (apply #'format nil format-string arguments)))
1160 mkoeppe 1.327 (force-output)
1161     (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1162 heller 1.330 (catch (intern-catch-tag tag)
1163     (loop (read-from-emacs)))))
1164 lgorrie 1.90
1165 lgorrie 1.62 (defslimefun take-input (tag input)
1166 heller 1.147 "Return the string INPUT to the continuation TAG."
1167 heller 1.232 (throw (intern-catch-tag tag) input))
1168 mbaringer 1.279
1169 mbaringer 1.346 (defun process-form-for-emacs (form)
1170     "Returns a string which emacs will read as equivalent to
1171     FORM. FORM can contain lists, strings, characters, symbols and
1172     numbers.
1173    
1174     Characters are converted emacs' ?<char> notaion, strings are left
1175     as they are (except for espacing any nested \" chars, numbers are
1176     printed in base 10 and symbols are printed as their symbol-nome
1177     converted to lower case."
1178     (etypecase form
1179     (string (format nil "~S" form))
1180     (cons (format nil "(~A . ~A)"
1181     (process-form-for-emacs (car form))
1182     (process-form-for-emacs (cdr form))))
1183     (character (format nil "?~C" form))
1184     (symbol (string-downcase (symbol-name form)))
1185     (number (let ((*print-base* 10))
1186     (princ-to-string form)))))
1187    
1188 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1189     "Eval FORM in Emacs."
1190 mbaringer 1.346 (cond (nowait
1191     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1192     (t
1193     (force-output)
1194     (let* ((tag (incf *read-input-catch-tag*))
1195     (value (catch (intern-catch-tag tag)
1196     (send-to-emacs
1197 heller 1.348 `(:eval ,(current-thread) ,tag
1198     ,(process-form-for-emacs form)))
1199 mbaringer 1.346 (loop (read-from-emacs)))))
1200     (destructure-case value
1201     ((:ok value) value)
1202     ((:abort) (abort)))))))
1203 heller 1.337
1204 heller 1.126 (defslimefun connection-info ()
1205 heller 1.343 "Return a key-value list of the form:
1206     \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE)
1207     PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1208     STYLE: the communication style
1209 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1210 heller 1.343 FEATURES: a list of keywords
1211     PACKAGE: a list (&key NAME PROMPT)"
1212 heller 1.260 (setq *slime-features* *features*)
1213 heller 1.343 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1214     :lisp-implementation (:type ,(lisp-implementation-type)
1215 heller 1.350 :name ,(lisp-implementation-type-name)
1216 heller 1.343 :version ,(lisp-implementation-version))
1217     :machine (:instance ,(machine-instance)
1218     :type ,(machine-type)
1219     :version ,(machine-version))
1220     :features ,(features-for-emacs)
1221     :package (:name ,(package-name *package*)
1222     :prompt ,(package-string-for-prompt *package*))))
1223 lgorrie 1.62
1224 heller 1.339 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1225     (let* ((s *standard-output*)
1226     (*trace-output* (make-broadcast-stream s *log-output*)))
1227 heller 1.337 (time (progn
1228     (dotimes (i n)
1229     (format s "~D abcdefghijklm~%" i)
1230     (when (zerop (mod n m))
1231 heller 1.339 (force-output s)))
1232 heller 1.337 (finish-output s)
1233 heller 1.339 (when *emacs-connection*
1234     (eval-in-emacs '(message "done.")))))
1235     (terpri *trace-output*)
1236     (finish-output *trace-output*)
1237 heller 1.337 nil))
1238    
1239 lgorrie 1.62
1240     ;;;; Reading and printing
1241 dbarlow 1.28
1242 heller 1.207 (defmacro define-special (name doc)
1243     "Define a special variable NAME with doc string DOC.
1244 heller 1.232 This is like defvar, but NAME will not be initialized."
1245 heller 1.207 `(progn
1246     (defvar ,name)
1247 heller 1.240 (setf (documentation ',name 'variable) ,doc)))
1248 heller 1.207
1249     (define-special *buffer-package*
1250     "Package corresponding to slime-buffer-package.
1251 dbarlow 1.28
1252 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1253 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1254    
1255 heller 1.207 (define-special *buffer-readtable*
1256     "Readtable associated with the current buffer")
1257 heller 1.189
1258     (defmacro with-buffer-syntax ((&rest _) &body body)
1259     "Execute BODY with appropriate *package* and *readtable* bindings.
1260    
1261     This should be used for code that is conceptionally executed in an
1262     Emacs buffer."
1263     (destructuring-bind () _
1264 heller 1.293 `(call-with-buffer-syntax (lambda () ,@body))))
1265    
1266     (defun call-with-buffer-syntax (fun)
1267     (let ((*package* *buffer-package*))
1268     ;; Don't shadow *readtable* unnecessarily because that prevents
1269     ;; the user from assigning to it.
1270     (if (eq *readtable* *buffer-readtable*)
1271     (call-with-syntax-hooks fun)
1272     (let ((*readtable* *buffer-readtable*))
1273     (call-with-syntax-hooks fun)))))
1274 heller 1.189
1275 heller 1.330 (defun to-string (object)
1276     "Write OBJECT in the *BUFFER-PACKAGE*.
1277 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1278     gracefully."
1279 heller 1.330 (with-buffer-syntax ()
1280     (let ((*print-readably* nil))
1281 nsiivola 1.354 (handler-case
1282     (prin1-to-string object)
1283     (error ()
1284     (with-output-to-string (s)
1285     (print-unreadable-object (object s :type t :identity t)
1286     (princ "<<error printing object>>" s))))))))
1287 heller 1.330
1288 dbarlow 1.28 (defun from-string (string)
1289     "Read string in the *BUFFER-PACKAGE*"
1290 heller 1.189 (with-buffer-syntax ()
1291     (let ((*read-suppress* nil))
1292     (read-from-string string))))
1293 lgorrie 1.60
1294 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
1295     (defun tokenize-symbol (string)
1296     (let ((package (let ((pos (position #\: string)))
1297     (if pos (subseq string 0 pos) nil)))
1298     (symbol (let ((pos (position #\: string :from-end t)))
1299     (if pos (subseq string (1+ pos)) string)))
1300     (internp (search "::" string)))
1301     (values symbol package internp)))
1302    
1303 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1304     "This version of tokenize-symbol handles escape characters."
1305     (let ((package nil)
1306     (token (make-array (length string) :element-type 'character
1307     :fill-pointer 0))
1308     (backslash nil)
1309     (vertical nil)
1310     (internp nil))
1311     (loop for char across string
1312     do (cond
1313     (backslash
1314     (vector-push-extend char token)
1315     (setq backslash nil))
1316     ((char= char #\\) ; Quotes next character, even within |...|
1317     (setq backslash t))
1318     ((char= char #\|)
1319     (setq vertical t))
1320     (vertical
1321     (vector-push-extend char token))
1322     ((char= char #\:)
1323     (if package
1324     (setq internp t)
1325     (setq package token
1326     token (make-array (length string)
1327     :element-type 'character
1328     :fill-pointer 0))))
1329     (t
1330     (vector-push-extend (casify-char char) token))))
1331     (values token package internp)))
1332    
1333     (defun casify-char (char)
1334     "Convert CHAR accoring to readtable-case."
1335 heller 1.245 (ecase (readtable-case *readtable*)
1336 mkoeppe 1.370 (:preserve char)
1337     (:upcase (char-upcase char))
1338     (:downcase (char-downcase char))
1339     (:invert (if (upper-case-p char)
1340     (char-downcase char)
1341     (char-upcase char)))))
1342 heller 1.245
1343 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1344 heller 1.189 "Find the symbol named STRING.
1345 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1346 mkoeppe 1.370 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1347 heller 1.277 (let ((package (cond ((string= pname "") keyword-package)
1348 mkoeppe 1.370 (pname (find-package pname))
1349 heller 1.277 (t package))))
1350     (if package
1351 mkoeppe 1.370 (find-symbol sname package)
1352 heller 1.277 (values nil nil)))))
1353 heller 1.189
1354 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1355     (multiple-value-bind (symbol status) (parse-symbol string package)
1356     (if status
1357     (values symbol status)
1358 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
1359 heller 1.207
1360 heller 1.245 ;; FIXME: interns the name
1361 heller 1.189 (defun parse-package (string)
1362     "Find the package named STRING.
1363     Return the package or nil."
1364 heller 1.196 (multiple-value-bind (name pos)
1365 heller 1.190 (if (zerop (length string))
1366     (values :|| 0)
1367 lgorrie 1.194 (let ((*package* keyword-package))
1368 heller 1.190 (ignore-errors (read-from-string string))))
1369 heller 1.196 (if (and (or (keywordp name) (stringp name))
1370     (= (length string) pos))
1371     (find-package name))))
1372 heller 1.190
1373 heller 1.53 (defun guess-package-from-string (name &optional (default-package *package*))
1374 dbarlow 1.28 (or (and name
1375 heller 1.189 (or (parse-package name)
1376 heller 1.153 (find-package (string-upcase name))
1377 heller 1.189 (parse-package (substitute #\- #\! name))))
1378 heller 1.53 default-package))
1379 dbarlow 1.28
1380 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1381 heller 1.189 "An alist mapping package names to readtables.")
1382    
1383     (defun guess-buffer-readtable (package-name &optional (default *readtable*))
1384     (let ((package (guess-package-from-string package-name)))
1385     (if package
1386     (or (cdr (assoc (package-name package) *readtable-alist*
1387     :test #'string=))
1388     default)
1389     default)))
1390    
1391 lgorrie 1.280 (defun valid-operator-symbol-p (symbol)
1392     "Test if SYMBOL names a function, macro, or special-operator."
1393     (or (fboundp symbol)
1394     (macro-function symbol)
1395     (special-operator-p symbol)))
1396    
1397 heller 1.172 (defun valid-operator-name-p (string)
1398     "Test if STRING names a function, macro, or special-operator."
1399 heller 1.207 (let ((symbol (parse-symbol string)))
1400 lgorrie 1.280 (valid-operator-symbol-p symbol)))
1401 heller 1.172
1402 lgorrie 1.284
1403     ;;;; Arglists
1404    
1405 mkoeppe 1.387 (defun find-valid-operator-name (names)
1406     "As a secondary result, returns its index."
1407     (let ((index
1408     (position-if (lambda (name)
1409     (or (consp name)
1410     (valid-operator-name-p name)))
1411     names)))
1412     (if index
1413     (values (elt names index) index)
1414     (values nil nil))))
1415    
1416 mkoeppe 1.365 (defslimefun arglist-for-echo-area (names &key print-right-margin
1417 mkoeppe 1.372 print-lines arg-indices)
1418 heller 1.148 "Return the arglist for the first function, macro, or special-op in NAMES."
1419 lgorrie 1.246 (handler-case
1420     (with-buffer-syntax ()
1421 mkoeppe 1.387 (multiple-value-bind (name which)
1422     (find-valid-operator-name names)
1423 mkoeppe 1.365 (when which
1424 mkoeppe 1.387 (let ((arg-index (and arg-indices (elt arg-indices which))))
1425 mkoeppe 1.365 (multiple-value-bind (form operator-name)
1426     (operator-designator-to-form name)
1427     (let ((*print-right-margin* print-right-margin))
1428     (format-arglist-for-echo-area
1429     form operator-name
1430     :print-right-margin print-right-margin
1431 mkoeppe 1.372 :print-lines print-lines
1432 mkoeppe 1.369 :highlight (and arg-index
1433     (not (zerop arg-index))
1434 mkoeppe 1.365 ;; don't highlight the operator
1435     arg-index))))))))
1436 lgorrie 1.246 (error (cond)
1437     (format nil "ARGLIST: ~A" cond))))
1438 heller 1.172
1439 mkoeppe 1.362 (defun operator-designator-to-form (name)
1440     (etypecase name
1441     (cons
1442     (destructure-case name
1443 mkoeppe 1.382 ((:make-instance class-name operator-name &rest args)
1444 mkoeppe 1.374 (let ((parsed-operator-name (parse-symbol operator-name)))
1445 mkoeppe 1.382 (values `(,parsed-operator-name ,@args ',(parse-symbol class-name))
1446 mkoeppe 1.374 operator-name)))
1447 mkoeppe 1.362 ((:defmethod generic-name)
1448     (values `(defmethod ,(parse-symbol generic-name))
1449     'defmethod))))
1450     (string
1451     (values `(,(parse-symbol name))
1452     name))))
1453    
1454 heller 1.266 (defun clean-arglist (arglist)
1455     "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1456     (cond ((null arglist) '())
1457     ((member (car arglist) '(&whole &environment))
1458     (clean-arglist (cddr arglist)))
1459     ((eq (car arglist) '&aux)
1460     '())
1461     (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1462    
1463 mkoeppe 1.387 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1464     provided-args ; list of the provided actual arguments
1465     required-args ; list of the required arguments
1466     optional-args ; list of the optional arguments
1467     key-p ; whether &key appeared
1468     keyword-args ; list of the keywords
1469     rest ; name of the &rest or &body argument (if any)
1470     body-p ; whether the rest argument is a &body
1471     allow-other-keys-p ; whether &allow-other-keys appeared
1472     aux-args ; list of &aux variables
1473     known-junk ; &whole, &environment
1474     unknown-junk) ; unparsed stuff
1475    
1476     (defun print-arglist (arglist &key operator highlight)
1477     (let ((index 0)
1478     (need-space nil))
1479     (labels ((print-arg (arg)
1480 heller 1.389 (typecase arg
1481 mkoeppe 1.387 (arglist ; destructuring pattern
1482     (print-arglist arg))
1483     (optional-arg
1484     (princ (encode-optional-arg arg)))
1485     (keyword-arg
1486     (let ((enc-arg (encode-keyword-arg arg)))
1487     (etypecase enc-arg
1488     (symbol (princ enc-arg))
1489     ((cons symbol)
1490     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1491     (princ (car enc-arg))
1492     (write-char #\space)
1493     (pprint-fill *standard-output* (cdr enc-arg) nil)))
1494     ((cons cons)
1495     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1496     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1497     (prin1 (caar enc-arg))
1498     (write-char #\space)
1499     (print-arg (keyword-arg.arg-name arg)))
1500     (unless (null (cdr enc-arg))
1501     (write-char #\space))
1502     (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1503     (t ; required formal or provided actual arg
1504     (princ arg))))
1505     (print-space ()
1506     (ecase need-space
1507     ((nil))
1508     ((:miser)
1509     (write-char #\space)
1510     (pprint-newline :miser))
1511     ((t)
1512     (write-char #\space)
1513     (pprint-newline :fill)))
1514     (setq need-space t))
1515     (print-with-space (obj)
1516     (print-space)
1517     (print-arg obj))
1518     (print-with-highlight (arg &optional (index-ok-p #'=))
1519     (print-space)
1520     (cond
1521     ((and highlight (funcall index-ok-p index highlight))
1522     (princ "===> ")
1523     (print-arg arg)
1524     (princ " <==="))
1525     (t
1526     (print-arg arg)))
1527     (incf index)))
1528     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1529     (when operator
1530     (print-with-highlight operator)
1531     (setq need-space :miser))
1532     (mapc #'print-with-highlight
1533     (arglist.provided-args arglist))
1534     (mapc #'print-with-highlight
1535     (arglist.required-args arglist))
1536     (when (arglist.optional-args arglist)
1537     (print-with-space '&optional)
1538     (mapc #'print-with-highlight
1539     (arglist.optional-args arglist)))
1540     (when (arglist.key-p arglist)
1541     (print-with-space '&key)
1542     (mapc #'print-with-space
1543     (arglist.keyword-args arglist)))
1544     (when (arglist.allow-other-keys-p arglist)
1545     (print-with-space '&allow-other-keys))
1546     (cond ((not (arglist.rest arglist)))
1547     ((arglist.body-p arglist)
1548     (print-with-space '&body)
1549     (print-with-highlight (arglist.rest arglist) #'<=))
1550     (t
1551     (print-with-space '&rest)
1552     (print-with-highlight (arglist.rest arglist) #'<=)))
1553     (mapc #'print-with-space
1554     (arglist.unknown-junk arglist))))))
1555    
1556 mkoeppe 1.372 (defun decoded-arglist-to-string (arglist package
1557     &key operator print-right-margin
1558     print-lines highlight)
1559     "Print the decoded ARGLIST for display in the echo area. The
1560     argument name are printed without package qualifiers and pretty
1561     printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
1562     non-nil, it must be the index of an argument; highlight this argument.
1563     If OPERATOR is non-nil, put it in front of the arglist."
1564     (with-output-to-string (*standard-output*)
1565     (with-standard-io-syntax
1566     (let ((*package* package) (*print-case* :downcase)
1567     (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1568     (*print-level* 10) (*print-length* 20)
1569     (*print-right-margin* print-right-margin)
1570     (*print-lines* print-lines))
1571 mkoeppe 1.387 (print-arglist arglist :operator operator :highlight highlight)))))
1572 mkoeppe 1.372
1573 lgorrie 1.217 (defslimefun variable-desc-for-echo-area (variable-name)
1574     "Return a short description of VARIABLE-NAME, or NIL."
1575     (with-buffer-syntax ()
1576     (let ((sym (parse-symbol variable-name)))
1577     (if (and sym (boundp sym))
1578 heller 1.222 (let ((*print-pretty* nil) (*print-level* 4)
1579     (*print-length* 10) (*print-circle* t))
1580     (format nil "~A => ~A" sym (symbol-value sym)))))))
1581 heller 1.72
1582 mkoeppe 1.387 (defun decode-required-arg (arg)
1583     "ARG can be a symbol or a destructuring pattern."
1584     (etypecase arg
1585     (symbol arg)
1586     (list (decode-arglist arg))))
1587    
1588     (defun encode-required-arg (arg)
1589     (etypecase arg
1590     (symbol arg)
1591     (arglist (encode-arglist arg))))
1592    
1593 lgorrie 1.284 (defstruct (keyword-arg
1594     (:conc-name keyword-arg.)
1595     (:constructor make-keyword-arg (keyword arg-name default-arg)))
1596     keyword
1597     arg-name
1598     default-arg)
1599    
1600 heller 1.276 (defun decode-keyword-arg (arg)
1601     "Decode a keyword item of formal argument list.
1602     Return three values: keyword, argument name, default arg."
1603     (cond ((symbolp arg)
1604 lgorrie 1.284 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1605     arg
1606     nil))
1607 heller 1.276 ((and (consp arg)
1608     (consp (car arg)))
1609 lgorrie 1.284 (make-keyword-arg (caar arg)
1610 mkoeppe 1.387 (decode-required-arg (cadar arg))
1611 lgorrie 1.284 (cadr arg)))
1612 heller 1.276 ((consp arg)
1613 lgorrie 1.284 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1614     (car arg)
1615     (cadr arg)))
1616 heller 1.276 (t
1617 mbaringer 1.399 (abort-request "Bad keyword item of formal argument list"))))
1618 heller 1.276
1619 lgorrie 1.284 (defun encode-keyword-arg (arg)
1620 mkoeppe 1.387 (cond
1621     ((arglist-p (keyword-arg.arg-name arg))
1622     ;; Destructuring pattern
1623     (let ((keyword/name (list (keyword-arg.keyword arg)
1624     (encode-required-arg
1625     (keyword-arg.arg-name arg)))))
1626     (if (keyword-arg.default-arg arg)
1627     (list keyword/name
1628     (keyword-arg.default-arg arg))
1629     (list keyword/name))))
1630     ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1631     keyword-package)
1632     (keyword-arg.keyword arg))
1633     (if (keyword-arg.default-arg arg)
1634     (list (keyword-arg.arg-name arg)
1635     (keyword-arg.default-arg arg))
1636     (keyword-arg.arg-name arg)))
1637     (t
1638     (let ((keyword/name (list (keyword-arg.keyword arg)
1639     (keyword-arg.arg-name arg))))
1640     (if (keyword-arg.default-arg arg)
1641     (list keyword/name
1642     (keyword-arg.default-arg arg))
1643     (list keyword/name))))))
1644 heller 1.276
1645     (progn
1646 lgorrie 1.284 (assert (equalp (decode-keyword-arg 'x)
1647 lgorrie 1.285 (make-keyword-arg :x 'x nil)))
1648 lgorrie 1.284 (assert (equalp (decode-keyword-arg '(x t))
1649 lgorrie 1.285 (make-keyword-arg :x 'x t)))
1650     (assert (equalp (decode-keyword-arg '((:x y)))
1651 lgorrie 1.284 (make-keyword-arg :x 'y nil)))
1652 lgorrie 1.285 (assert (equalp (decode-keyword-arg '((:x y) t))
1653 lgorrie 1.284 (make-keyword-arg :x 'y t))))
1654    
1655     (defstruct (optional-arg
1656     (:conc-name optional-arg.)
1657     (:constructor make-optional-arg (arg-name default-arg)))
1658     arg-name
1659     default-arg)
1660 heller 1.276
1661     (defun decode-optional-arg (arg)
1662     "Decode an optional item of a formal argument list.
1663 lgorrie 1.284 Return an OPTIONAL-ARG structure."
1664 heller 1.276 (etypecase arg
1665 lgorrie 1.284 (symbol (make-optional-arg arg nil))
1666 mkoeppe 1.387 (list (make-optional-arg (decode-required-arg (car arg))
1667     (cadr arg)))))
1668 lgorrie 1.284
1669     (defun encode-optional-arg (optional-arg)
1670 mkoeppe 1.387 (if (or (optional-arg.default-arg optional-arg)
1671     (arglist-p (optional-arg.arg-name optional-arg)))
1672     (list (encode-required-arg
1673     (optional-arg.arg-name optional-arg))
1674 lgorrie 1.284 (optional-arg.default-arg optional-arg))
1675     (optional-arg.arg-name optional-arg)))
1676 heller 1.276
1677     (progn
1678 lgorrie 1.284 (assert (equalp (decode-optional-arg 'x)
1679     (make-optional-arg 'x nil)))
1680     (assert (equalp (decode-optional-arg '(x t))
1681     (make-optional-arg 'x t))))
1682 heller 1.276
1683 mkoeppe 1.372 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1684 lgorrie 1.280
1685     (defun decode-arglist (arglist)
1686 lgorrie 1.284 "Parse the list ARGLIST and return an ARGLIST structure."
1687 lgorrie 1.280 (let ((mode nil)
1688     (result (make-arglist)))
1689     (dolist (arg arglist)
1690 lgorrie 1.284 (cond
1691 mkoeppe 1.372 ((eql mode '&unknown-junk)
1692     ;; don't leave this mode -- we don't know how the arglist
1693     ;; after unknown lambda-list keywords is interpreted
1694     (push arg (arglist.unknown-junk result)))
1695 lgorrie 1.284 ((eql arg '&allow-other-keys)
1696     (setf (arglist.allow-other-keys-p result) t))
1697     ((eql arg '&key)
1698     (setf (arglist.key-p result) t
1699     mode arg))
1700 mkoeppe 1.372 ((member arg '(&optional &rest &body &aux))
1701     (setq mode arg))
1702     ((member arg '(&whole &environment))
1703     (setq mode arg)
1704     (push arg (arglist.known-junk result)))
1705 lgorrie 1.284 ((member arg lambda-list-keywords)
1706 mkoeppe 1.372 (setq mode '&unknown-junk)
1707     (push arg (arglist.unknown-junk result)))
1708 lgorrie 1.284 (t
1709 mkoeppe 1.372 (ecase mode
1710 lgorrie 1.280 (&key
1711     (push (decode-keyword-arg arg)
1712     (arglist.keyword-args result)))
1713     (&optional
1714     (push (decode-optional-arg arg)
1715     (arglist.optional-args result)))
1716     (&body
1717     (setf (arglist.body-p result) t
1718     (arglist.rest result) arg))
1719     (&rest
1720     (setf (arglist.rest result) arg))
1721 mkoeppe 1.372 (&aux
1722     (push (decode-optional-arg arg)
1723     (arglist.aux-args result)))
1724 lgorrie 1.280 ((nil)
1725 mkoeppe 1.387 (push (decode-required-arg arg)
1726     (arglist.required-args result)))
1727 lgorrie 1.284 ((&whole &environment)
1728 mkoeppe 1.372 (setf mode nil)
1729     (push arg (arglist.known-junk result)))))))
1730     (nreversef (arglist.required-args result))
1731     (nreversef (arglist.optional-args result))
1732     (nreversef (arglist.keyword-args result))
1733     (nreversef (arglist.aux-args result))
1734     (nreversef (arglist.known-junk result))
1735     (nreversef (arglist.unknown-junk result))
1736 lgorrie 1.280 result))
1737    
1738 lgorrie 1.284 (defun encode-arglist (decoded-arglist)
1739 mkoeppe 1.387 (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
1740 lgorrie 1.284 (when (arglist.optional-args decoded-arglist)
1741     '(&optional))
1742     (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1743     (when (arglist.key-p decoded-arglist)
1744     '(&key))
1745     (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1746     (when (arglist.allow-other-keys-p decoded-arglist)
1747     '(&allow-other-keys))
1748     (cond ((not (arglist.rest decoded-arglist))
1749     '())
1750     ((arglist.body-p decoded-arglist)
1751     `(&body ,(arglist.rest decoded-arglist)))
1752     (t
1753 mkoeppe 1.372 `(&rest ,(arglist.rest decoded-arglist))))
1754     (when (arglist.aux-args decoded-arglist)
1755     `(&aux ,(arglist.aux-args decoded-arglist)))
1756     (arglist.known-junk decoded-arglist)
1757     (arglist.unknown-junk decoded-arglist)))
1758 lgorrie 1.284
1759 lgorrie 1.280 (defun arglist-keywords (arglist)
1760     "Return the list of keywords in ARGLIST.
1761     As a secondary value, return whether &allow-other-keys appears."
1762     (let ((decoded-arglist (decode-arglist arglist)))
1763     (values (arglist.keyword-args decoded-arglist)
1764     (arglist.allow-other-keys-p decoded-arglist))))
1765    
1766     (defun methods-keywords (methods)
1767     "Collect all keywords in the arglists of METHODS.
1768     As a secondary value, return whether &allow-other-keys appears somewhere."
1769     (let ((keywords '())
1770     (allow-other-keys nil))
1771     (dolist (method methods)
1772     (multiple-value-bind (kw aok)
1773     (arglist-keywords
1774     (swank-mop:method-lambda-list method))
1775 lgorrie 1.284 (setq keywords (remove-duplicates (append keywords kw)
1776     :key #'keyword-arg.keyword)
1777 lgorrie 1.280 allow-other-keys (or allow-other-keys aok))))
1778     (values keywords allow-other-keys)))
1779    
1780     (defun generic-function-keywords (generic-function)
1781     "Collect all keywords in the methods of GENERIC-FUNCTION.
1782     As a secondary value, return whether &allow-other-keys appears somewhere."
1783     (methods-keywords
1784     (swank-mop:generic-function-methods generic-function)))
1785    
1786 crhodes 1.376 (defun applicable-methods-keywords (generic-function arguments)
1787 lgorrie 1.280 "Collect all keywords in the methods of GENERIC-FUNCTION that are
1788     applicable for argument of CLASSES. As a secondary value, return
1789     whether &allow-other-keys appears somewhere."
1790 crhodes 1.376 (methods-keywords
1791     (multiple-value-bind (amuc okp)
1792     (swank-mop:compute-applicable-methods-using-classes
1793     generic-function (mapcar #'class-of arguments))
1794     (if okp
1795     amuc
1796     (compute-applicable-methods generic-function arguments)))))
1797 lgorrie 1.280
1798     (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1799     (with-output-to-string (*standard-output*)
1800     (with-standard-io-syntax
1801     (let ((*package* package) (*print-case* :downcase)
1802     (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1803     (*print-level* 10) (*print-length* 20))
1804 mkoeppe 1.387 (print-decoded-arglist-as-template decoded-arglist
1805     :prefix prefix
1806     :suffix suffix)))))
1807    
1808     (defun print-decoded-arglist-as-template (decoded-arglist &key
1809     (prefix "(") (suffix ")"))
1810     (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1811     (let ((first-p t))
1812     (flet ((space ()
1813     (unless first-p
1814     (write-char #\space)
1815     (pprint-newline :fill))
1816     (setq first-p nil))
1817     (print-arg-or-pattern (arg)
1818     (etypecase arg
1819     (symbol (princ arg))
1820     (string (princ arg))
1821     (list (princ arg))
1822     (arglist (print-decoded-arglist-as-template arg)))))
1823     (dolist (arg (arglist.required-args decoded-arglist))
1824     (space)
1825     (print-arg-or-pattern arg))
1826     (dolist (arg (arglist.optional-args decoded-arglist))
1827     (space)
1828     (princ "[")
1829     (print-arg-or-pattern (optional-arg.arg-name arg))
1830     (princ "]"))
1831     (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1832     (space)
1833     (let ((arg-name (keyword-arg.arg-name keyword-arg))
1834     (keyword (keyword-arg.keyword keyword-arg)))
1835     (format t "~W "
1836     (if (keywordp keyword) keyword `',keyword))
1837     (print-arg-or-pattern arg-name)))
1838     (when (and (arglist.rest decoded-arglist)
1839     (or (not (arglist.keyword-args decoded-arglist))
1840     (arglist.allow-other-keys-p decoded-arglist)))
1841     (if (arglist.body-p decoded-arglist)
1842     (pprint-newline :mandatory)
1843     (space))
1844     (format t "~A..." (arglist.rest decoded-arglist)))))
1845     (pprint-newline :fill)))
1846 lgorrie 1.280
1847     (defgeneric extra-keywords (operator &rest args)
1848 lgorrie 1.284 (:documentation "Return a list of extra keywords of OPERATOR (a
1849 mkoeppe 1.360 symbol) when applied to the (unevaluated) ARGS.
1850     As a secondary value, return whether other keys are allowed.
1851     As a tertiary value, return the initial sublist of ARGS that was needed
1852     to determine the extra keywords."))
1853 lgorrie 1.280
1854     (defmethod extra-keywords (operator &rest args)
1855     ;; default method
1856     (declare (ignore args))
1857     (let ((symbol-function (symbol-function operator)))
1858     (if (typep symbol-function 'generic-function)
1859     (generic-function-keywords symbol-function)
1860     nil)))
1861    
1862 crhodes 1.376 (defun class-from-class-name-form (class-name-form)
1863     (when (and (listp class-name-form)
1864     (= (length class-name-form) 2)
1865     (eq (car class-name-form) 'quote))
1866     (let* ((class-name (cadr class-name-form))
1867     (class (find-class class-name nil)))
1868     (when (and class
1869     (not (swank-mop:class-finalized-p class)))
1870     ;; Try to finalize the class, which can fail if
1871     ;; superclasses are not defined yet
1872     (handler-case (swank-mop:finalize-inheritance class)
1873     (program-error (c)
1874     (declare (ignore c)))))
1875     class)))
1876    
1877     (defun extra-keywords/slots (class)
1878     (multiple-value-bind (slots allow-other-keys-p)
1879     (if (swank-mop:class-finalized-p class)
1880     (values (swank-mop:class-slots class) nil)
1881     (values (swank-mop:class-direct-slots class) t))
1882     (let ((slot-init-keywords
1883     (loop for slot in slots append
1884     (mapcar (lambda (initarg)
1885     (make-keyword-arg
1886     initarg
1887     (swank-mop:slot-definition-name slot)
1888     (swank-mop:slot-definition-initform slot)))
1889     (swank-mop:slot-definition-initargs slot)))))
1890     (values slot-init-keywords allow-other-keys-p))))
1891    
1892 mkoeppe 1.374 (defun extra-keywords/make-instance (operator &rest args)
1893     (declare (ignore operator))
1894 lgorrie 1.280 (unless (null args)
1895 crhodes 1.376 (let* ((class-name-form (car args))
1896     (class (class-from-class-name-form class-name-form)))
1897     (when class
1898     (multiple-value-bind (slot-init-keywords class-aokp)
1899     (extra-keywords/slots class)
1900     (multiple-value-bind (allocate-instance-keywords ai-aokp)
1901     (applicable-methods-keywords
1902     #'allocate-instance (list class))
1903     (multiple-value-bind (initialize-instance-keywords ii-aokp)
1904     (applicable-methods-keywords
1905     #'initialize-instance (list (swank-mop:class-prototype class)))
1906     (multiple-value-bind (shared-initialize-keywords si-aokp)
1907     (applicable-methods-keywords
1908     #'shared-initialize (list (swank-mop:class-prototype class) t))
1909     (values (append slot-init-keywords
1910     allocate-instance-keywords
1911     initialize-instance-keywords
1912     shared-initialize-keywords)
1913     (or class-aokp ai-aokp ii-aokp si-aokp)
1914     (list class-name-form))))))))))
1915    
1916     (defun extra-keywords/change-class (operator &rest args)
1917     (declare (ignore operator))
1918     (unless (null args)
1919     (let* ((class-name-form (car args))
1920     (class (class-from-class-name-form class-name-form)))
1921     (when class
1922     (multiple-value-bind (slot-init-keywords class-aokp)
1923     (extra-keywords/slots class)
1924     (declare (ignore class-aokp))
1925     (multiple-value-bind (shared-initialize-keywords si-aokp)
1926     (applicable-methods-keywords
1927     #'shared-initialize (list (swank-mop:class-prototype class) t))
1928     ;; FIXME: much as it would be nice to include the
1929     ;; applicable keywords from
1930     ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
1931     ;; how to do it: so we punt, always declaring
1932     ;; &ALLOW-OTHER-KEYS.
1933     (declare (ignore si-aokp))
1934     (values (append slot-init-keywords shared-initialize-keywords)
1935     t
1936     (list class-name-form))))))))
1937 mkoeppe 1.374
1938 mkoeppe 1.375 (defmacro multiple-value-or (&rest forms)
1939     (if (null forms)
1940     nil
1941     (let ((first (first forms))
1942     (rest (rest forms)))
1943     `(let* ((values (multiple-value-list ,first))
1944     (primary-value (first values)))
1945     (if primary-value
1946     (values-list values)
1947     (multiple-value-or ,@rest))))))
1948    
1949 mkoeppe 1.374 (defmethod extra-keywords ((operator (eql 'make-instance))
1950     &rest args)
1951 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
1952     (call-next-method)))
1953 mkoeppe 1.374
1954     (defmethod extra-keywords ((operator (eql 'make-condition))
1955     &rest args)
1956 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
1957     (call-next-method)))
1958 mkoeppe 1.374
1959     (defmethod extra-keywords ((operator (eql 'error))
1960     &rest args)
1961 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
1962     (call-next-method)))
1963 mkoeppe 1.374
1964     (defmethod extra-keywords ((operator (eql 'signal))
1965     &rest args)
1966 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
1967     (call-next-method)))
1968 mkoeppe 1.374
1969     (defmethod extra-keywords ((operator (eql 'warn))
1970     &rest args)
1971 mkoeppe 1.375 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
1972     (call-next-method)))
1973 mkoeppe 1.374
1974     (defmethod extra-keywords ((operator (eql 'cerror))
1975     &rest args)
1976 mkoeppe 1.381 (multiple-value-bind (keywords aok determiners)
1977     (apply #'extra-keywords/make-instance operator
1978     (cdr args))
1979     (if keywords
1980     (values keywords aok
1981     (cons (car args) determiners))
1982     (call-next-method))))
1983 heller 1.276
1984 crhodes 1.376 (defmethod extra-keywords ((operator (eql 'change-class))
1985     &rest args)
1986 mkoeppe 1.385 (multiple-value-bind (keywords aok determiners)
1987     (apply #'extra-keywords/change-class operator (cdr args))
1988     (if keywords
1989     (values keywords aok
1990     (cons (car args) determiners))
1991     (call-next-method))))
1992 crhodes 1.376
1993 mkoeppe 1.387 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
1994     "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
1995     (when keywords
1996     (setf (arglist.key-p decoded-arglist) t)
1997     (setf (arglist.keyword-args decoded-arglist)
1998     (remove-duplicates
1999     (append (arglist.keyword-args decoded-arglist)
2000     keywords)
2001     :key #'keyword-arg.keyword)))
2002     (setf (arglist.allow-other-keys-p decoded-arglist)
2003     (or (arglist.allow-other-keys-p decoded-arglist)
2004     allow-other-keys-p)))
2005    
2006 lgorrie 1.284 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
2007 mkoeppe 1.360 "Determine extra keywords from the function call FORM, and modify
2008     DECODED-ARGLIST to include them. As a secondary return value, return
2009     the initial sublist of ARGS that was needed to determine the extra
2010     keywords. As a tertiary return value, return whether any enrichment
2011     was done."
2012     (multiple-value-bind (extra-keywords extra-aok determining-args)
2013 lgorrie 1.284 (apply #'extra-keywords form)
2014     ;; enrich the list of keywords with the extra keywords
2015 mkoeppe 1.387 (enrich-decoded-arglist-with-keywords decoded-arglist
2016     extra-keywords extra-aok)
2017 mkoeppe 1.360 (values decoded-arglist
2018     determining-args
2019     (or extra-keywords extra-aok))))
2020 lgorrie 1.284
2021 mkoeppe 1.387 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
2022     (:documentation
2023     "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2024     ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2025     If the arglist is not available, return :NOT-AVAILABLE."))
2026    
2027     (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2028     (let ((arglist (arglist operator-form)))
2029     (etypecase arglist
2030     ((member :not-available)
2031     :not-available)
2032     (list
2033     (let ((decoded-arglist (decode-arglist arglist)))
2034     (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2035     (cons operator-form
2036     argument-forms)))))))
2037    
2038     (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2039     argument-forms)
2040 mkoeppe 1.393 (declare (ignore argument-forms))
2041 mkoeppe 1.387 (multiple-value-bind (decoded-arglist determining-args)
2042     (call-next-method)
2043     (let ((first-arg (first (arglist.required-args decoded-arglist)))
2044     (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2045     (when (and (arglist-p first-arg) (arglist-p open-arglist))
2046     (enrich-decoded-arglist-with-keywords
2047     first-arg
2048     (arglist.keyword-args open-arglist)
2049     nil)))
2050     (values decoded-arglist determining-args t)))
2051    
2052 mkoeppe 1.391 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
2053     argument-forms)
2054     (let ((function-name-form (car argument-forms)))
2055     (when (and (listp function-name-form)
2056     (= (length function-name-form) 2)
2057     (member (car function-name-form) '(quote function)))
2058     (let ((function-name (cadr function-name-form)))
2059     (when (valid-operator-symbol-p function-name)
2060     (let ((function-arglist
2061     (compute-enriched-decoded-arglist function-name
2062     (cdr argument-forms))))
2063     (return-from compute-enriched-decoded-arglist
2064     (values (make-arglist :required-args
2065     (list 'function)
2066     :optional-args
2067     (append
2068     (mapcar #'(lambda (arg)
2069     (make-optional-arg arg nil))
2070     (arglist.required-args function-arglist))
2071     (arglist.optional-args function-arglist))
2072     :key-p
2073     (arglist.key-p function-arglist)
2074     :keyword-args
2075     (arglist.keyword-args function-arglist)
2076     :rest
2077     'args
2078     :allow-other-keys-p
2079     (arglist.allow-other-keys-p function-arglist))
2080     (list function-name-form)
2081     t)))))))
2082     (call-next-method))
2083    
2084 heller 1.172 (defslimefun arglist-for-insertion (name)
2085 heller 1.207 (with-buffer-syntax ()
2086 lgorrie 1.280 (let ((symbol (parse-symbol name)))
2087     (cond
2088 &nb