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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.368 - (hide annotations)
Wed Mar 22 16:40:01 2006 UTC (8 years ago) by dcrosher
Branch: MAIN
Changes since 1.367: +74 -51 lines
* Improve the robustness of connection establishment.
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 mkoeppe 1.318 (defvar *use-dedicated-output-stream* t
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     ;; FIXME: Escape chars are ignored
1280     (defun casify (string)
1281     "Convert string accoring to readtable-case."
1282     (ecase (readtable-case *readtable*)
1283 heller 1.277 (:preserve string)
1284     (:upcase (string-upcase string))
1285     (:downcase (string-downcase string))
1286     (:invert (multiple-value-bind (lower upper) (determine-case string)
1287     (cond ((and lower upper) string)
1288     (lower (string-upcase string))
1289     (upper (string-downcase string))
1290     (t string))))))
1291 heller 1.245
1292 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1293 heller 1.189 "Find the symbol named STRING.
1294 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1295 heller 1.245 (multiple-value-bind (sname pname) (tokenize-symbol string)
1296 heller 1.277 (let ((package (cond ((string= pname "") keyword-package)
1297     (pname (find-package (casify pname)))
1298     (t package))))
1299     (if package
1300     (find-symbol (casify sname) package)
1301     (values nil nil)))))
1302 heller 1.189
1303 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1304     (multiple-value-bind (symbol status) (parse-symbol string package)
1305     (if status
1306     (values symbol status)
1307     (error "Unknown symbol: ~A [in ~A]" string package))))
1308    
1309 heller 1.245 ;; FIXME: interns the name
1310 heller 1.189 (defun parse-package (string)
1311     "Find the package named STRING.
1312     Return the package or nil."
1313 heller 1.196 (multiple-value-bind (name pos)
1314 heller 1.190 (if (zerop (length string))
1315     (values :|| 0)
1316 lgorrie 1.194 (let ((*package* keyword-package))
1317 heller 1.190 (ignore-errors (read-from-string string))))
1318 heller 1.196 (if (and (or (keywordp name) (stringp name))
1319     (= (length string) pos))
1320     (find-package name))))
1321 heller 1.190
1322 heller 1.53 (defun guess-package-from-string (name &optional (default-package *package*))
1323 dbarlow 1.28 (or (and name
1324 heller 1.189 (or (parse-package name)
1325 heller 1.153 (find-package (string-upcase name))
1326 heller 1.189 (parse-package (substitute #\- #\! name))))
1327 heller 1.53 default-package))
1328 dbarlow 1.28
1329 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1330 heller 1.189 "An alist mapping package names to readtables.")
1331    
1332     (defun guess-buffer-readtable (package-name &optional (default *readtable*))
1333     (let ((package (guess-package-from-string package-name)))
1334     (if package
1335     (or (cdr (assoc (package-name package) *readtable-alist*
1336     :test #'string=))
1337     default)
1338     default)))
1339    
1340 lgorrie 1.280 (defun valid-operator-symbol-p (symbol)
1341     "Test if SYMBOL names a function, macro, or special-operator."
1342     (or (fboundp symbol)
1343     (macro-function symbol)
1344     (special-operator-p symbol)))
1345    
1346 heller 1.172 (defun valid-operator-name-p (string)
1347     "Test if STRING names a function, macro, or special-operator."
1348 heller 1.207 (let ((symbol (parse-symbol string)))
1349 lgorrie 1.280 (valid-operator-symbol-p symbol)))
1350 heller 1.172
1351 lgorrie 1.284
1352     ;;;; Arglists
1353    
1354 mkoeppe 1.365 (defslimefun arglist-for-echo-area (names &key print-right-margin
1355     arg-indices)
1356 heller 1.148 "Return the arglist for the first function, macro, or special-op in NAMES."
1357 lgorrie 1.246 (handler-case
1358     (with-buffer-syntax ()
1359 mkoeppe 1.365 (let ((which (position-if (lambda (name)
1360     (or (consp name)
1361     (valid-operator-name-p name)))
1362     names)))
1363     (when which
1364     (let ((name (elt names which))
1365     (arg-index (and arg-indices (elt arg-indices which))))
1366     (multiple-value-bind (form operator-name)
1367     (operator-designator-to-form name)
1368     (let ((*print-right-margin* print-right-margin))
1369     (format-arglist-for-echo-area
1370     form operator-name
1371     :print-right-margin print-right-margin
1372     :highlight (and (not (zerop arg-index))
1373     ;; don't highlight the operator
1374     arg-index))))))))
1375 lgorrie 1.246 (error (cond)
1376     (format nil "ARGLIST: ~A" cond))))
1377 heller 1.172
1378 mkoeppe 1.362 (defun operator-designator-to-form (name)
1379     (etypecase name
1380     (cons
1381     (destructure-case name
1382     ((:make-instance class-name)
1383     (values `(make-instance ',(parse-symbol class-name))
1384     'make-instance))
1385     ((:defmethod generic-name)
1386     (values `(defmethod ,(parse-symbol generic-name))
1387     'defmethod))))
1388     (string
1389     (values `(,(parse-symbol name))
1390     name))))
1391    
1392 heller 1.266 (defun clean-arglist (arglist)
1393     "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1394     (cond ((null arglist) '())
1395     ((member (car arglist) '(&whole &environment))
1396     (clean-arglist (cddr arglist)))
1397     ((eq (car arglist) '&aux)
1398     '())
1399     (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1400    
1401 mkoeppe 1.365 (defun arglist-to-string (arglist package &key print-right-margin highlight)
1402 heller 1.147 "Print the list ARGLIST for display in the echo area.
1403     The argument name are printed without package qualifiers and
1404 mkoeppe 1.365 pretty printing of (function foo) as #'foo is suppressed.
1405     If HIGHLIGHT is non-nil, it must be the index of an argument;
1406     highlight this argument."
1407 heller 1.266 (setq arglist (clean-arglist arglist))
1408 heller 1.172 (etypecase arglist
1409     (null "()")
1410     (cons
1411     (with-output-to-string (*standard-output*)
1412     (with-standard-io-syntax
1413 lgorrie 1.295 (let ((*package* package) (*print-case* :downcase)
1414 heller 1.266 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1415 mkoeppe 1.364 (*print-level* 10) (*print-length* 20)
1416     (*print-right-margin* print-right-margin))
1417 mkoeppe 1.365 (let ((index 0))
1418     (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1419     (loop
1420     (let ((arg (pop arglist)))
1421     (when (member arg lambda-list-keywords)
1422     ;; The highlighting code is currently only
1423     ;; prepared for the required arguments. To
1424     ;; extend it to work with optional and keyword
1425     ;; arguments as well, arglist-to-string should
1426     ;; get a DECODED-ARGLIST instead. --mkoeppe
1427     (setq highlight nil))
1428     (when (and highlight (= index highlight))
1429     (princ "===> "))
1430     (etypecase arg
1431     (symbol (princ arg))
1432     (string (princ arg))
1433     (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1434     (princ (car arg))
1435     (unless (null (cdr arg))
1436     (write-char #\space))
1437     (pprint-fill *standard-output* (cdr arg) nil))))
1438     (when (and highlight (= index highlight))
1439     (princ " <==="))
1440     (incf index)
1441     (when (null arglist) (return))
1442     (write-char #\space)
1443     (pprint-newline :fill)))))))))))
1444 heller 1.135
1445     (defun test-print-arglist (list string)
1446 heller 1.172 (string= (arglist-to-string list (find-package :swank)) string))
1447 heller 1.135
1448 heller 1.141 ;; Should work:
1449 heller 1.265 (progn
1450     (assert (test-print-arglist '(function cons) "(function cons)"))
1451     (assert (test-print-arglist '(quote cons) "(quote cons)"))
1452 heller 1.266 (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
1453     (assert (test-print-arglist '(&whole x y z) "(y z)"))
1454     (assert (test-print-arglist '(x &aux y z) "(x)"))
1455     (assert (test-print-arglist '(x &environment env y) "(x y)")))
1456 heller 1.141 ;; Expected failure:
1457 heller 1.135 ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
1458 lgorrie 1.217
1459     (defslimefun variable-desc-for-echo-area (variable-name)
1460     "Return a short description of VARIABLE-NAME, or NIL."
1461     (with-buffer-syntax ()
1462     (let ((sym (parse-symbol variable-name)))
1463     (if (and sym (boundp sym))
1464 heller 1.222 (let ((*print-pretty* nil) (*print-level* 4)
1465     (*print-length* 10) (*print-circle* t))
1466     (format nil "~A => ~A" sym (symbol-value sym)))))))
1467 heller 1.72
1468 lgorrie 1.284 (defstruct (keyword-arg
1469     (:conc-name keyword-arg.)
1470     (:constructor make-keyword-arg (keyword arg-name default-arg)))
1471     keyword
1472     arg-name
1473     default-arg)
1474    
1475 heller 1.276 (defun decode-keyword-arg (arg)
1476     "Decode a keyword item of formal argument list.
1477     Return three values: keyword, argument name, default arg."
1478     (cond ((symbolp arg)
1479 lgorrie 1.284 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1480     arg
1481     nil))
1482 heller 1.276 ((and (consp arg)
1483     (consp (car arg)))
1484 lgorrie 1.284 (make-keyword-arg (caar arg)
1485     (cadar arg)
1486     (cadr arg)))
1487 heller 1.276 ((consp arg)
1488 lgorrie 1.284 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1489     (car arg)
1490     (cadr arg)))
1491 heller 1.276 (t
1492     (error "Bad keyword item of formal argument list"))))
1493    
1494 lgorrie 1.284 (defun encode-keyword-arg (arg)
1495     (if (eql (intern (symbol-name (keyword-arg.arg-name arg))
1496     keyword-package)
1497     (keyword-arg.keyword arg))
1498     (if (keyword-arg.default-arg arg)
1499     (list (keyword-arg.arg-name arg)
1500     (keyword-arg.default-arg arg))
1501     (keyword-arg.arg-name arg))
1502     (let ((keyword/name (list (keyword-arg.arg-name arg)
1503     (keyword-arg.keyword arg))))
1504     (if (keyword-arg.default-arg arg)
1505     (list keyword/name
1506     (keyword-arg.default-arg arg))
1507     (list keyword/name)))))
1508 heller 1.276
1509     (progn
1510 lgorrie 1.284 (assert (equalp (decode-keyword-arg 'x)
1511 lgorrie 1.285 (make-keyword-arg :x 'x nil)))
1512 lgorrie 1.284 (assert (equalp (decode-keyword-arg '(x t))
1513 lgorrie 1.285 (make-keyword-arg :x 'x t)))
1514     (assert (equalp (decode-keyword-arg '((:x y)))
1515 lgorrie 1.284 (make-keyword-arg :x 'y nil)))
1516 lgorrie 1.285 (assert (equalp (decode-keyword-arg '((:x y) t))
1517 lgorrie 1.284 (make-keyword-arg :x 'y t))))
1518    
1519     (defstruct (optional-arg
1520     (:conc-name optional-arg.)
1521     (:constructor make-optional-arg (arg-name default-arg)))
1522     arg-name
1523     default-arg)
1524 heller 1.276
1525     (defun decode-optional-arg (arg)
1526     "Decode an optional item of a formal argument list.
1527 lgorrie 1.284 Return an OPTIONAL-ARG structure."
1528 heller 1.276 (etypecase arg
1529 lgorrie 1.284 (symbol (make-optional-arg arg nil))
1530     (list (make-optional-arg (car arg) (cadr arg)))))
1531    
1532     (defun encode-optional-arg (optional-arg)
1533     (if (optional-arg.default-arg optional-arg)
1534     (list (optional-arg.arg-name optional-arg)
1535     (optional-arg.default-arg optional-arg))
1536     (optional-arg.arg-name optional-arg)))
1537 heller 1.276
1538     (progn
1539 lgorrie 1.284 (assert (equalp (decode-optional-arg 'x)
1540     (make-optional-arg 'x nil)))
1541     (assert (equalp (decode-optional-arg '(x t))
1542     (make-optional-arg 'x t))))
1543 heller 1.276
1544 lgorrie 1.280 (defstruct (arglist (:conc-name arglist.))
1545     required-args ; list of the required arguments
1546     optional-args ; list of the optional arguments
1547 lgorrie 1.284 key-p ; whether &key appeared
1548 lgorrie 1.280 keyword-args ; list of the keywords
1549     rest ; name of the &rest or &body argument (if any)
1550     body-p ; whether the rest argument is a &body
1551     allow-other-keys-p) ; whether &allow-other-keys appeared
1552    
1553     (defun decode-arglist (arglist)
1554 lgorrie 1.284 "Parse the list ARGLIST and return an ARGLIST structure."
1555 lgorrie 1.280 (let ((mode nil)
1556     (result (make-arglist)))
1557     (dolist (arg arglist)
1558 lgorrie 1.284 (cond
1559     ((eql arg '&allow-other-keys)
1560     (setf (arglist.allow-other-keys-p result) t))
1561     ((eql arg '&key)
1562     (setf (arglist.key-p result) t
1563     mode arg))
1564     ((member arg lambda-list-keywords)
1565     (setq mode arg))
1566     (t
1567     (case mode
1568 lgorrie 1.280 (&key
1569     (push (decode-keyword-arg arg)
1570     (arglist.keyword-args result)))
1571     (&optional
1572     (push (decode-optional-arg arg)
1573     (arglist.optional-args result)))
1574     (&body
1575     (setf (arglist.body-p result) t
1576     (arglist.rest result) arg))
1577     (&rest
1578     (setf (arglist.rest result) arg))
1579     ((nil)
1580 lgorrie 1.284 (push arg (arglist.required-args result)))
1581     ((&whole &environment)
1582     (setf mode nil))))))
1583 lgorrie 1.280 (setf (arglist.required-args result)
1584     (nreverse (arglist.required-args result)))
1585     (setf (arglist.optional-args result)
1586     (nreverse (arglist.optional-args result)))
1587     (setf (arglist.keyword-args result)
1588     (nreverse (arglist.keyword-args result)))
1589     result))
1590    
1591 lgorrie 1.284 (defun encode-arglist (decoded-arglist)
1592     (append (arglist.required-args decoded-arglist)
1593     (when (arglist.optional-args decoded-arglist)
1594     '(&optional))
1595     (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
1596     (when (arglist.key-p decoded-arglist)
1597     '(&key))
1598     (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
1599     (when (arglist.allow-other-keys-p decoded-arglist)
1600     '(&allow-other-keys))
1601     (cond ((not (arglist.rest decoded-arglist))
1602     '())
1603     ((arglist.body-p decoded-arglist)
1604     `(&body ,(arglist.rest decoded-arglist)))
1605     (t
1606     `(&rest ,(arglist.rest decoded-arglist))))))
1607    
1608 lgorrie 1.280 (defun arglist-keywords (arglist)
1609     "Return the list of keywords in ARGLIST.
1610     As a secondary value, return whether &allow-other-keys appears."
1611     (let ((decoded-arglist (decode-arglist arglist)))
1612     (values (arglist.keyword-args decoded-arglist)
1613     (arglist.allow-other-keys-p decoded-arglist))))
1614    
1615     (defun methods-keywords (methods)
1616     "Collect all keywords in the arglists of METHODS.
1617     As a secondary value, return whether &allow-other-keys appears somewhere."
1618     (let ((keywords '())
1619     (allow-other-keys nil))
1620     (dolist (method methods)
1621     (multiple-value-bind (kw aok)
1622     (arglist-keywords
1623     (swank-mop:method-lambda-list method))
1624 lgorrie 1.284 (setq keywords (remove-duplicates (append keywords kw)
1625     :key #'keyword-arg.keyword)
1626 lgorrie 1.280 allow-other-keys (or allow-other-keys aok))))
1627     (values keywords allow-other-keys)))
1628    
1629     (defun generic-function-keywords (generic-function)
1630     "Collect all keywords in the methods of GENERIC-FUNCTION.
1631     As a secondary value, return whether &allow-other-keys appears somewhere."
1632     (methods-keywords
1633     (swank-mop:generic-function-methods generic-function)))
1634    
1635     (defun applicable-methods-keywords (generic-function classes)
1636     "Collect all keywords in the methods of GENERIC-FUNCTION that are
1637     applicable for argument of CLASSES. As a secondary value, return
1638     whether &allow-other-keys appears somewhere."
1639     (methods-keywords
1640 heller 1.281 (swank-mop:compute-applicable-methods-using-classes
1641     generic-function classes)))
1642 lgorrie 1.280
1643     (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
1644     (with-output-to-string (*standard-output*)
1645     (with-standard-io-syntax
1646     (let ((*package* package) (*print-case* :downcase)
1647     (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1648     (*print-level* 10) (*print-length* 20))
1649     (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
1650     (print-decoded-arglist-as-template decoded-arglist))))))
1651    
1652     (defun print-decoded-arglist-as-template (decoded-arglist)
1653     (let ((first-p t))
1654     (flet ((space ()
1655     (unless first-p
1656     (write-char #\space)
1657     (pprint-newline :fill))
1658     (setq first-p nil)))
1659     (dolist (arg (arglist.required-args decoded-arglist))
1660     (space)
1661     (princ arg))
1662     (dolist (arg (arglist.optional-args decoded-arglist))
1663     (space)
1664 lgorrie 1.284 (format t "[~A]" (optional-arg.arg-name arg)))
1665     (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
1666 lgorrie 1.280 (space)
1667 lgorrie 1.284 (let ((arg-name (keyword-arg.arg-name keyword-arg))
1668     (keyword (keyword-arg.keyword keyword-arg)))
1669     (format t "~W ~A"
1670     (if (keywordp keyword) keyword `',keyword)
1671     arg-name)))
1672 lgorrie 1.280 (when (and (arglist.rest decoded-arglist)
1673     (or (not (arglist.keyword-args decoded-arglist))
1674     (arglist.allow-other-keys-p decoded-arglist)))
1675     (if (arglist.body-p decoded-arglist)
1676     (pprint-newline :mandatory)
1677     (space))
1678     (format t "~A..." (arglist.rest decoded-arglist)))))
1679     (pprint-newline :fill))
1680    
1681     (defgeneric extra-keywords (operator &rest args)
1682 lgorrie 1.284 (:documentation "Return a list of extra keywords of OPERATOR (a
1683 mkoeppe 1.360 symbol) when applied to the (unevaluated) ARGS.
1684     As a secondary value, return whether other keys are allowed.
1685     As a tertiary value, return the initial sublist of ARGS that was needed
1686     to determine the extra keywords."))
1687 lgorrie 1.280
1688     (defmethod extra-keywords (operator &rest args)
1689     ;; default method
1690     (declare (ignore args))
1691     (let ((symbol-function (symbol-function operator)))
1692     (if (typep symbol-function 'generic-function)
1693     (generic-function-keywords symbol-function)
1694     nil)))
1695    
1696     (defmethod extra-keywords ((operator (eql 'make-instance))
1697     &rest args)
1698     (unless (null args)
1699     (let ((class-name-form (car args)))
1700     (when (and (listp class-name-form)
1701     (= (length class-name-form) 2)
1702     (eq (car class-name-form) 'quote))
1703     (let* ((class-name (cadr class-name-form))
1704     (class (find-class class-name nil)))
1705 mkoeppe 1.360 (when (and class
1706     (not (swank-mop:class-finalized-p class)))
1707 lgorrie 1.284 ;; Try to finalize the class, which can fail if
1708     ;; superclasses are not defined yet
1709     (handler-case (swank-mop:finalize-inheritance class)
1710     (program-error (c)
1711     (declare (ignore c)))))
1712 lgorrie 1.280 (when class
1713     ;; We have the case (make-instance 'CLASS ...)
1714     ;; with a known CLASS.
1715 lgorrie 1.284 (multiple-value-bind (slots allow-other-keys-p)
1716     (if (swank-mop:class-finalized-p class)
1717     (values (swank-mop:class-slots class) nil)
1718     (values (swank-mop:class-direct-slots class) t))
1719     (let ((slot-init-keywords
1720     (loop for slot in slots append
1721     (mapcar (lambda (initarg)
1722     (make-keyword-arg
1723     initarg
1724     initarg ; FIXME
1725     (swank-mop:slot-definition-initform slot)))
1726     (swank-mop:slot-definition-initargs slot))))
1727     (initialize-instance-keywords
1728     (applicable-methods-keywords #'initialize-instance
1729     (list class))))
1730     (return-from extra-keywords
1731     (values (append slot-init-keywords
1732     initialize-instance-keywords)
1733 mkoeppe 1.360 allow-other-keys-p
1734     (list class-name-form))))))))))
1735 lgorrie 1.280 (call-next-method))
1736 heller 1.276
1737 lgorrie 1.284 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
1738 mkoeppe 1.360 "Determine extra keywords from the function call FORM, and modify
1739     DECODED-ARGLIST to include them. As a secondary return value, return
1740     the initial sublist of ARGS that was needed to determine the extra
1741     keywords. As a tertiary return value, return whether any enrichment
1742     was done."
1743     (multiple-value-bind (extra-keywords extra-aok determining-args)
1744 lgorrie 1.284 (apply #'extra-keywords form)
1745     ;; enrich the list of keywords with the extra keywords
1746     (when extra-keywords
1747     (setf (arglist.key-p decoded-arglist) t)
1748     (setf (arglist.keyword-args decoded-arglist)
1749     (remove-duplicates
1750     (append (arglist.keyword-args decoded-arglist)
1751     extra-keywords)
1752     :key #'keyword-arg.keyword)))
1753     (setf (arglist.allow-other-keys-p decoded-arglist)
1754 mkoeppe 1.360 (or (arglist.allow-other-keys-p decoded-arglist) extra-aok))
1755     (values decoded-arglist
1756     determining-args
1757     (or extra-keywords extra-aok))))
1758 lgorrie 1.284
1759 heller 1.172 (defslimefun arglist-for-insertion (name)
1760 heller 1.207 (with-buffer-syntax ()
1761 lgorrie 1.280 (let ((symbol (parse-symbol name)))
1762     (cond
1763     ((and symbol
1764     (valid-operator-name-p name))
1765     (let ((arglist (arglist symbol)))
1766     (etypecase arglist
1767     ((member :not-available)
1768 heller 1.276 :not-available)
1769 lgorrie 1.280 (list
1770 lgorrie 1.284 (let ((decoded-arglist (decode-arglist arglist)))
1771     (enrich-decoded-arglist-with-extra-keywords decoded-arglist
1772     (list symbol))
1773 lgorrie 1.280 (decoded-arglist-to-template-string decoded-arglist
1774     *buffer-package*))))))
1775     (t
1776     :not-available)))))
1777    
1778 lgorrie 1.284 (defvar *remove-keywords-alist*
1779     '((:test :test-not)
1780     (:test-not :test)))
1781    
1782 lgorrie 1.280 (defun remove-actual-args (decoded-arglist actual-arglist)
1783     "Remove from DECODED-ARGLIST the arguments that have already been
1784     provided in ACTUAL-ARGLIST."
1785     (loop while (and actual-arglist
1786     (arglist.required-args decoded-arglist))
1787     do (progn (pop actual-arglist)
1788     (pop (arglist.required-args decoded-arglist))))
1789     (loop while (and actual-arglist
1790     (arglist.optional-args decoded-arglist))
1791     do (progn (pop actual-arglist)
1792     (pop (arglist.optional-args decoded-arglist))))
1793     (loop for keyword in actual-arglist by #'cddr
1794 lgorrie 1.284 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
1795 lgorrie 1.280 do (setf (arglist.keyword-args decoded-arglist)
1796 lgorrie 1.284 (remove-if (lambda (kw)
1797     (or (eql kw keyword)
1798     (member kw keywords-to-remove)))
1799     (arglist.keyword-args decoded-arglist)
1800     :key #'keyword-arg.keyword))))
1801 lgorrie 1.280
1802 mkoeppe 1.360 (defgeneric form-completion (operator-form argument-forms &key remove-args))
1803 mkoeppe 1.319
1804 mkoeppe 1.360 (defmethod form-completion (operator-form argument-forms &key (remove-args t))
1805 mkoeppe 1.319 (when (and (symbolp operator-form)
1806     (valid-operator-symbol-p operator-form))
1807     (let ((arglist (arglist operator-form)))
1808     (etypecase arglist
1809     ((member :not-available)
1810     :not-available)
1811     (list
1812     (let ((decoded-arglist (decode-arglist arglist)))
1813 mkoeppe 1.360 (multiple-value-bind (decoded-arglist determining-args any-enrichment)
1814     (enrich-decoded-arglist-with-extra-keywords decoded-arglist
1815     (cons operator-form
1816     argument-forms))
1817     (cond
1818     (remove-args
1819     ;; get rid of formal args already provided
1820     (remove-actual-args decoded-arglist argument-forms))
1821     (t
1822     ;; replace some formal args by determining actual args
1823     (remove-actual-args decoded-arglist determining-args)
1824     (setf (arglist.required-args decoded-arglist)
1825     (append determining-args
1826     (arglist.required-args decoded-arglist)))))
1827     (return-from form-completion
1828     (values decoded-arglist any-enrichment))))))))
1829 mkoeppe 1.319 :not-available)
1830    
1831     (defmethod form-completion ((operator-form (eql 'defmethod))
1832 mkoeppe 1.360 argument-forms &key (remove-args t))
1833 mkoeppe 1.319 (when (and (listp argument-forms)
1834     (not (null argument-forms)) ;have generic function name
1835     (notany #'listp (rest argument-forms))) ;don't have arglist yet
1836     (let* ((gf-name (first argument-forms))
1837     (gf (and (or (symbolp gf-name)
1838     (and (listp gf-name)
1839     (eql (first gf-name) 'setf)))
1840     (fboundp gf-name)
1841     (fdefinition gf-name))))
1842     (when (typep gf 'generic-function)
1843     (let ((arglist (arglist gf)))
1844     (etypecase arglist
1845     ((member :not-available))
1846     (list
1847     (return-from form-completion
1848 mkoeppe 1.360 (values (make-arglist :required-args (if remove-args
1849     (list arglist)
1850     (list gf-name arglist))
1851     :rest "body" :body-p t)
1852     t))))))))
1853 mkoeppe 1.319 (call-next-method))
1854    
1855 mkoeppe 1.360 (defun read-incomplete-form-from-string (form-string)
1856     (with-buffer-syntax ()
1857     (handler-case
1858     (read-from-string form-string)
1859     (reader-error (c)
1860     (declare (ignore c))
1861     nil)
1862     (stream-error (c)
1863     (declare (ignore c))
1864     nil))))
1865    
1866 lgorrie 1.280 (defslimefun complete-form (form-string)
1867     "Read FORM-STRING in the current buffer package, then complete it
1868     by adding a template for the missing arguments."
1869 mkoeppe 1.360 (let ((form (read-incomplete-form-from-string form-string)))
1870     (when (consp form)
1871     (let ((operator-form (first form))
1872     (argument-forms (rest form)))
1873     (let ((form-completion
1874     (form-completion operator-form argument-forms)))
1875     (unless (eql form-completion :not-available)
1876     (return-from complete-form
1877     (decoded-arglist-to-template-string form-completion
1878     *buffer-package*
1879     :prefix ""))))))
1880     :not-available))
1881    
1882 mkoeppe 1.364 (defun format-arglist-for-echo-area (form operator-name
1883 mkoeppe 1.365 &key print-right-margin highlight)
1884 mkoeppe 1.360 "Return the arglist for FORM as a string."
1885     (when (consp form)
1886     (let ((operator-form (first form))
1887     (argument-forms (rest form)))
1888     (multiple-value-bind (form-completion any-enrichment)
1889     (form-completion operator-form argument-forms
1890     :remove-args nil)
1891     (cond
1892     ((eql form-completion :not-available)
1893     nil)
1894     ((not any-enrichment)
1895     ;; Just use the original arglist.
1896     ;; This works better for implementation-specific
1897     ;; lambda-list-keywords like CMUCL's &parse-body.
1898     (let ((arglist (arglist operator-form)))
1899     (etypecase arglist
1900     ((member :not-available)
1901     nil)
1902     (list
1903     (return-from format-arglist-for-echo-area
1904     (arglist-to-string (cons operator-name arglist)
1905 mkoeppe 1.364 *package*
1906 mkoeppe 1.365 :print-right-margin print-right-margin
1907     :highlight highlight))))))
1908 mkoeppe 1.360 (t
1909     (return-from format-arglist-for-echo-area
1910     (arglist-to-string
1911     (cons operator-name
1912     (encode-arglist form-completion))
1913 mkoeppe 1.364 *package*
1914 mkoeppe 1.365 :print-right-margin print-right-margin
1915     :highlight highlight)))))))
1916 mkoeppe 1.360 nil)
1917 heller 1.172
1918 mkoeppe 1.362 (defslimefun completions-for-keyword (name keyword-string)
1919     (with-buffer-syntax ()
1920     (let* ((form (operator-designator-to-form name))
1921     (operator-form (first form))
1922     (argument-forms (rest form))
1923     (arglist
1924     (form-completion operator-form argument-forms
1925     :remove-args nil)))
1926     (unless (eql arglist :not-available)
1927     (let* ((keywords
1928     (mapcar #'keyword-arg.keyword
1929     (arglist.keyword-args arglist)))
1930     (keyword-name
1931     (tokenize-symbol keyword-string))
1932     (matching-keywords
1933     (find-matching-symbols-in-list keyword-name keywords
1934     #'compound-prefix-match))
1935     (converter (output-case-converter keyword-string))
1936     (strings
1937     (mapcar converter
1938     (mapcar #'symbol-name matching-keywords)))
1939     (completion-set
1940     (format-completion-set strings nil "")))
1941     (list completion-set
1942     (longest-completion completion-set)))))))
1943    
1944    
1945 lgorrie 1.62
1946 mkoeppe 1.323 ;;;; Recording and accessing results of computations
1947    
1948     (defvar *record-repl-results* t
1949     "Non-nil means that REPL results are saved for later lookup.")
1950    
1951     (defvar *object-to-presentation-id*
1952 mkoeppe 1.326 (make-weak-key-hash-table :test 'eq)
1953 mkoeppe 1.323 "Store the mapping of objects to numeric identifiers")
1954    
1955     (defvar *presentation-id-to-object*
1956 heller 1.331 (make-weak-value-hash-table :test 'eql)
1957 mkoeppe 1.323 "Store the mapping of numeric identifiers to objects")
1958    
1959     (defun clear-presentation-tables ()
1960     (clrhash *object-to-presentation-id*)
1961     (clrhash *presentation-id-to-object*))
1962    
1963     (defvar *presentation-counter* 0 "identifier counter")
1964    
1965 heller 1.331 ;; XXX thread safety?
1966     (defun save-presented-object (object)
1967     "Save OBJECT and return the assigned id.
1968     If OBJECT was saved previously return the old id."
1969     (or (gethash object *object-to-presentation-id*)
1970 heller 1.357 (let ((id (incf *presentation-counter*)))
1971 heller 1.331 (setf (gethash id *presentation-id-to-object*) object)
1972     (setf (gethash object *object-to-presentation-id*) id)
1973     id)))
1974 mkoeppe 1.323
1975     (defun lookup-presented-object (id)
1976 heller 1.331 "Retrieve the object corresponding to ID.
1977 heller 1.337 The secondary value indicates the absence of an entry."
1978 heller 1.331 (gethash id *presentation-id-to-object*))
1979 mkoeppe 1.323
1980     (defslimefun get-repl-result (id)
1981     "Get the result of the previous REPL evaluation with ID."
1982 heller 1.331 (multiple-value-bind (object foundp) (lookup-presented-object id)
1983     (cond (foundp object)
1984     (t (error "Attempt to access unrecorded object (id ~D)." id)))))
1985 mkoeppe 1.323
1986     (defslimefun clear-repl-results ()
1987     "Forget the results of all previous REPL evaluations."
1988     (clear-presentation-tables)
1989     t)
1990    
1991    
1992 lgorrie 1.218 ;;;; Evaluation
1993    
1994 heller 1.278 (defvar *pending-continuations* '()
1995     "List of continuations for Emacs. (thread local)")
1996    
1997 lgorrie 1.218 (defun guess-buffer-package (string)
1998     "Return a package for STRING.
1999     Fall back to the the current if no such package exists."
2000     (or (guess-package-from-string string nil)
2001     *package*))
2002    
2003     (defun eval-for-emacs (form buffer-package id)
2004     "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
2005     Return the result to the continuation ID.
2006     Errors are trapped and invoke our debugger."
2007 heller 1.281 (call-with-debugger-hook
2008     #'swank-debugger-hook
2009     (lambda ()
2010     (let (ok result)
2011     (unwind-protect
2012     (let ((*buffer-package* (guess-buffer-package buffer-package))
2013     (*buffer-readtable* (guess-buffer-readtable buffer-package))
2014 heller 1.331 (*pending-continuations* (cons id *pending-continuations*)))
2015 heller 1.293 (check-type *buffer-package* package)
2016     (check-type *buffer-readtable* readtable)
2017 heller 1.353 ;; APPLY would be cleaner than EVAL.
2018     ;;(setq result (apply (car form) (cdr form)))
2019 heller 1.281 (setq result (eval form))
2020 heller 1.339 (finish-output)
2021 heller 1.281 (run-hook *pre-reply-hook*)
2022     (setq ok t))
2023     (force-user-output)
2024     (send-to-emacs `(:return ,(current-thread)
2025     ,(if ok `(:ok ,result) '(:abort))
2026     ,id)))))))
2027 lgorrie 1.218
2028 heller 1.337 (defvar *echo-area-prefix* "=> "
2029     "A prefix that `format-values-for-echo-area' should use.")
2030    
2031 lgorrie 1.218 (defun format-values-for-echo-area (values)
2032     (with-buffer-syntax ()
2033     (let ((*print-readably* nil))
2034 heller 1.242 (cond ((null values) "; No value")
2035     ((and (null (cdr values)) (integerp (car values)))
2036     (let ((i (car values)))
2037 heller 1.337 (format nil "~A~D (#x~X, #o~O, #b~B)"
2038     *echo-area-prefix* i i i i)))
2039     (t (format nil "~A~{~S~^, ~}" *echo-area-prefix* values))))))
2040 lgorrie 1.218
2041     (defslimefun interactive-eval (string)
2042 heller 1.331 (with-buffer-syntax ()
2043     (let ((values (multiple-value-list (eval (from-string string)))))
2044     (fresh-line)
2045 heller 1.339 (finish-output)
2046 heller 1.332 (format-values-for-echo-area values))))
2047 lgorrie 1.218
2048 heller 1.278 (defslimefun eval-and-grab-output (string)
2049     (with-buffer-syntax ()
2050     (let* ((s (make-string-output-stream))
2051     (*standard-output* s)
2052 heller 1.293 (values (multiple-value-list (eval (from-string string)))))
2053 heller 1.278 (list (get-output-stream-string s)
2054     (format nil "~{~S~^~%~}" values)))))
2055    
2056 heller 1.331 ;;; XXX do we need this stuff? What is it good for?
2057 aruttenberg 1.298 (defvar *slime-repl-advance-history* nil
2058     "In the dynamic scope of a single form typed at the repl, is set to nil to
2059     prevent the repl from advancing the history - * ** *** etc.")
2060    
2061     (defvar *slime-repl-suppress-output* nil
2062     "In the dynamic scope of a single form typed at the repl, is set to nil to
2063     prevent the repl from printing the result of the evalation.")
2064    
2065     (defvar *slime-repl-eval-hook-pass* (gensym "PASS")
2066     "Token to indicate that a repl hook declines to evaluate the form")
2067    
2068     (defvar *slime-repl-eval-hooks* nil
2069     "A list of functions. When the repl is about to eval a form, first try running each of
2070     these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
2071     is considered a replacement for calling eval. If there are no hooks, or all
2072     pass, then eval is used.")
2073    
2074     (defslimefun repl-eval-hook-pass ()
2075     "call when repl hook declines to evaluate the form"
2076     (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
2077    
2078     (defslimefun repl-suppress-output ()
2079     "In the dynamic scope of a single form typed at the repl, call to
2080     prevent the repl from printing the result of the evalation."
2081     (setq *slime-repl-suppress-output* t))
2082    
2083     (defslimefun repl-suppress-advance-history ()
2084     "In the dynamic scope of a single form typed at the repl, call to
2085     prevent the repl from advancing the history - * ** *** etc."
2086     (setq *slime-repl-advance-history* nil))
2087    
2088 lgorrie 1.218 (defun eval-region (string &optional package-update-p)
2089     "Evaluate STRING and return the result.
2090     If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
2091     change, then send Emacs an update."
2092 heller 1.269 (unwind-protect
2093     (with-input-from-string (stream string)
2094     (let (- values)
2095     (loop
2096     (let ((form (read stream nil stream)))
2097     (when (eq form stream)
2098     (fresh-line)
2099 heller 1.339 (finish-output)
2100 heller 1.269 (return (values values -)))
2101     (setq - form)
2102 aruttenberg 1.298 (if *slime-repl-eval-hooks*
2103 heller 1.331 (setq values (run-repl-eval-hooks form))
2104     (setq values (multiple-value-list (eval form))))
2105 heller 1.339 (finish-output)))))
2106 heller 1.269 (when (and package-update-p (not (eq *package* *buffer-package*)))
2107     (send-to-emacs
2108     (list :new-package (package-name *package*)
2109     (package-string-for-prompt *package*))))))
2110 lgorrie 1.218
2111 heller 1.331 (defun run-repl-eval-hooks (form)
2112     (loop for hook in *slime-repl-eval-hooks*
2113 aruttenberg 1.333 for res = (catch *slime-repl-eval-hook-pass*
2114     (multiple-value-list (funcall hook form)))
2115     until (not (eq res *slime-repl-eval-hook-pass*))
2116     finally (return
2117     (if (eq res *slime-repl-eval-hook-pass*)
2118     (multiple-value-list (eval form))
2119     res))))
2120 heller 1.331
2121 lgorrie 1.218 (defun package-string-for-prompt (package)
2122     "Return the shortest nickname (or canonical name) of PACKAGE."
2123 heller 1.348 (princ-to-string
2124     (make-symbol
2125     (or (canonical-package-nickname package)
2126     (auto-abbreviated-package-name package)
2127     (shortest-package-nickname package)))))
2128 lgorrie 1.218
2129     (defun canonical-package-nickname (package)
2130     "Return the canonical package nickname, if any, of PACKAGE."
2131 dcrosher 1.347 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2132     :test #'string=))))
2133     (and name (string name))))
2134 lgorrie 1.218
2135     (defun auto-abbreviated-package-name (package)
2136 heller 1.278 "Return an abbreviated 'name' for PACKAGE.
2137    
2138     N.B. this is not an actual package name or nickname."
2139 lgorrie 1.218 (when *auto-abbreviate-dotted-packages*
2140     (let ((last-dot (position #\. (package-name package) :from-end t)))
2141     (when last-dot (subseq (package-name package) (1+ last-dot))))))
2142    
2143     (defun shortest-package-nickname (package)
2144     "Return the shortest nickname (or canonical name) of PACKAGE."
2145     (loop for name in (cons (package-name package) (package-nicknames package))
2146     for shortest = name then (if (< (length name) (length shortest))
2147     name
2148     shortest)
2149     finally (return shortest)))
2150    
2151     (defslimefun interactive-eval-region (string)
2152     (with-buffer-syntax ()
2153     (format-values-for-echo-area (eval-region string))))
2154    
2155     (defslimefun re-evaluate-defvar (form)
2156     (with-buffer-syntax ()
2157     (let ((form (read-from-string form)))
2158     (destructuring-bind (dv name &optional value doc) form
2159     (declare (ignore value doc))
2160     (assert (eq dv 'defvar))
2161     (makunbound name)
2162     (prin1-to-string (eval form))))))
2163    
2164 heller 1.288 (defvar *swank-pprint-bindings*
2165     `((*print-pretty* . t)
2166     (*print-level* . nil)
2167     (*print-length* . nil)
2168     (*print-circle* . t)
2169     (*print-gensym* . t)
2170     (*print-readably* . nil))
2171     "A list of variables bindings during pretty printing.
2172     Used by pprint-eval.")
2173    
2174 lgorrie 1.218 (defun swank-pprint (list)
2175     "Bind some printer variables and pretty print each object in LIST."
2176     (with-buffer-syntax ()
2177 heller 1.288 (with-bindings *swank-pprint-bindings*
2178     (cond ((null list) "; No value")
2179     (t (with-output-to-string (*standard-output*)
2180     (dolist (o list)
2181     (pprint o)
2182     (terpri))))))))
2183 heller 1.250
2184 lgorrie 1.218 (defslimefun pprint-eval (string)
2185     (with-buffer-syntax ()
2186     (swank-pprint (multiple-value-list (eval (read-from-string string))))))
2187    
2188     (defslimefun set-package (package)
2189 heller 1.243 "Set *package* to PACKAGE.
2190     Return its name and the string to use in the prompt."
2191 lgorrie 1.218 (let ((p (setq *package* (guess-package-from-string package))))
2192     (list (package-name p) (package-string-for-prompt p))))
2193    
2194     (defslimefun listener-eval (string)
2195     (clear-user-input)
2196     (with-buffer-syntax ()
2197 aruttenberg 1.298 (let ((*slime-repl-suppress-output* :unset)
2198     (*slime-repl-advance-history* :unset))
2199 heller 1.331 (multiple-value-bind (values last-form) (eval-region string t)
2200 aruttenberg 1.298 (unless (or (and (eq values nil) (eq last-form nil))
2201     (eq *slime-repl-advance-history* nil))
2202     (setq *** ** ** * * (car values)
2203 heller 1.331 /// // // / / values))
2204 aruttenberg 1.298 (setq +++ ++ ++ + + last-form)
2205 heller 1.331 (cond ((eq *slime-repl-suppress-output* t) '(:suppress-output))
2206     (*record-repl-results*
2207     `(:present ,(loop for x in values
2208     collect (cons (prin1-to-string x)
2209     (save-presented-object x)))))
2210     (t
2211 heller 1.337 `(:values ,(mapcar #'prin1-to-string values))))))))
2212 lgorrie 1.218
2213     (defslimefun ed-in-emacs (&optional what)
2214     "Edit WHAT in Emacs.
2215    
2216     WHAT can be:
2217 crhodes 1.307 A pathname or a string,
2218     A list (PATHNAME-OR-STRING LINE [COLUMN]),
2219 lgorrie 1.218 A function name (symbol),
2220 crhodes 1.307 NIL.
2221    
2222     Returns true if it actually called emacs, or NIL if not."
2223     (flet ((pathname-or-string-p (thing)
2224     (or (pathnamep thing) (typep thing 'string))))
2225     (let ((target
2226     (cond ((and (listp what) (pathname-or-string-p (first what)))
2227     (cons (canonicalize-filename (car what)) (cdr what)))
2228     ((pathname-or-string-p what)
2229     (canonicalize-filename what))
2230     ((symbolp what) what)
2231     (t (return-from ed-in-emacs nil)))))
2232     (send-oob-to-emacs `(:ed ,target))
2233     t)))
2234 lgorrie 1.218
2235 lgorrie 1.286 (defslimefun value-for-editing (form)
2236     "Return a readable value of FORM for editing in Emacs.
2237     FORM is expected, but not required, to be SETF'able."
2238     ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2239 heller 1.288 (with-buffer-syntax ()
2240     (prin1-to-string (eval (read-from-string form)))))
2241 lgorrie 1.286
2242     (defslimefun commit-edited-value (form value)
2243     "Set the value of a setf'able FORM to VALUE.
2244     FORM and VALUE are both strings from Emacs."
2245 heller 1.289 (with-buffer-syntax ()
2246 heller 1.330 (eval `(setf ,(read-from-string form)
2247     ,(read-from-string (concatenate 'string "`" value))))
2248 heller 1.289 t))
2249 lgorrie 1.286
2250 heller 1.330 (defun background-message (format-string &rest args)
2251     "Display a message in Emacs' echo area.
2252    
2253     Use this function for informative messages only. The message may even
2254     be dropped, if we are too busy with other things."
2255     (when *emacs-connection*
2256     (send-to-emacs `(:background-message
2257     ,(apply #'format nil format-string args)))))
2258    
2259 lgorrie 1.218
2260 lgorrie 1.62 ;;;; Debugger
2261 heller 1.47
2262 heller 1.38 (defun swank-debugger-hook (condition hook)
2263 lgorrie 1.177 "Debugger function for binding *DEBUGGER-HOOK*.
2264 lgorrie 1.62 Sends a message to Emacs declaring that the debugger has been entered,
2265     then waits to handle further requests from Emacs. Eventually returns
2266     after Emacs causes a restart to be invoked."
2267 heller 1.67 (declare (ignore hook))
2268 heller 1.291 (cond (*emacs-connection*
2269     (debug-in-emacs condition))
2270     ((default-connection)
2271     (with-connection ((default-connection))
2272     (debug-in-emacs condition)))))
2273 lgorrie 1.223
2274     (defvar *global-debugger* t
2275     "Non-nil means the Swank debugger hook will be installed globally.")
2276    
2277     (add-hook *new-connection-hook* 'install-debugger)
2278     (defun install-debugger (connection)
2279     (declare (ignore connection))
2280     (when *global-debugger*
2281 heller 1.348 (install-debugger-globally #'swank-debugger-hook)))
2282 lgorrie 1.157
2283 lgorrie 1.212 ;;;;; Debugger loop
2284     ;;;
2285     ;;; These variables are dynamically bound during debugging.
2286     ;;;
2287     (defvar *swank-debugger-condition* nil
2288     "The condition being debugged.")
2289    
2290     (defvar *sldb-level* 0
2291     "The current level of recursive debugging.")
2292    
2293     (defvar *sldb-initial-frames* 20
2294     "The initial number of backtrace frames to send to Emacs.")
2295    
2296     (defvar *sldb-restarts* nil
2297     "The list of currenlty active restarts.")
2298    
2299 heller 1.256 (defvar *sldb-stepping-p* nil
2300     "True when during execution of a stepp command.")
2301    
2302 lgorrie 1.157 (defun debug-in-emacs (condition)
2303 heller 1.38 (let ((*swank-debugger-condition* condition)
2304 heller 1.138 (*sldb-restarts* (compute-restarts condition))
2305 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
2306     (symbol-value '*buffer-package*))
2307 heller 1.112 *package*))
2308     (*sldb-level* (1+ *sldb-level*))
2309 heller 1.256 (*sldb-stepping-p* nil)
2310 heller 1.250 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2311 lgorrie 1.157 (force-user-output)
2312 heller 1.288 (with-bindings *sldb-printer-bindings*
2313     (call-with-debugging-environment
2314     (lambda () (sldb-loop *sldb-level*))))))
2315 lgorrie 1.80
2316 lgorrie 1.62 (defun sldb-loop (level)
2317 heller 1.119 (unwind-protect
2318     (catch 'sldb-enter-default-debugger
2319     (send-to-emacs
2320 heller 1.291 (list* :debug (current-thread) level
2321 heller 1.119 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2322 heller 1.117 (loop (catch 'sldb-loop-catcher
2323     (with-simple-restart (abort "Return to sldb level ~D." level)
2324     (send-to-emacs (list :debug-activate (current-thread)
2325 heller 1.291 level))
2326 heller 1.117 (handler-bind ((sldb-condition #'handle-sldb-condition))
2327 heller 1.119 (read-from-emacs))))))
2328 heller 1.291 (send-to-emacs `(:debug-return
2329 heller 1.256 ,(current-thread) ,level ,*sldb-stepping-p*))))
2330 heller 1.117
2331 lgorrie 1.62 (defun handle-sldb-condition (condition)
2332     "Handle an internal debugger condition.
2333     Rather than recursively debug the debugger (a dangerous idea!), these
2334     conditions are simply reported."
2335     (let ((real-condition (original-condition condition)))
2336 heller 1.115 (send-to-emacs `(:debug-condition ,(current-thread)
2337 heller 1.250 ,(princ-to-string real-condition))))
2338 lgorrie 1.62 (throw 'sldb-loop-catcher nil))
2339    
2340 heller 1.86 (defun safe-condition-message (condition)
2341     "Safely print condition to a string, handling any errors during
2342     printing."
2343 heller 1.147 (let ((*print-pretty* t))
2344     (handler-case
2345 lgorrie 1.188 (format-sldb-condition condition)
2346 heller 1.147 (error (cond)
2347     ;; Beware of recursive errors in printing, so only use the condition
2348     ;; if it is printable itself:
2349     (format nil "Unable to display error condition~@[: ~A~]"
2350     (ignore-errors (princ-to-string cond)))))))
2351 heller 1.86
2352     (defun debugger-condition-for-emacs ()
2353     (list (safe-condition-message *swank-debugger-condition*)
2354     (format nil " [Condition of type ~S]"
2355 lgorrie 1.188 (type-of *swank-debugger-condition*))
2356 heller 1.240 (condition-references *swank-debugger-condition*)
2357     (condition-extras *swank-debugger-condition*)))
2358 heller 1.86
2359 heller 1.138 (defun format-restarts-for-emacs ()
2360     "Return a list of restarts for *swank-debugger-condition* in a
2361     format suitable for Emacs."
2362     (loop for restart in *sldb-restarts*
2363     collect (list (princ-to-string (restart-name restart))
2364     (princ-to-string restart))))
2365    
2366     (defun frame-for-emacs (n frame)
2367 heller 1.272 (let* ((label (format nil " ~2D: " n))
2368 heller 1.86 (string (with-output-to-string (stream)
2369 heller 1.138 (princ label stream)
2370 heller 1.250 (print-frame frame stream))))
2371 heller 1.86 (subseq string (length label))))
2372    
2373 lgorrie 1.212 ;;;;; SLDB entry points
2374    
2375     (defslimefun sldb-break-with-default-debugger ()
2376     "Invoke the default debugger by returning from our debugger-loop."
2377     (throw 'sldb-enter-default-debugger nil))
2378    
2379 heller 1.138 (defslimefun backtrace (start end)
2380 heller 1.147 "Return a list ((I FRAME) ...) of frames from START to END.
2381     I is an integer describing and FRAME a string."
2382 heller 1.331 (loop for frame in (compute-backtrace start end)
2383     for i from start
2384     collect (list i (frame-for-emacs i frame))))
2385 heller 1.138
2386     (defslimefun debugger-info-for-emacs (start end)
2387     "Return debugger state, with stack frames from START to END.
2388     The result is a list:
2389 heller 1.278 (condition ({restart}*) ({stack-frame}*) (cont*))
2390 heller 1.138 where
2391 heller 1.240 condition ::= (description type [extra])
2392 heller 1.138 restart ::= (name description)
2393     stack-frame ::= (number description)
2394 heller 1.278 extra ::= (:references and other random things)
2395     cont ::= continutation
2396 heller 1.240 condition---a pair of strings: message, and type. If show-source is
2397     not nil it is a frame number for which the source should be displayed.
2398 heller 1.138
2399     restart---a pair of strings: restart name, and description.
2400    
2401     stack-frame---a number from zero (the top), and a printed
2402     representation of the frame's call.
2403    
2404 heller 1.278 continutation---the id of a pending Emacs continuation.
2405    
2406 heller 1.138 Below is an example return value. In this case the condition was a
2407     division by zero (multi-line description), and only one frame is being
2408     fetched (start=0, end=1).
2409    
2410     ((\"Arithmetic error DIVISION-BY-ZERO signalled.
2411     Operation was KERNEL::DIVISION, operands (1 0).\"
2412     \"[Condition of type DIVISION-BY-ZERO]\")
2413     ((\"ABORT\" \"Return to Slime toplevel.\")
2414     (\"ABORT\" \"Return to Top-Level.\"))
2415 heller 1.278 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
2416     (4))"
2417 heller 1.138 (list (debugger-condition-for-emacs)
2418     (format-restarts-for-emacs)
2419 heller 1.278 (backtrace start end)
2420     *pending-continuations*))
2421 heller 1.138
2422     (defun nth-restart (index)
2423     (nth index *sldb-restarts*))
2424    
2425     (defslimefun invoke-nth-restart (index)
2426     (invoke-restart-interactively (nth-restart index)))
2427    
2428     (defslimefun sldb-abort ()
2429     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
2430    
2431 lgorrie 1.62 (defslimefun sldb-continue ()
2432 heller 1.79 (continue))
2433 lgorrie 1.64
2434 heller 1.142 (defslimefun throw-to-toplevel ()
2435 heller 1.340 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
2436 lgorrie 1.194 If we are not evaluating an RPC then ABORT instead."
2437 heller 1.340 (let ((restart (find-restart 'abort-request)))
2438     (cond (restart (invoke-restart restart))
2439 heller 1.357 (t "Restart not found: ABORT-REQUEST"))))
2440 heller 1.142
2441 lgorrie 1.84 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
2442     "Invoke the Nth available restart.
2443     SLDB-LEVEL is the debug level when the request was made. If this
2444     has changed, ignore the request."
2445     (when (= sldb-level *sldb-level*)
2446     (invoke-nth-restart n)))
2447    
2448 heller 1.291 (defun wrap-sldb-vars (form)
2449     `(let ((*sldb-level* ,*sldb-level*))
2450     ,form))
2451    
2452 lgorrie 1.64 (defslimefun eval-string-in-frame (string index)
2453 heller 1.291 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
2454     index)))
2455 lgorrie 1.62
2456 heller 1.138 (defslimefun pprint-eval-string-in-frame (string index)
2457     (swank-pprint
2458     (multiple-value-list
2459 heller 1.291 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
2460 heller 1.138
2461 heller 1.147 (defslimefun frame-locals-for-emacs (index)
2462     "Return a property list ((&key NAME ID VALUE) ...) describing
2463     the local variables in the frame INDEX."
2464 heller 1.271 (mapcar (lambda (frame-locals)
2465     (destructuring-bind (&key name id value) frame-locals
2466     (list :name (prin1-to-string name) :id id
2467     :value (to-string value))))
2468     (frame-locals index)))
2469 mbaringer 1.136
2470 heller 1.138 (defslimefun frame-catch-tags-for-emacs (frame-index)
2471 heller 1.147 (mapcar #'to-string (frame-catch-tags frame-index)))
2472 heller 1.139
2473     (defslimefun sldb-disassemble (index)
2474     (with-output-to-string (*standard-output*)
2475     (disassemble-frame index)))
2476 heller 1.138
2477 heller 1.147 (defslimefun sldb-return-from-frame (index string)
2478     (let ((form (from-string string)))
2479     (to-string (multiple-value-list (return-from-frame index form)))))
2480 heller 1.240
2481     (defslimefun sldb-break (name)
2482     (with-buffer-syntax ()
2483     (sldb-break-at-start (read-from-string name))))
2484 lgorrie 1.173
2485 heller 1.256 (defslimefun sldb-step (frame)
2486     (cond ((find-restart 'continue)
2487     (activate-stepping frame)
2488     (setq *sldb-stepping-p* t)
2489     (continue))
2490     (t
2491     (error "No continue restart."))))
2492    
2493 lgorrie 1.62
2494 dbarlow 1.29 ;;;; Compilation Commands.
2495    
2496     (defvar *compiler-notes* '()
2497     "List of compiler notes for the last compilation unit.")
2498    
2499     (defun clear-compiler-notes ()
2500 lgorrie 1.61 (setf *compiler-notes* '()))
2501 dbarlow 1.29
2502     (defun canonicalize-filename (filename)
2503     (namestring (truename filename)))
2504    
2505 heller 1.31 (defslimefun compiler-notes-for-emacs ()
2506     "Return the list of compiler notes for the last compilation unit."
2507     (reverse *compiler-notes*))
2508    
2509 dbarlow 1.29 (defun measure-time-interval (fn)
2510     "Call FN and return the first return value and the elapsed time.
2511     The time is measured in microseconds."
2512 heller 1.111 (declare (type function fn))
2513 dbarlow 1.29 (let ((before (get-internal-real-time)))
2514     (values
2515     (funcall fn)
2516     (* (- (get-internal-real-time) before)
2517     (/ 1000000 internal-time-units-per-second)))))
2518    
2519 lgorrie 1.61 (defun record-note-for-condition (condition)
2520     "Record a note for a compiler-condition."
2521     (push (make-compiler-note condition) *compiler-notes*))
2522    
2523     (defun make-compiler-note (condition)
2524     "Make a compiler note data structure from a compiler-condition."
2525     (declare (type compiler-condition condition))
2526 heller 1.121 (list* :message (message condition)
2527     :severity (severity condition)
2528     :location (location condition)
2529 crhodes 1.213 :references (references condition)
2530 heller 1.121 (let ((s (short-message condition)))
2531     (if s (list :short-message s)))))
2532 lgorrie 1.32
2533 dbarlow 1.78 (defun swank-compiler (function)
2534 heller 1.331 (clear-compiler-notes)
2535     (with-simple-restart (abort "Abort SLIME compilation.")
2536     (multiple-value-bind (result usecs)
2537     (handler-bind ((compiler-condition #'record-note-for-condition))
2538     (measure-time-interval function))
2539     (list (to-string result)
2540     (format nil "~,2F" (/ usecs 1000000.0))))))
2541 lgorrie 1.61
2542 heller 1.311 (defslimefun compile-file-for-emacs (filename load-p &optional external-format)
2543 dbarlow 1.78 "Compile FILENAME and, when LOAD-P, load the result.
2544     Record compiler notes signalled as `compiler-condition's."
2545 heller 1.331 (with-buffer-syntax ()
2546     (let ((*compile-print* nil))
2547     (swank-compiler (lambda () (swank-compile-file filename load-p
2548     external-format))))))
2549 dbarlow 1.78
2550 pseibel 1.224 (defslimefun compile-string-for-emacs (string buffer position directory)
2551 lgorrie 1.62 "Compile STRING (exerpted from BUFFER at POSITION).
2552     Record compiler notes signalled as `compiler-condition's."
2553 heller 1.189 (with-buffer-syntax ()
2554     (swank-compiler
2555     (lambda ()
2556 heller 1.289 (let ((*compile-print* nil) (*compile-verbose* t))
2557     (swank-compile-string string :buffer buffer :position position
2558     :directory directory))))))
2559 dbarlow 1.78
2560 lgorrie 1.167 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
2561 dbarlow 1.78 "Compile and load SYSTEM using ASDF.
2562     Record compiler notes signalled as `compiler-condition's."
2563 heller 1.171 (swank-compiler
2564     (lambda ()
2565     (apply #'operate-on-system system-name operation keywords))))
2566 dbarlow 1.78
2567 heller 1.171 (defun asdf-central-registry ()
2568     (when (find-package :asdf)
2569     (symbol-value (find-symbol (string :*central-registry*) :asdf))))
2570    
2571     (defslimefun list-all-systems-in-central-registry ()
2572     "Returns a list of all systems in ASDF's central registry."
2573 eweitz 1.308 (delete-duplicates
2574     (loop for dir in (asdf-central-registry)
2575     for defaults = (eval dir)
2576     when defaults
2577     nconc (mapcar #'file-namestring
2578     (directory
2579     (make-pathname :defaults defaults
2580     :version :newest
2581     :type "asd"
2582     :name :wild
2583     :case :local))))
2584     :test #'string=))
2585    
2586 heller 1.195 (defun file-newer-p (new-file old-file)
2587     "Returns true if NEW-FILE is newer than OLD-FILE."
2588     (> (file-write-date new-file) (file-write-date old-file)))
2589    
2590     (defun requires-compile-p (source-file)
2591     (let ((fasl-file (probe-file (compile-file-pathname source-file))))
2592     (or (not fasl-file)
2593     (file-newer-p source-file fasl-file))))
2594    
2595     (defslimefun compile-file-if-needed (filename loadp)
2596     (cond ((requires-compile-p filename)
2597     (compile-file-for-emacs filename loadp))
2598     (loadp
2599     (load (compile-file-pathname filename))
2600     nil)))
2601    
2602    
2603     ;;;; Loading
2604    
2605     (defslimefun load-file (filename)
2606 heller 1.331 (to-string (load filename)))
2607 heller 1.243
2608     (defslimefun load-file-set-package (filename &optional package)
2609     (load-file filename)
2610     (if package
2611     (set-package package)))
2612 heller 1.195
2613 lgorrie 1.62
2614 lgorrie 1.70 ;;;; Macroexpansion
2615 dbarlow 1.29
2616 heller 1.288 (defvar *macroexpand-printer-bindings*
2617     '((*print-circle* . nil)
2618     (*print-pretty* . t)
2619     (*print-escape* . t)
2620     (*print-level* . nil)
2621     (*print-length* . nil)))
2622    
2623 dbarlow 1.29 (defun apply-macro-expander (expander string)
2624 heller 1.111 (declare (type function expander))
2625 heller 1.242 (with-buffer-syntax ()
2626 heller 1.288 (with-bindings *macroexpand-printer-bindings*
2627     (prin1-to-string (funcall expander (from-string string))))))
2628 dbarlow 1.29
2629     (defslimefun swank-macroexpand-1 (string)
2630     (apply-macro-expander #'macroexpand-1 string))
2631    
2632     (defslimefun swank-macroexpand (string)
2633     (apply-macro-expander #'macroexpand string))
2634    
2635</