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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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