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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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