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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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