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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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