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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.494 - (show annotations)
Thu Aug 23 16:19:56 2007 UTC (6 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.493: +363 -159 lines
	Added arglist display for declaration specifiers and type
	specifiers.

	Examples:

	`(declare (type' will display

	   (declare (type type-specifier &rest vars))

	`(declare (type (float' will display

	   [Typespec] (float &optional lower-limit upper-limit)

	`(declare (optimize' will display

	   (declare (optimize &any (safety 1) (space 1) (speed 1) ...))

	&ANY is a new lambda keyword that is introduced for arglist
	description purpose, and is very similiar to &KEY, but isn't based
	upon plists; they're more based upon *FEATURES* lists. (See the
	comment near the ARGLIST defstruct in `swank.lisp'.)

	* slime.el:
	(slime-to-feature-keyword): Renamed to `slime-keywordify'.
	(slime-eval-feature-conditional): Adapted to use `slime-keywordify'.
	(slime-ensure-list): New utility.
	(slime-sexp-at-point): Now takes an argument that specify how many
	sexps at point should be returned.
	(slime-enclosing-operator-names): Renamed to
	`slime-enclosing-form-specs'.
	(slime-enclosing-form-specs): Returns a list of ``raw form specs''
	instead of what was called ``extended operator names'' before, see
	`swank::parse-form-spec' for more information. This is a
	simplified superset. Additionally as tertiary return value return
	a list of points to let the caller see where each form spec is
	located. Adapted callers accordingly. Extended docstring.
	(slime-parse-extended-operator-name): Adapted to changes in
	`slime-enclosing-form-specs'. Now gets more context, and is such
	more powerful. This was needed to allow parsing DECLARE forms.
	(slime-make-extended-operator-parser/look-ahead): Because the
	protocol for arglist display was simplified, it was possible to
	replace the plethora of parsing function just by this one.
	(slime-extended-operator-name-parser-alist): Use it. Also add
	parser for DECLARE forms.
	(slime-parse-extended-operator/declare): Responsible for parsing
	DECLARE forms.
	(%slime-in-mid-of-typespec-p): Helper function for
	`slime-parse-extended-operator/declare'.
	(slime-incomplete-form-at-point): New. Return the ``raw form
	spec'' near point.
	(slime-complete-form): Use `slime-incomplete-form-at-point'.

	* swank.lisp: New Helper functions.
	(length=, ensure-list, recursively-empty-p): New.
	(maybecall, exactly-one-p): New.

	* swank.lisp (arglist-for-echo-area): Adapted to take ``raw form
	specs'' from Slime.
	(parse-form-spec): New. Takes a ``raw form spec'' and returns a
	``form spec'' for further processing in Swank. Docstring documents
	these two terms.
	(split-form-spec): New. Return relevant information from a form	spec.
	(parse-first-valid-form-spec): Replaces `find-valid-operator-name'.
	(find-valid-operator-name): Removed.
	(operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'.

	(defstruct arglist): Add `any-p' and `any-args' slots to contain
	arguments belonging to the &ANY lambda keyword.
	(print-arglist): Adapted to also print &ANY args.
	(print-decoded-arglist-as-template): Likewise.
	(decode-arglist): Adapted to also decode &ANY args.
	(remove-actual-args): Adapted to also remove &ANY args.
	(remove-&key-args): Split out from `remove-actual-args'.
	(remove-&any-args): New. Removes already provided &ANY args.
	(arglist-from-form-spec): New. Added detailed docstring.
	(arglist-dispatch): Dispatching generic function for
	`arglist-from-form-spec' that does all the work. Renamed from
	prior `form-completion'.
	(arglist-dispatch) Added methods for dealing with declaration and
	type-specifiers.
	(complete-form): Adapted to take ``raw form specs'' from Slime.
	(completions-for-keyword): Likewise.
	(format-arglist-for-echo-area): Removed. Not needed anymore.

	* swank-backend.lisp (declaration-arglist): New generic
	function. Returns the arglist for a given declaration
	identifier. (Backends are supposed to specialize it if they can
	provide additional information.)
	(type-specifier-arglist): New generic function. Returns the
	arglist for a given type-specifier operator. (Backends are
	supposed to specialize it if they can provide additional
	information.)
	(*type-specifier-arglists*): New variable. Contains the arglists
	for the type specifiers in Common Lisp.

	* swank-sbcl.lisp: Now depends upon sb-cltl2.
	(declaration-arglist 'optimize): Specialize the `optimize'
	declaration identifier to pass it to
	sb-cltl2:declaration-information.
1 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 ;;;
3 ;;; This code has been placed in the Public Domain. All warranties
4 ;;; are disclaimed.
5 ;;;
6 ;;;; swank.lisp
7 ;;;
8 ;;; 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
15 (defpackage :swank
16 (:use :common-lisp :swank-backend)
17 (:export #:startup-multiprocessing
18 #:start-server
19 #:create-server
20 #:ed-in-emacs
21 #:inspect-in-emacs
22 #:print-indentation-lossage
23 #:swank-debugger-hook
24 #:run-after-init-hook
25 #:inspect-for-emacs
26 #:inspect-slot-for-emacs
27 ;; These are user-configurable variables:
28 #:*communication-style*
29 #:*dont-close*
30 #:*log-events*
31 #:*log-output*
32 #:*use-dedicated-output-stream*
33 #:*dedicated-output-stream-port*
34 #:*configure-emacs-indentation*
35 #:*readtable-alist*
36 #:*globally-redirect-io*
37 #:*global-debugger*
38 #:*sldb-printer-bindings*
39 #:*swank-pprint-bindings*
40 #:*default-worker-thread-bindings*
41 #:*macroexpand-printer-bindings*
42 #:*record-repl-results*
43 #:*debug-on-swank-error*
44 ;; These are re-exported directly from the backend:
45 #:buffer-first-change
46 #:frame-source-location-for-emacs
47 #:restart-frame
48 #:sldb-step
49 #:sldb-break
50 #:sldb-break-on-return
51 #:profiled-functions
52 #:profile-report
53 #:profile-reset
54 #:unprofile-all
55 #:profile-package
56 #:default-directory
57 #:set-default-directory
58 #:quit-lisp))
59
60 (in-package :swank)
61
62
63 ;;;; Top-level variables, constants, macros
64
65 (defconstant cl-package (find-package :cl)
66 "The COMMON-LISP package.")
67
68 (defconstant keyword-package (find-package :keyword)
69 "The KEYWORD package.")
70
71 (defvar *canonical-package-nicknames*
72 `((:common-lisp-user . :cl-user))
73 "Canonical package names to use instead of shortest name/nickname.")
74
75 (defvar *auto-abbreviate-dotted-packages* t
76 "Abbreviate dotted package names to their last component if T.")
77
78 (defvar *swank-io-package*
79 (let ((package (make-package :swank-io-package :use '())))
80 (import '(nil t quote) package)
81 package))
82
83 (defconstant default-server-port 4005
84 "The default TCP port for the server (when started manually).")
85
86 (defvar *swank-debug-p* t
87 "When true, print extra debugging information.")
88
89 (defvar *redirect-io* t
90 "When non-nil redirect Lisp standard I/O to Emacs.
91 Redirection is done while Lisp is processing a request for Emacs.")
92
93 (defvar *sldb-printer-bindings*
94 `((*print-pretty* . t)
95 (*print-level* . 4)
96 (*print-length* . 10)
97 (*print-circle* . t)
98 (*print-readably* . nil)
99 (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
100 (*print-gensym* . t)
101 (*print-base* . 10)
102 (*print-radix* . nil)
103 (*print-array* . t)
104 (*print-lines* . 10)
105 (*print-escape* . t)
106 (*print-right-margin* . 70))
107 "A set of printer variables used in the debugger.")
108
109 (defvar *default-worker-thread-bindings* '()
110 "An alist to initialize dynamic variables in worker threads.
111 The list has the form ((VAR . VALUE) ...). Each variable VAR will be
112 bound to the corresponding VALUE.")
113
114 (defun call-with-bindings (alist fun)
115 "Call FUN with variables bound according to ALIST.
116 ALIST is a list of the form ((VAR . VAL) ...)."
117 (let* ((rlist (reverse alist))
118 (vars (mapcar #'car rlist))
119 (vals (mapcar #'cdr rlist)))
120 (progv vars vals
121 (funcall fun))))
122
123 (defmacro with-bindings (alist &body body)
124 "See `call-with-bindings'."
125 `(call-with-bindings ,alist (lambda () ,@body)))
126
127 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
128 ;;; RPC.
129
130 (defmacro defslimefun (name arglist &body rest)
131 "A DEFUN for functions that Emacs can call by RPC."
132 `(progn
133 (defun ,name ,arglist ,@rest)
134 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
135 (eval-when (:compile-toplevel :load-toplevel :execute)
136 (export ',name :swank))))
137
138 (defun missing-arg ()
139 "A function that the compiler knows will never to return a value.
140 You can use (MISSING-ARG) as the initform for defstruct slots that
141 must always be supplied. This way the :TYPE slot option need not
142 include some arbitrary initial value like NIL."
143 (error "A required &KEY or &OPTIONAL argument was not supplied."))
144
145
146 ;;;; Hooks
147 ;;;
148 ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
149 ;;; simple indirection. The interface is more CLish than the Emacs
150 ;;; Lisp one.
151
152 (defmacro add-hook (place function)
153 "Add FUNCTION to the list of values on PLACE."
154 `(pushnew ,function ,place))
155
156 (defun run-hook (functions &rest arguments)
157 "Call each of FUNCTIONS with ARGUMENTS."
158 (dolist (function functions)
159 (apply function arguments)))
160
161 (defvar *new-connection-hook* '()
162 "This hook is run each time a connection is established.
163 The connection structure is given as the argument.
164 Backend code should treat the connection structure as opaque.")
165
166 (defvar *connection-closed-hook* '()
167 "This hook is run when a connection is closed.
168 The connection as passed as an argument.
169 Backend code should treat the connection structure as opaque.")
170
171 (defvar *pre-reply-hook* '()
172 "Hook run (without arguments) immediately before replying to an RPC.")
173
174 (defvar *after-init-hook* '()
175 "Hook run after user init files are loaded.")
176
177 (defun run-after-init-hook ()
178 (run-hook *after-init-hook*))
179
180
181 ;;;; Connections
182 ;;;
183 ;;; Connection structures represent the network connections between
184 ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
185 ;;; streams that redirect to Emacs, and optionally a second socket
186 ;;; used solely to pipe user-output to Emacs (an optimization).
187 ;;;
188
189 (defstruct (connection
190 (:conc-name connection.)
191 (:print-function print-connection))
192 ;; Raw I/O stream of socket connection.
193 (socket-io (missing-arg) :type stream :read-only t)
194 ;; Optional dedicated output socket (backending `user-output' slot).
195 ;; Has a slot so that it can be closed with the connection.
196 (dedicated-output nil :type (or stream null))
197 ;; Streams that can be used for user interaction, with requests
198 ;; redirected to Emacs.
199 (user-input nil :type (or stream null))
200 (user-output nil :type (or stream null))
201 (user-io nil :type (or stream null))
202 ;; A stream where we send REPL results.
203 (repl-results nil :type (or stream null))
204 ;; In multithreaded systems we delegate certain tasks to specific
205 ;; threads. The `reader-thread' is responsible for reading network
206 ;; requests from Emacs and sending them to the `control-thread'; the
207 ;; `control-thread' is responsible for dispatching requests to the
208 ;; threads that should handle them; the `repl-thread' is the one
209 ;; that evaluates REPL expressions. The control thread dispatches
210 ;; all REPL evaluations to the REPL thread and for other requests it
211 ;; spawns new threads.
212 reader-thread
213 control-thread
214 repl-thread
215 ;; Callback functions:
216 ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
217 ;; from Emacs.
218 (serve-requests (missing-arg) :type function)
219 ;; (READ) is called to read and return one message from Emacs.
220 (read (missing-arg) :type function)
221 ;; (SEND OBJECT) is called to send one message to Emacs.
222 (send (missing-arg) :type function)
223 ;; (CLEANUP <this-connection>) is called when the connection is
224 ;; closed.
225 (cleanup nil :type (or null function))
226 ;; Cache of macro-indentation information that has been sent to Emacs.
227 ;; This is used for preparing deltas to update Emacs's knowledge.
228 ;; Maps: symbol -> indentation-specification
229 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
230 ;; The list of packages represented in the cache:
231 (indentation-cache-packages '())
232 ;; The communication style used.
233 (communication-style nil :type (member nil :spawn :sigio :fd-handler))
234 ;; The coding system for network streams.
235 (coding-system ))
236
237 (defun print-connection (conn stream depth)
238 (declare (ignore depth))
239 (print-unreadable-object (conn stream :type t :identity t)))
240
241 (defvar *connections* '()
242 "List of all active connections, with the most recent at the front.")
243
244 (defvar *emacs-connection* nil
245 "The connection to Emacs currently in use.")
246
247 (defvar *swank-state-stack* '()
248 "A list of symbols describing the current state. Used for debugging
249 and to detect situations where interrupts can be ignored.")
250
251 (defun default-connection ()
252 "Return the 'default' Emacs connection.
253 This connection can be used to talk with Emacs when no specific
254 connection is in use, i.e. *EMACS-CONNECTION* is NIL.
255
256 The default connection is defined (quite arbitrarily) as the most
257 recently established one."
258 (first *connections*))
259
260 (defslimefun state-stack ()
261 "Return the value of *SWANK-STATE-STACK*."
262 *swank-state-stack*)
263
264 ;; A conditions to include backtrace information
265 (define-condition swank-error (error)
266 ((condition :initarg :condition :reader swank-error.condition)
267 (backtrace :initarg :backtrace :reader swank-error.backtrace))
268 (:report (lambda (condition stream)
269 (princ (swank-error.condition condition) stream))))
270
271 (defun make-swank-error (condition)
272 (let ((bt (ignore-errors
273 (call-with-debugging-environment
274 (lambda () (backtrace 0 nil))))))
275 (make-condition 'swank-error :condition condition :backtrace bt)))
276
277 (add-hook *new-connection-hook* 'notify-backend-of-connection)
278 (defun notify-backend-of-connection (connection)
279 (declare (ignore connection))
280 (emacs-connected))
281
282
283 ;;;; Helper macros
284
285 (defmacro with-io-redirection ((connection) &body body)
286 "Execute BODY I/O redirection to CONNECTION.
287 If *REDIRECT-IO* is true then all standard I/O streams are redirected."
288 `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
289
290 (defun maybe-call-with-io-redirection (connection fun)
291 (if *redirect-io*
292 (call-with-redirected-io connection fun)
293 (funcall fun)))
294
295 (defmacro with-connection ((connection) &body body)
296 "Execute BODY in the context of CONNECTION."
297 `(call-with-connection ,connection (lambda () ,@body)))
298
299 (defun call-with-connection (connection fun)
300 (let ((*emacs-connection* connection))
301 (with-io-redirection (*emacs-connection*)
302 (call-with-debugger-hook #'swank-debugger-hook fun))))
303
304 (defmacro without-interrupts (&body body)
305 `(call-without-interrupts (lambda () ,@body)))
306
307 (defmacro destructure-case (value &rest patterns)
308 "Dispatch VALUE to one of PATTERNS.
309 A cross between `case' and `destructuring-bind'.
310 The pattern syntax is:
311 ((HEAD . ARGS) . BODY)
312 The list of patterns is searched for a HEAD `eq' to the car of
313 VALUE. If one is found, the BODY is executed with ARGS bound to the
314 corresponding values in the CDR of VALUE."
315 (let ((operator (gensym "op-"))
316 (operands (gensym "rand-"))
317 (tmp (gensym "tmp-")))
318 `(let* ((,tmp ,value)
319 (,operator (car ,tmp))
320 (,operands (cdr ,tmp)))
321 (case ,operator
322 ,@(loop for (pattern . body) in patterns collect
323 (if (eq pattern t)
324 `(t ,@body)
325 (destructuring-bind (op &rest rands) pattern
326 `(,op (destructuring-bind ,rands ,operands
327 ,@body)))))
328 ,@(if (eq (caar (last patterns)) t)
329 '()
330 `((t (error "destructure-case failed: ~S" ,tmp))))))))
331
332 (defmacro with-temp-package (var &body body)
333 "Execute BODY with VAR bound to a temporary package.
334 The package is deleted before returning."
335 `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
336 (unwind-protect (progn ,@body)
337 (delete-package ,var))))
338
339 (defvar *log-events* nil)
340 (defvar *log-output* *error-output*)
341 (defvar *event-history* (make-array 40 :initial-element nil)
342 "A ring buffer to record events for better error messages.")
343 (defvar *event-history-index* 0)
344 (defvar *enable-event-history* t)
345
346 (defun log-event (format-string &rest args)
347 "Write a message to *terminal-io* when *log-events* is non-nil.
348 Useful for low level debugging."
349 (with-standard-io-syntax
350 (let ((*print-readably* nil)
351 (*print-pretty* nil)
352 (*package* *swank-io-package*))
353 (when *enable-event-history*
354 (setf (aref *event-history* *event-history-index*)
355 (format nil "~?" format-string args))
356 (setf *event-history-index*
357 (mod (1+ *event-history-index*) (length *event-history*))))
358 (when *log-events*
359 (apply #'format *log-output* format-string args)
360 (force-output *log-output*)))))
361
362 (defun event-history-to-list ()
363 "Return the list of events (older events first)."
364 (let ((arr *event-history*)
365 (idx *event-history-index*))
366 (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
367
368 (defun dump-event-history (stream)
369 (dolist (e (event-history-to-list))
370 (dump-event e stream)))
371
372 (defun dump-event (event stream)
373 (cond ((stringp event)
374 (write-string (escape-non-ascii event) stream))
375 ((null event))
376 (t (format stream "Unexpected event: ~A~%" event))))
377
378 (defun escape-non-ascii (string)
379 "Return a string like STRING but with non-ascii chars escaped."
380 (cond ((ascii-string-p string) string)
381 (t (with-output-to-string (out)
382 (loop for c across string do
383 (cond ((ascii-char-p c) (write-char c out))
384 (t (format out "\\x~4,'0X" (char-code c)))))))))
385
386 (defun ascii-string-p (o)
387 (and (stringp o)
388 (every #'ascii-char-p o)))
389
390 (defun ascii-char-p (c)
391 (<= (char-code c) 127))
392
393 (defun length= (seq n)
394 "Test for whether SEQ contains N number of elements. I.e. it's equivalent
395 to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
396 efficiently implemented."
397 (etypecase seq
398 (list (do ((i n (1- i))
399 (list seq (cdr list)))
400 ((or (<= i 0) (null list))
401 (and (zerop i) (null list)))))
402 (sequence (= (length seq) n))))
403
404 (defun ensure-list (thing)
405 (if (listp thing) thing (list thing)))
406
407 (defun recursively-empty-p (list)
408 "Returns whether LIST consists only of arbitrarily nested empty lists."
409 (cond ((not (listp list)) nil)
410 ((null list) t)
411 (t (every #'recursively-empty-p list))))
412
413 (defun maybecall (bool fn &rest args)
414 "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
415 (if bool (apply fn args) (values-list args)))
416
417 (defun exactly-one-p (&rest values)
418 "If exactly one value in VALUES is non-NIL, this value is returned.
419 Otherwise NIL is returned."
420 (let ((found nil))
421 (dolist (v values)
422 (when v (if found
423 (return-from exactly-one-p nil)
424 (setq found v))))
425 found))
426
427 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
428 "Just like do-symbols, but makes sure a symbol is visited only once."
429 (let ((seen-ht (gensym "SEEN-HT")))
430 `(let ((,seen-ht (make-hash-table :test #'eq)))
431 (do-symbols (,var ,package ,result-form)
432 (unless (gethash ,var ,seen-ht)
433 (setf (gethash ,var ,seen-ht) t)
434 ,@body)))))
435
436
437 ;;;; TCP Server
438
439 (defvar *use-dedicated-output-stream* nil
440 "When T swank will attempt to create a second connection to
441 Emacs which is used just to send output.")
442
443 (defvar *dedicated-output-stream-port* 0
444 "Which port we should use for the dedicated output stream.")
445
446 (defvar *communication-style* (preferred-communication-style))
447
448 (defvar *dont-close* nil
449 "Default value of :dont-close argument to start-server and
450 create-server.")
451
452 (defvar *dedicated-output-stream-buffering*
453 (if (eq *communication-style* :spawn) :full :none)
454 "The buffering scheme that should be used for the output stream.
455 Valid values are :none, :line, and :full.")
456
457 (defvar *coding-system* "iso-latin-1-unix")
458
459 (defun start-server (port-file &key (style *communication-style*)
460 (dont-close *dont-close*)
461 (coding-system *coding-system*))
462 "Start the server and write the listen port number to PORT-FILE.
463 This is the entry point for Emacs."
464 (flet ((start-server-aux ()
465 (setup-server 0 (lambda (port)
466 (announce-server-port port-file port))
467 style dont-close
468 (find-external-format-or-lose coding-system))))
469 (if (eq style :spawn)
470 (initialize-multiprocessing #'start-server-aux)
471 (start-server-aux))))
472
473 (defun create-server (&key (port default-server-port)
474 (style *communication-style*)
475 (dont-close *dont-close*)
476 (coding-system *coding-system*))
477 "Start a SWANK server on PORT running in STYLE.
478 If DONT-CLOSE is true then the listen socket will accept multiple
479 connections, otherwise it will be closed after the first."
480 (setup-server port #'simple-announce-function style dont-close
481 (find-external-format-or-lose coding-system)))
482
483 (defun find-external-format-or-lose (coding-system)
484 (or (find-external-format coding-system)
485 (error "Unsupported coding system: ~s" coding-system)))
486
487 (defparameter *loopback-interface* "127.0.0.1")
488
489 (defun setup-server (port announce-fn style dont-close external-format)
490 (declare (type function announce-fn))
491 (let* ((socket (create-socket *loopback-interface* port))
492 (port (local-port socket)))
493 (funcall announce-fn port)
494 (flet ((serve ()
495 (serve-connection socket style dont-close external-format)))
496 (ecase style
497 (:spawn
498 (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
499 :name "Swank"))
500 ((:fd-handler :sigio)
501 (add-fd-handler socket (lambda () (serve))))
502 ((nil) (loop do (serve) while dont-close)))
503 port)))
504
505 (defun serve-connection (socket style dont-close external-format)
506 (let ((closed-socket-p nil))
507 (unwind-protect
508 (let ((client (accept-authenticated-connection
509 socket :external-format external-format)))
510 (unless dont-close
511 (close-socket socket)
512 (setf closed-socket-p t))
513 (let ((connection (create-connection client style)))
514 (run-hook *new-connection-hook* connection)
515 (push connection *connections*)
516 (serve-requests connection)))
517 (unless (or dont-close closed-socket-p)
518 (close-socket socket)))))
519
520 (defun accept-authenticated-connection (&rest args)
521 (let ((new (apply #'accept-connection args))
522 (success nil))
523 (unwind-protect
524 (let ((secret (slime-secret)))
525 (when secret
526 (set-stream-timeout new 20)
527 (let ((first-val (decode-message new)))
528 (unless (and (stringp first-val) (string= first-val secret))
529 (error "Incoming connection doesn't know the password."))))
530 (set-stream-timeout new nil)
531 (setf success t))
532 (unless success
533 (close new :abort t)))
534 new))
535
536 (defun slime-secret ()
537 "Finds the magic secret from the user's home directory. Returns nil
538 if the file doesn't exist; otherwise the first line of the file."
539 (with-open-file (in
540 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
541 :if-does-not-exist nil)
542 (and in (read-line in nil ""))))
543
544 (defun serve-requests (connection)
545 "Read and process all requests on connections."
546 (funcall (connection.serve-requests connection) connection))
547
548 (defun announce-server-port (file port)
549 (with-open-file (s file
550 :direction :output
551 :if-exists :error
552 :if-does-not-exist :create)
553 (format s "~S~%" port))
554 (simple-announce-function port))
555
556 (defun simple-announce-function (port)
557 (when *swank-debug-p*
558 (format *debug-io* "~&;; Swank started at port: ~D.~%" port)
559 (force-output *debug-io*)))
560
561 (defun open-streams (connection)
562 "Return the 5 streams for IO redirection:
563 DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
564 (multiple-value-bind (output-fn dedicated-output)
565 (make-output-function connection)
566 (let ((input-fn
567 (lambda ()
568 (with-connection (connection)
569 (with-simple-restart (abort-read
570 "Abort reading input from Emacs.")
571 (read-user-input-from-emacs))))))
572 (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
573 (let ((out (or dedicated-output out)))
574 (let ((io (make-two-way-stream in out)))
575 (mapc #'make-stream-interactive (list in out io))
576 (let* ((repl-results-fn
577 (make-output-function-for-target connection :repl-result))
578 (repl-results
579 (nth-value 1 (make-fn-streams
580 (lambda ()
581 (error "Should never be called"))
582 repl-results-fn))))
583 (values dedicated-output in out io repl-results))))))))
584
585 (defun make-output-function (connection)
586 "Create function to send user output to Emacs.
587 This function may open a dedicated socket to send output. It
588 returns two values: the output function, and the dedicated
589 stream (or NIL if none was created)."
590 (if *use-dedicated-output-stream*
591 (let ((stream (open-dedicated-output-stream
592 (connection.socket-io connection))))
593 (values (lambda (string)
594 (write-string string stream)
595 (force-output stream))
596 stream))
597 (values (lambda (string)
598 (with-connection (connection)
599 (with-simple-restart
600 (abort "Abort sending output to Emacs.")
601 (send-to-emacs `(:write-string ,string)))))
602 nil)))
603
604 (defun make-output-function-for-target (connection target)
605 "Create a function to send user output to a specific TARGET in Emacs."
606 (lambda (string)
607 (with-connection (connection)
608 (with-simple-restart
609 (abort "Abort sending output to Emacs.")
610 (send-to-emacs `(:write-string ,string nil ,target))))))
611
612 (defun open-dedicated-output-stream (socket-io)
613 "Open a dedicated output connection to the Emacs on SOCKET-IO.
614 Return an output stream suitable for writing program output.
615
616 This is an optimized way for Lisp to deliver output to Emacs."
617 (let ((socket (create-socket *loopback-interface*
618 *dedicated-output-stream-port*)))
619 (unwind-protect
620 (let ((port (local-port socket)))
621 (encode-message `(:open-dedicated-output-stream ,port) socket-io)
622 (let ((dedicated (accept-authenticated-connection
623 socket
624 :external-format
625 (or (ignore-errors
626 (stream-external-format socket-io))
627 :default)
628 :buffering *dedicated-output-stream-buffering*
629 :timeout 30)))
630 (close-socket socket)
631 (setf socket nil)
632 dedicated))
633 (when socket
634 (close-socket socket)))))
635
636 (defvar *sldb-quit-restart* 'abort
637 "What restart should swank attempt to invoke when the user sldb-quits.")
638
639 (defun handle-request (connection)
640 "Read and process one request. The processing is done in the extent
641 of the toplevel restart."
642 (assert (null *swank-state-stack*))
643 (let ((*swank-state-stack* '(:handle-request)))
644 (with-connection (connection)
645 (with-simple-restart (abort "Return to SLIME's top level.")
646 (let ((*sldb-quit-restart* (find-restart 'abort)))
647 (read-from-emacs))))))
648
649 (defun current-socket-io ()
650 (connection.socket-io *emacs-connection*))
651
652 (defun close-connection (c &optional condition backtrace)
653 (format *debug-io* "~&;; swank:close-connection: ~A~%" condition)
654 (let ((cleanup (connection.cleanup c)))
655 (when cleanup
656 (funcall cleanup c)))
657 (close (connection.socket-io c))
658 (when (connection.dedicated-output c)
659 (close (connection.dedicated-output c)))
660 (setf *connections* (remove c *connections*))
661 (run-hook *connection-closed-hook* c)
662 (when (and condition (not (typep condition 'end-of-file)))
663 (finish-output *debug-io*)
664 (format *debug-io* "~&;; Event history start:~%")
665 (dump-event-history *debug-io*)
666 (format *debug-io* ";; Event history end.~%~
667 ;; Backtrace:~%~{~A~%~}~
668 ;; Connection to Emacs lost. [~%~
669 ;; condition: ~A~%~
670 ;; type: ~S~%~
671 ;; encoding: ~A style: ~S dedicated: ~S]~%"
672 backtrace
673 (escape-non-ascii (safe-condition-message condition) )
674 (type-of condition)
675 (ignore-errors (stream-external-format (connection.socket-io c)))
676 (connection.communication-style c)
677 *use-dedicated-output-stream*)
678 (finish-output *debug-io*)))
679
680 (defvar *debug-on-swank-error* nil
681 "When non-nil internal swank errors will drop to a
682 debugger (not an sldb buffer). Do not set this to T unless you
683 want to debug swank internals.")
684
685 (defmacro with-reader-error-handler ((connection) &body body)
686 (let ((con (gensym))
687 (block (gensym)))
688 `(let ((,con ,connection))
689 (block ,block
690 (handler-bind ((swank-error
691 (lambda (e)
692 (if *debug-on-swank-error*
693 (invoke-debugger e)
694 (return-from ,block
695 (close-connection ,con
696 (swank-error.condition e)
697 (swank-error.backtrace e)))))))
698 (progn ,@body))))))
699
700 (defslimefun simple-break ()
701 (with-simple-restart (continue "Continue from interrupt.")
702 (call-with-debugger-hook
703 #'swank-debugger-hook
704 (lambda ()
705 (invoke-debugger
706 (make-condition 'simple-error
707 :format-control "Interrupt from Emacs")))))
708 nil)
709
710 ;;;;;; Thread based communication
711
712 (defvar *active-threads* '())
713
714 (defun read-loop (control-thread input-stream connection)
715 (with-reader-error-handler (connection)
716 (loop (send control-thread (decode-message input-stream)))))
717
718 (defun dispatch-loop (socket-io connection)
719 (let ((*emacs-connection* connection))
720 (handler-bind ((error (lambda (e)
721 (if *debug-on-swank-error*
722 (invoke-debugger e)
723 (return-from dispatch-loop
724 (close-connection connection e))))))
725 (loop (dispatch-event (receive) socket-io)))))
726
727 (defun repl-thread (connection)
728 (let ((thread (connection.repl-thread connection)))
729 (when (not thread)
730 (log-event "ERROR: repl-thread is nil"))
731 (assert thread)
732 (cond ((thread-alive-p thread)
733 thread)
734 (t
735 (setf (connection.repl-thread connection)
736 (spawn-repl-thread connection "new-repl-thread"))))))
737
738 (defun find-worker-thread (id)
739 (etypecase id
740 ((member t)
741 (car *active-threads*))
742 ((member :repl-thread)
743 (repl-thread *emacs-connection*))
744 (fixnum
745 (find-thread id))))
746
747 (defun interrupt-worker-thread (id)
748 (let ((thread (or (find-worker-thread id)
749 (repl-thread *emacs-connection*))))
750 (interrupt-thread thread #'simple-break)))
751
752 (defun thread-for-evaluation (id)
753 "Find or create a thread to evaluate the next request."
754 (let ((c *emacs-connection*))
755 (etypecase id
756 ((member t)
757 (spawn-worker-thread c))
758 ((member :repl-thread)
759 (repl-thread c))
760 (fixnum
761 (find-thread id)))))
762
763 (defun spawn-worker-thread (connection)
764 (spawn (lambda ()
765 (with-bindings *default-worker-thread-bindings*
766 (handle-request connection)))
767 :name "worker"))
768
769 (defun spawn-repl-thread (connection name)
770 (spawn (lambda ()
771 (with-bindings *default-worker-thread-bindings*
772 (repl-loop connection)))
773 :name name))
774
775 (defun dispatch-event (event socket-io)
776 "Handle an event triggered either by Emacs or within Lisp."
777 (log-event "DISPATCHING: ~S~%" event)
778 (destructure-case event
779 ((:emacs-rex form package thread-id id)
780 (let ((thread (thread-for-evaluation thread-id)))
781 (push thread *active-threads*)
782 (send thread `(eval-for-emacs ,form ,package ,id))))
783 ((:return thread &rest args)
784 (let ((tail (member thread *active-threads*)))
785 (setq *active-threads* (nconc (ldiff *active-threads* tail)
786 (cdr tail))))
787 (encode-message `(:return ,@args) socket-io))
788 ((:emacs-interrupt thread-id)
789 (interrupt-worker-thread thread-id))
790 (((:debug :debug-condition :debug-activate :debug-return)
791 thread &rest args)
792 (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
793 ((:read-string thread &rest args)
794 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
795 ((:y-or-n-p thread &rest args)
796 (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
797 ((:read-aborted thread &rest args)
798 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
799 ((:emacs-return-string thread-id tag string)
800 (send (find-thread thread-id) `(take-input ,tag ,string)))
801 ((:eval thread &rest args)
802 (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
803 ((:emacs-return thread-id tag value)
804 (send (find-thread thread-id) `(take-input ,tag ,value)))
805 (((:write-string :presentation-start :presentation-end
806 :new-package :new-features :ed :%apply :indentation-update
807 :eval-no-wait :background-message :inspect)
808 &rest _)
809 (declare (ignore _))
810 (encode-message event socket-io))))
811
812 (defun spawn-threads-for-connection (connection)
813 (macrolet ((without-debugger-hook (&body body)
814 `(call-with-debugger-hook nil (lambda () ,@body))))
815 (let* ((socket-io (connection.socket-io connection))
816 (control-thread (spawn (lambda ()
817 (without-debugger-hook
818 (dispatch-loop socket-io connection)))
819 :name "control-thread")))
820 (setf (connection.control-thread connection) control-thread)
821 (let ((reader-thread (spawn (lambda ()
822 (let ((go (receive)))
823 (assert (eq go 'accept-input)))
824 (without-debugger-hook
825 (read-loop control-thread socket-io
826 connection)))
827 :name "reader-thread"))
828 (repl-thread (spawn-repl-thread connection "repl-thread")))
829 (setf (connection.repl-thread connection) repl-thread)
830 (setf (connection.reader-thread connection) reader-thread)
831 (send reader-thread 'accept-input)
832 connection))))
833
834 (defun cleanup-connection-threads (connection)
835 (let ((threads (list (connection.repl-thread connection)
836 (connection.reader-thread connection)
837 (connection.control-thread connection))))
838 (dolist (thread threads)
839 (when (and thread
840 (thread-alive-p thread)
841 (not (equal (current-thread) thread)))
842 (kill-thread thread)))))
843
844 (defun repl-loop (connection)
845 (loop (handle-request connection)))
846
847 (defun process-available-input (stream fn)
848 (loop while (input-available-p stream)
849 do (funcall fn)))
850
851 (defun input-available-p (stream)
852 ;; return true iff we can read from STREAM without waiting or if we
853 ;; hit EOF
854 (let ((c (read-char-no-hang stream nil :eof)))
855 (cond ((not c) nil)
856 ((eq c :eof) t)
857 (t
858 (unread-char c stream)
859 t))))
860
861 ;;;;;; Signal driven IO
862
863 (defun install-sigio-handler (connection)
864 (let ((client (connection.socket-io connection)))
865 (flet ((handler ()
866 (cond ((null *swank-state-stack*)
867 (with-reader-error-handler (connection)
868 (process-available-input
869 client (lambda () (handle-request connection)))))
870 ((eq (car *swank-state-stack*) :read-next-form))
871 (t (process-available-input client #'read-from-emacs)))))
872 (add-sigio-handler client #'handler)
873 (handler))))
874
875 (defun deinstall-sigio-handler (connection)
876 (remove-sigio-handlers (connection.socket-io connection)))
877
878 ;;;;;; SERVE-EVENT based IO
879
880 (defun install-fd-handler (connection)
881 (let ((client (connection.socket-io connection)))
882 (flet ((handler ()
883 (cond ((null *swank-state-stack*)
884 (with-reader-error-handler (connection)
885 (process-available-input
886 client (lambda () (handle-request connection)))))
887 ((eq (car *swank-state-stack*) :read-next-form))
888 (t
889 (process-available-input client #'read-from-emacs)))))
890 ;;;; handle sigint
891 ;;(install-debugger-globally
892 ;; (lambda (c h)
893 ;; (with-reader-error-handler (connection)
894 ;; (block debugger
895 ;; (with-connection (connection)
896 ;; (swank-debugger-hook c h)
897 ;; (return-from debugger))
898 ;; (abort)))))
899 (add-fd-handler client #'handler)
900 (handler))))
901
902 (defun deinstall-fd-handler (connection)
903 (remove-fd-handlers (connection.socket-io connection)))
904
905 ;;;;;; Simple sequential IO
906
907 (defun simple-serve-requests (connection)
908 (unwind-protect
909 (with-simple-restart (close-connection "Close SLIME connection")
910 (with-reader-error-handler (connection)
911 (loop
912 (handle-request connection))))
913 (close-connection connection)))
914
915 (defun read-from-socket-io ()
916 (let ((event (decode-message (current-socket-io))))
917 (log-event "DISPATCHING: ~S~%" event)
918 (destructure-case event
919 ((:emacs-rex form package thread id)
920 (declare (ignore thread))
921 `(eval-for-emacs ,form ,package ,id))
922 ((:emacs-interrupt thread)
923 (declare (ignore thread))
924 '(simple-break))
925 ((:emacs-return-string thread tag string)
926 (declare (ignore thread))
927 `(take-input ,tag ,string))
928 ((:emacs-return thread tag value)
929 (declare (ignore thread))
930 `(take-input ,tag ,value)))))
931
932 (defun send-to-socket-io (event)
933 (log-event "DISPATCHING: ~S~%" event)
934 (flet ((send (o)
935 (without-interrupts
936 (encode-message o (current-socket-io)))))
937 (destructure-case event
938 (((:debug-activate :debug :debug-return :read-string :read-aborted
939 :y-or-n-p :eval)
940 thread &rest args)
941 (declare (ignore thread))
942 (send `(,(car event) 0 ,@args)))
943 ((:return thread &rest args)
944 (declare (ignore thread))
945 (send `(:return ,@args)))
946 (((:write-string :new-package :new-features :debug-condition
947 :presentation-start :presentation-end
948 :indentation-update :ed :%apply :eval-no-wait
949 :background-message :inspect)
950 &rest _)
951 (declare (ignore _))
952 (send event)))))
953
954 (defun initialize-streams-for-connection (connection)
955 (multiple-value-bind (dedicated in out io repl-results)
956 (open-streams connection)
957 (setf (connection.dedicated-output connection) dedicated
958 (connection.user-io connection) io
959 (connection.user-output connection) out
960 (connection.user-input connection) in
961 (connection.repl-results connection) repl-results)
962 connection))
963
964 (defun create-connection (socket-io style)
965 (let ((success nil))
966 (unwind-protect
967 (let ((c (ecase style
968 (:spawn
969 (make-connection :socket-io socket-io
970 :read #'read-from-control-thread
971 :send #'send-to-control-thread
972 :serve-requests #'spawn-threads-for-connection
973 :cleanup #'cleanup-connection-threads))
974 (:sigio
975 (make-connection :socket-io socket-io
976 :read #'read-from-socket-io
977 :send #'send-to-socket-io
978 :serve-requests #'install-sigio-handler
979 :cleanup #'deinstall-sigio-handler))
980 (:fd-handler
981 (make-connection :socket-io socket-io
982 :read #'read-from-socket-io
983 :send #'send-to-socket-io
984 :serve-requests #'install-fd-handler
985 :cleanup #'deinstall-fd-handler))
986 ((nil)
987 (make-connection :socket-io socket-io
988 :read #'read-from-socket-io
989 :send #'send-to-socket-io
990 :serve-requests #'simple-serve-requests)))))
991 (setf (connection.communication-style c) style)
992 (initialize-streams-for-connection c)
993 (setf success t)
994 c)
995 (unless success
996 (close socket-io :abort t)))))
997
998
999 ;;;; IO to Emacs
1000 ;;;
1001 ;;; This code handles redirection of the standard I/O streams
1002 ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1003 ;;; contains the appropriate streams, so all we have to do is make the
1004 ;;; right bindings.
1005
1006 ;;;;; Global I/O redirection framework
1007 ;;;
1008 ;;; Optionally, the top-level global bindings of the standard streams
1009 ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1010 ;;; redirect the streams into the connection, and they keep going into
1011 ;;; that connection even if more are established. If the connection
1012 ;;; handling the streams closes then another is chosen, or if there
1013 ;;; are no connections then we revert to the original (real) streams.
1014 ;;;
1015 ;;; It is slightly tricky to assign the global values of standard
1016 ;;; streams because they are often shadowed by dynamic bindings. We
1017 ;;; solve this problem by introducing an extra indirection via synonym
1018 ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1019 ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1020 ;;; variables, so they can always be assigned to affect a global
1021 ;;; change.
1022
1023 (defvar *globally-redirect-io* nil
1024 "When non-nil globally redirect all standard streams to Emacs.")
1025
1026 ;;;;; Global redirection setup
1027
1028 (defvar *saved-global-streams* '()
1029 "A plist to save and restore redirected stream objects.
1030 E.g. the value for '*standard-output* holds the stream object
1031 for *standard-output* before we install our redirection.")
1032
1033 (defun setup-stream-indirection (stream-var &optional stream)
1034 "Setup redirection scaffolding for a global stream variable.
1035 Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1036
1037 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1038
1039 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1040 *STANDARD-INPUT*.
1041
1042 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1043 *CURRENT-STANDARD-INPUT*.
1044
1045 This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1046 effective global value for *STANDARD-INPUT*. This way we can assign
1047 the effective global value even when *STANDARD-INPUT* is shadowed by a
1048 dynamic binding."
1049 (let ((current-stream-var (prefixed-var '#:current stream-var))
1050 (stream (or stream (symbol-value stream-var))))
1051 ;; Save the real stream value for the future.
1052 (setf (getf *saved-global-streams* stream-var) stream)
1053 ;; Define a new variable for the effective stream.
1054 ;; This can be reassigned.
1055 (proclaim `(special ,current-stream-var))
1056 (set current-stream-var stream)
1057 ;; Assign the real binding as a synonym for the current one.
1058 (set stream-var (make-synonym-stream current-stream-var))))
1059
1060 (defun prefixed-var (prefix variable-symbol)
1061 "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1062 (let ((basename (subseq (symbol-name variable-symbol) 1)))
1063 (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1064
1065 (defvar *standard-output-streams*
1066 '(*standard-output* *error-output* *trace-output*)
1067 "The symbols naming standard output streams.")
1068
1069 (defvar *standard-input-streams*
1070 '(*standard-input*)
1071 "The symbols naming standard input streams.")
1072
1073 (defvar *standard-io-streams*
1074 '(*debug-io* *query-io* *terminal-io*)
1075 "The symbols naming standard io streams.")
1076
1077 (defun init-global-stream-redirection ()
1078 (when *globally-redirect-io*
1079 (mapc #'setup-stream-indirection
1080 (append *standard-output-streams*
1081 *standard-input-streams*
1082 *standard-io-streams*))))
1083
1084 (add-hook *after-init-hook* 'init-global-stream-redirection)
1085
1086 (defun globally-redirect-io-to-connection (connection)
1087 "Set the standard I/O streams to redirect to CONNECTION.
1088 Assigns *CURRENT-<STREAM>* for all standard streams."
1089 (dolist (o *standard-output-streams*)
1090 (set (prefixed-var '#:current o)
1091 (connection.user-output connection)))
1092 ;; FIXME: If we redirect standard input to Emacs then we get the
1093 ;; regular Lisp top-level trying to read from our REPL.
1094 ;;
1095 ;; Perhaps the ideal would be for the real top-level to run in a
1096 ;; thread with local bindings for all the standard streams. Failing
1097 ;; that we probably would like to inhibit it from reading while
1098 ;; Emacs is connected.
1099 ;;
1100 ;; Meanwhile we just leave *standard-input* alone.
1101 #+NIL
1102 (dolist (i *standard-input-streams*)
1103 (set (prefixed-var '#:current i)
1104 (connection.user-input connection)))
1105 (dolist (io *standard-io-streams*)
1106 (set (prefixed-var '#:current io)
1107 (connection.user-io connection))))
1108
1109 (defun revert-global-io-redirection ()
1110 "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1111 (dolist (stream-var (append *standard-output-streams*
1112 *standard-input-streams*
1113 *standard-io-streams*))
1114 (set (prefixed-var '#:current stream-var)
1115 (getf *saved-global-streams* stream-var))))
1116
1117 ;;;;; Global redirection hooks
1118
1119 (defvar *global-stdio-connection* nil
1120 "The connection to which standard I/O streams are globally redirected.
1121 NIL if streams are not globally redirected.")
1122
1123 (defun maybe-redirect-global-io (connection)
1124 "Consider globally redirecting to a newly-established CONNECTION."
1125 (when (and *globally-redirect-io* (null *global-stdio-connection*))
1126 (setq *global-stdio-connection* connection)
1127 (globally-redirect-io-to-connection connection)))
1128
1129 (defun update-redirection-after-close (closed-connection)
1130 "Update redirection after a connection closes."
1131 (when (eq *global-stdio-connection* closed-connection)
1132 (if (and (default-connection) *globally-redirect-io*)
1133 ;; Redirect to another connection.
1134 (globally-redirect-io-to-connection (default-connection))
1135 ;; No more connections, revert to the real streams.
1136 (progn (revert-global-io-redirection)
1137 (setq *global-stdio-connection* nil)))))
1138
1139 (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1140 (add-hook *connection-closed-hook* 'update-redirection-after-close)
1141
1142 ;;;;; Redirection during requests
1143 ;;;
1144 ;;; We always redirect the standard streams to Emacs while evaluating
1145 ;;; an RPC. This is done with simple dynamic bindings.
1146
1147 (defun call-with-redirected-io (connection function)
1148 "Call FUNCTION with I/O streams redirected via CONNECTION."
1149 (declare (type function function))
1150 (let* ((io (connection.user-io connection))
1151 (in (connection.user-input connection))
1152 (out (connection.user-output connection))
1153 (*standard-output* out)
1154 (*error-output* out)
1155 (*trace-output* out)
1156 (*debug-io* io)
1157 (*query-io* io)
1158 (*standard-input* in)
1159 (*terminal-io* io))
1160 (funcall function)))
1161
1162 (defun read-from-emacs ()
1163 "Read and process a request from Emacs."
1164 (apply #'funcall (funcall (connection.read *emacs-connection*))))
1165
1166 (defun read-from-control-thread ()
1167 (receive))
1168
1169 (defun decode-message (stream)
1170 "Read an S-expression from STREAM using the SLIME protocol."
1171 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1172 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1173 (let* ((length (decode-message-length stream))
1174 (string (make-string length))
1175 (pos (read-sequence string stream)))
1176 (assert (= pos length) ()
1177 "Short read: length=~D pos=~D" length pos)
1178 (log-event "READ: ~S~%" string)
1179 (read-form string)))))
1180
1181 (defun decode-message-length (stream)
1182 (let ((buffer (make-string 6)))
1183 (dotimes (i 6)
1184 (setf (aref buffer i) (read-char stream)))
1185 (parse-integer buffer :radix #x10)))
1186
1187 (defun read-form (string)
1188 (with-standard-io-syntax
1189 (let ((*package* *swank-io-package*))
1190 (read-from-string string))))
1191
1192 (defvar *slime-features* nil
1193 "The feature list that has been sent to Emacs.")
1194
1195 (defun send-to-emacs (object)
1196 "Send OBJECT to Emacs."
1197 (funcall (connection.send *emacs-connection*) object))
1198
1199 (defun send-oob-to-emacs (object)
1200 (send-to-emacs object))
1201
1202 (defun send-to-control-thread (object)
1203 (send (connection.control-thread *emacs-connection*) object))
1204
1205 (defun encode-message (message stream)
1206 (let* ((string (prin1-to-string-for-emacs message))
1207 (length (length string)))
1208 (log-event "WRITE: ~A~%" string)
1209 (let ((*print-pretty* nil))
1210 (format stream "~6,'0x" length))
1211 (write-string string stream)
1212 ;;(terpri stream)
1213 (finish-output stream)))
1214
1215 (defun prin1-to-string-for-emacs (object)
1216 (with-standard-io-syntax
1217 (let ((*print-case* :downcase)
1218 (*print-readably* nil)
1219 (*print-pretty* nil)
1220 (*package* *swank-io-package*))
1221 (prin1-to-string object))))
1222
1223 (defun force-user-output ()
1224 (force-output (connection.user-io *emacs-connection*))
1225 (finish-output (connection.user-output *emacs-connection*)))
1226
1227 (defun clear-user-input ()
1228 (clear-input (connection.user-input *emacs-connection*)))
1229
1230 (defvar *read-input-catch-tag* 0)
1231
1232 (defun intern-catch-tag (tag)
1233 ;; fixnums aren't eq in ABCL, so we use intern to create tags
1234 (intern (format nil "~D" tag) :swank))
1235
1236 (defun read-user-input-from-emacs ()
1237 (let ((tag (incf *read-input-catch-tag*)))
1238 (force-output)
1239 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1240 (let ((ok nil))
1241 (unwind-protect
1242 (prog1 (catch (intern-catch-tag tag)
1243 (loop (read-from-emacs)))
1244 (setq ok t))
1245 (unless ok
1246 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1247
1248 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1249 "Like y-or-n-p, but ask in the Emacs minibuffer."
1250 (let ((tag (incf *read-input-catch-tag*))
1251 (question (apply #'format nil format-string arguments)))
1252 (force-output)
1253 (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1254 (catch (intern-catch-tag tag)
1255 (loop (read-from-emacs)))))
1256
1257 (defslimefun take-input (tag input)
1258 "Return the string INPUT to the continuation TAG."
1259 (throw (intern-catch-tag tag) input))
1260
1261 (defun process-form-for-emacs (form)
1262 "Returns a string which emacs will read as equivalent to
1263 FORM. FORM can contain lists, strings, characters, symbols and
1264 numbers.
1265
1266 Characters are converted emacs' ?<char> notaion, strings are left
1267 as they are (except for espacing any nested \" chars, numbers are
1268 printed in base 10 and symbols are printed as their symbol-name
1269 converted to lower case."
1270 (etypecase form
1271 (string (format nil "~S" form))
1272 (cons (format nil "(~A . ~A)"
1273 (process-form-for-emacs (car form))
1274 (process-form-for-emacs (cdr form))))
1275 (character (format nil "?~C" form))
1276 (symbol (concatenate 'string (when (eq (symbol-package form)
1277 #.(find-package "KEYWORD"))
1278 ":")
1279 (string-downcase (symbol-name form))))
1280 (number (let ((*print-base* 10))
1281 (princ-to-string form)))))
1282
1283 (defun eval-in-emacs (form &optional nowait)
1284 "Eval FORM in Emacs."
1285 (cond (nowait
1286 (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1287 (t
1288 (force-output)
1289 (let* ((tag (incf *read-input-catch-tag*))
1290 (value (catch (intern-catch-tag tag)
1291 (send-to-emacs
1292 `(:eval ,(current-thread) ,tag
1293 ,(process-form-for-emacs form)))
1294 (loop (read-from-emacs)))))
1295 (destructure-case value
1296 ((:ok value) value)
1297 ((:abort) (abort)))))))
1298
1299 (defun present-in-emacs (value-or-values &key (separated-by " "))
1300 "Present VALUE in the Emacs repl buffer of the current thread."
1301 (unless (consp value-or-values)
1302 (setf value-or-values (list value-or-values)))
1303 (flet ((present (value)
1304 (if (stringp value)
1305 (send-to-emacs `(:write-string ,value))
1306 (let ((id (save-presented-object value)))
1307 (send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
1308 (map nil (let ((first-time-p t))
1309 (lambda (value)
1310 (when (and (not first-time-p)
1311 separated-by)
1312 (present separated-by))
1313 (present value)
1314 (setf first-time-p nil)))
1315 value-or-values))
1316 (values))
1317
1318 (defvar *swank-wire-protocol-version* nil
1319 "The version of the swank/slime communication protocol.")
1320
1321 (defslimefun connection-info ()
1322 "Return a key-value list of the form:
1323 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1324 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1325 STYLE: the communication style
1326 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1327 FEATURES: a list of keywords
1328 PACKAGE: a list (&key NAME PROMPT)
1329 VERSION: the protocol version"
1330 (setq *slime-features* *features*)
1331 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1332 :lisp-implementation (:type ,(lisp-implementation-type)
1333 :name ,(lisp-implementation-type-name)
1334 :version ,(lisp-implementation-version))
1335 :machine (:instance ,(machine-instance)
1336 :type ,(machine-type)
1337 :version ,(machine-version))
1338 :features ,(features-for-emacs)
1339 :package (:name ,(package-name *package*)
1340 :prompt ,(package-string-for-prompt *package*))
1341 :version ,*swank-wire-protocol-version*))
1342
1343 (defslimefun io-speed-test (&optional (n 5000) (m 1))
1344 (let* ((s *standard-output*)
1345 (*trace-output* (make-broadcast-stream s *log-output*)))
1346 (time (progn
1347 (dotimes (i n)
1348 (format s "~D abcdefghijklm~%" i)
1349 (when (zerop (mod n m))
1350 (force-output s)))
1351 (finish-output s)
1352 (when *emacs-connection*
1353 (eval-in-emacs '(message "done.")))))
1354 (terpri *trace-output*)
1355 (finish-output *trace-output*)
1356 nil))
1357
1358
1359 ;;;; Reading and printing
1360
1361 (defmacro define-special (name doc)
1362 "Define a special variable NAME with doc string DOC.
1363 This is like defvar, but NAME will not be initialized."
1364 `(progn
1365 (defvar ,name)
1366 (setf (documentation ',name 'variable) ,doc)))
1367
1368 (define-special *buffer-package*
1369 "Package corresponding to slime-buffer-package.
1370
1371 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1372 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1373
1374 (define-special *buffer-readtable*
1375 "Readtable associated with the current buffer")
1376
1377 (defmacro with-buffer-syntax ((&rest _) &body body)
1378 "Execute BODY with appropriate *package* and *readtable* bindings.
1379
1380 This should be used for code that is conceptionally executed in an
1381 Emacs buffer."
1382 (destructuring-bind () _
1383 `(call-with-buffer-syntax (lambda () ,@body))))
1384
1385 (defun call-with-buffer-syntax (fun)
1386 (let ((*package* *buffer-package*))
1387 ;; Don't shadow *readtable* unnecessarily because that prevents
1388 ;; the user from assigning to it.
1389 (if (eq *readtable* *buffer-readtable*)
1390 (call-with-syntax-hooks fun)
1391 (let ((*readtable* *buffer-readtable*))
1392 (call-with-syntax-hooks fun)))))
1393
1394 (defun to-string (object)
1395 "Write OBJECT in the *BUFFER-PACKAGE*.
1396 The result may not be readable. Handles problems with PRINT-OBJECT methods
1397 gracefully."
1398 (with-buffer-syntax ()
1399 (let ((*print-readably* nil))
1400 (handler-case
1401 (prin1-to-string object)
1402 (error ()
1403 (with-output-to-string (s)
1404 (print-unreadable-object (object s :type t :identity t)
1405 (princ "<<error printing object>>" s))))))))
1406
1407 (defun from-string (string)
1408 "Read string in the *BUFFER-PACKAGE*"
1409 (with-buffer-syntax ()
1410 (let ((*read-suppress* nil))
1411 (read-from-string string))))
1412
1413 ;; FIXME: deal with #\| etc. hard to do portably.
1414 (defun tokenize-symbol (string)
1415 "STRING is interpreted as the string representation of a symbol
1416 and is tokenized accordingly. The result is returned in three
1417 values: The package identifier part, the actual symbol identifier
1418 part, and a flag if the STRING represents a symbol that is
1419 internal to the package identifier part. (Notice that the flag is
1420 also true with an empty package identifier part, as the STRING is
1421 considered to represent a symbol internal to some current package.)"
1422 (let ((package (let ((pos (position #\: string)))
1423 (if pos (subseq string 0 pos) nil)))
1424 (symbol (let ((pos (position #\: string :from-end t)))
1425 (if pos (subseq string (1+ pos)) string)))
1426 (internp (not (= (count #\: string) 1))))
1427 (values symbol package internp)))
1428
1429 (defun tokenize-symbol-thoroughly (string)
1430 "This version of TOKENIZE-SYMBOL handles escape characters."
1431 (let ((package nil)
1432 (token (make-array (length string) :element-type 'character
1433 :fill-pointer 0))
1434 (backslash nil)
1435 (vertical nil)
1436 (internp nil))
1437 (loop for char across string
1438 do (cond
1439 (backslash
1440 (vector-push-extend char token)
1441 (setq backslash nil))
1442 ((char= char #\\) ; Quotes next character, even within |...|
1443 (setq backslash t))
1444 ((char= char #\|)
1445 (setq vertical t))
1446 (vertical
1447 (vector-push-extend char token))
1448 ((char= char #\:)
1449 (if package
1450 (setq internp t)
1451 (setq package token
1452 token (make-array (length string)
1453 :element-type 'character
1454 :fill-pointer 0))))
1455 (t
1456 (vector-push-extend (casify-char char) token))))
1457 (values token package (or (not package) internp))))
1458
1459 (defun untokenize-symbol (package-name internal-p symbol-name)
1460 "The inverse of TOKENIZE-SYMBOL.
1461
1462 (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1463 (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1464 (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1465 "
1466 (let ((prefix (cond ((not package-name) "")
1467 (internal-p (format nil "~A::" package-name))
1468 (t (format nil "~A:" package-name)))))
1469 (concatenate 'string prefix symbol-name)))
1470
1471 (defun casify-char (char)
1472 "Convert CHAR accoring to readtable-case."
1473 (ecase (readtable-case *readtable*)
1474 (:preserve char)
1475 (:upcase (char-upcase char))
1476 (:downcase (char-downcase char))
1477 (:invert (if (upper-case-p char)
1478 (char-downcase char)
1479 (char-upcase char)))))
1480
1481 (defun parse-symbol (string &optional (package *package*))
1482 "Find the symbol named STRING.
1483 Return the symbol and a flag indicating whether the symbols was found."
1484 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1485 (let ((package (cond ((string= pname "") keyword-package)
1486 (pname (find-package pname))
1487 (t package))))
1488 (if package
1489 (find-symbol sname package)
1490 (values nil nil)))))
1491
1492 (defun parse-symbol-or-lose (string &optional (package *package*))
1493 (multiple-value-bind (symbol status) (parse-symbol string package)
1494 (if status
1495 (values symbol status)
1496 (error "Unknown symbol: ~A [in ~A]" string package))))
1497
1498 ;; FIXME: interns the name
1499 (defun parse-package (string)
1500 "Find the package named STRING.
1501 Return the package or nil."
1502 (multiple-value-bind (name pos)
1503 (if (zerop (length string))
1504 (values :|| 0)
1505 (let ((*package* *swank-io-package*))
1506 (ignore-errors (read-from-string string))))
1507 (and name
1508 (or (symbolp name)
1509 (stringp name))
1510 (= (length string) pos)
1511 (find-package name))))
1512
1513 (defun unparse-name (string)
1514 "Print the name STRING according to the current printer settings."
1515 ;; this is intended for package or symbol names
1516 (subseq (prin1-to-string (make-symbol string)) 2))
1517
1518 (defun guess-package (string)
1519 "Guess which package corresponds to STRING.
1520 Return nil if no package matches."
1521 (or (find-package string)
1522 (parse-package string)
1523 (if (find #\! string) ; for SBCL
1524 (guess-package (substitute #\- #\! string)))))
1525
1526 (defvar *readtable-alist* (default-readtable-alist)
1527 "An alist mapping package names to readtables.")
1528
1529 (defun guess-buffer-readtable (package-name)
1530 (let ((package (guess-package package-name)))
1531 (or (and package
1532 (cdr (assoc (package-name package) *readtable-alist*
1533 :test #'string=)))
1534 *readtable*)))
1535
1536 (defun valid-operator-symbol-p (symbol)
1537 "Is SYMBOL the name of a function, a macro, or a special-operator?"
1538 (or (fboundp symbol)
1539 (macro-function symbol)
1540 (special-operator-p symbol)))
1541
1542 (defun valid-operator-name-p (string)
1543 "Is STRING the name of a function, macro, or special-operator?"
1544 (let ((symbol (parse-symbol string)))
1545 (valid-operator-symbol-p symbol)))
1546
1547
1548 ;;;; Arglists
1549
1550 (defslimefun arglist-for-echo-area (raw-specs &key arg-indices
1551 print-right-margin print-lines)
1552 "Return the arglist for the first valid ``form spec'' in
1553 RAW-SPECS. A ``form spec'' is a superset of functions, macros,
1554 special-ops, declarations and type specifiers.
1555
1556 For more information about the format of ``raw form specs'' and
1557 ``form specs'', please see PARSE-FORM-SPEC."
1558 (handler-case
1559 (with-buffer-syntax ()
1560 (multiple-value-bind (form-spec arg-index)
1561 (parse-first-valid-form-spec raw-specs arg-indices)
1562 (when form-spec
1563 (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
1564 (unless (eql arglist :not-available)
1565 (multiple-value-bind (type operator arguments)
1566 (split-form-spec form-spec)
1567 (declare (ignore arguments))
1568 (multiple-value-bind (stringified-arglist)
1569 (decoded-arglist-to-string
1570 arglist
1571 :operator operator
1572 :print-right-margin print-right-margin
1573 :print-lines print-lines
1574 :highlight (and arg-index
1575 (not (zerop arg-index))
1576 ;; don't highlight the operator
1577 arg-index))
1578 (case type
1579 (:declaration (format nil "(declare ~A)" stringified-arglist))
1580 (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
1581 (t stringified-arglist)))))))))
1582 (error (cond)
1583 (format nil "ARGLIST (error): ~A" cond))
1584 ))
1585
1586 (defun parse-form-spec (raw-spec)
1587 "Takes a raw (i.e. unparsed) form spec from SLIME and returns a
1588 proper form spec for further processing within SWANK. Returns NIL
1589 if RAW-SPEC could not be parsed.
1590
1591 A ``raw form spec'' can be either:
1592
1593 i) a string representing a Common Lisp symbol,
1594
1595 ii) a string representing a Common Lisp form,
1596
1597 iii) a list:
1598
1599 a) (:declaration declspec)
1600
1601 where DECLSPEC is the string representation of a /declaration specifier/,
1602
1603 b) (:type-specifier typespec)
1604
1605 where TYPESPEC is the string representation of a /type specifier/.
1606
1607
1608 A ``form spec'' is either
1609
1610 1) a normal Common Lisp form
1611
1612 2) a Common Lisp form with a list as its CAR specifying what namespace
1613 the operator is supposed to be interpreted in:
1614
1615 a) ((:declaration decl-identifier) declarg1 declarg2 ...)
1616
1617 b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...)
1618
1619
1620 Examples:
1621
1622 \"defmethod\" => (defmethod)
1623 \"cl:defmethod\" => (cl:defmethod)
1624 \"(defmethod print-object)\" => (defmethod print-object)
1625 (:declaration \"(optimize)\") => ((:declaration optimize))
1626 (:declaration \"(type string)\") => ((:declaration type) string)
1627 (:type-specifier \"(float)\") => ((:type-specifier float))
1628 (:type-specifier \"(float 0 100)\") => ((:type-specifier float) 0 100)
1629 "
1630 (typecase raw-spec
1631 (string (ensure-list (read-incomplete-form-from-string raw-spec)))
1632 (cons ; compound form spec
1633 (destructure-case raw-spec
1634 ((:declaration raw-declspec)
1635 (let ((declspec (from-string raw-declspec)))
1636 (unless (recursively-empty-p declspec) ; (:DECLARATION "(())") &c.
1637 (destructuring-bind (decl-identifier &rest decl-args) declspec
1638 `((:declaration ,decl-identifier) ,@decl-args)))))
1639 ((:type-specifier raw-typespec)
1640 (let ((typespec (from-string raw-typespec)))
1641 (unless (recursively-empty-p typespec)
1642 (destructuring-bind (typespec-op &rest typespec-args) typespec
1643 `((:type-specifier ,typespec-op) ,@typespec-args)))))))
1644 (otherwise nil)))
1645
1646 (defun split-form-spec (spec)
1647 "Returns all three relevant information a ``form spec''
1648 contains: the operator type, the operator, and the operands."
1649 (destructuring-bind (operator-designator &rest arguments) spec
1650 (multiple-value-bind (type operator)
1651 (if (listp operator-designator)
1652 (values (first operator-designator) (second operator-designator))
1653 (values :function operator-designator)) ; functions, macros, special ops
1654 (values type operator arguments)))) ; are all fbound.
1655
1656 (defun parse-first-valid-form-spec (raw-specs &optional arg-indices)
1657 "Returns the first parsed form spec in RAW-SPECS that can
1658 successfully be parsed. Additionally returns its respective index
1659 in ARG-INDICES (or NIL.)"
1660 (block traversal
1661 (mapc #'(lambda (raw-spec index)
1662 (let ((spec (parse-form-spec raw-spec)))
1663 (when spec (return-from traversal
1664 (values spec index)))))
1665 raw-specs
1666 (append arg-indices '#1=(nil . #1#)))))
1667
1668
1669 (defun clean-arglist (arglist)
1670 "Remove &whole, &enviroment, and &aux elements from ARGLIST."
1671 (cond ((null arglist) '())
1672 ((member (car arglist) '(&whole &environment))
1673 (clean-arglist (cddr arglist)))
1674 ((eq (car arglist) '&aux)
1675 '())
1676 (t (cons (car arglist) (clean-arglist (cdr arglist))))))
1677
1678
1679 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
1680 provided-args ; list of the provided actual arguments
1681 required-args ; list of the required arguments
1682 optional-args ; list of the optional arguments
1683 key-p ; whether &key appeared
1684 keyword-args ; list of the keywords
1685 rest ; name of the &rest or &body argument (if any)
1686 body-p ; whether the rest argument is a &body
1687 allow-other-keys-p ; whether &allow-other-keys appeared
1688 aux-args ; list of &aux variables
1689 any-p ; whether &any appeared
1690 any-args ; list of &any arguments [*]
1691 known-junk ; &whole, &environment
1692 unknown-junk) ; unparsed stuff
1693
1694 ;;;
1695 ;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
1696 ;;; and is only used to describe certain arglists that cannot be
1697 ;;; described in another way.
1698 ;;;
1699 ;;; &ANY is very similiar to &KEY but while &KEY is based upon
1700 ;;; the idea of a plist (key1 value1 key2 value2), &ANY is a
1701 ;;; cross between &OPTIONAL, &KEY and *FEATURES* lists:
1702 ;;;
1703 ;;; a) (&ANY :A :B :C) means that you can provide any (non-null)
1704 ;;; set consisting of the keywords `:A', `:B', or `:C' in
1705 ;;; the arglist. E.g. (:A) or (:C :B :A).
1706 ;;;
1707 ;;; (This is not restricted to keywords only, but any self-evaluating
1708 ;;; expression is allowed.)
1709 ;;;
1710 ;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can
1711 ;;; provide any (non-null) set consisting of lists where
1712 ;;; the CAR of the list is one of `key1', `key2', or `key3'.
1713 ;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23))
1714 ;;;
1715 ;;;
1716 ;;; For example, a) let us describe the situations of EVAL-WHEN as
1717 ;;;
1718 ;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
1719 ;;;
1720 ;;; and b) let us describe the optimization qualifiers that are valid
1721 ;;; in the declaration specifier `OPTIMIZE':
1722 ;;;
1723 ;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
1724 ;;;
1725
1726 (defun print-arglist (arglist &key operator highlight)
1727 (let ((index 0)
1728 (need-space nil))
1729 (labels ((print-arg (arg)
1730 (typecase arg
1731 (arglist ; destructuring pattern
1732 (print-arglist arg))
1733 (optional-arg
1734 (princ (encode-optional-arg arg)))
1735 (keyword-arg
1736 (let ((enc-arg (encode-keyword-arg arg)))
1737 (etypecase enc-arg
1738 (symbol (princ enc-arg))
1739 ((cons symbol)
1740 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1741 (princ (car enc-arg))
1742 (write-char #\space)
1743 (pprint-fill *standard-output* (cdr enc-arg) nil)))
1744 ((cons cons)
1745 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1746 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1747 (prin1 (caar enc-arg))
1748 (write-char #\space)
1749 (print-arg (keyword-arg.arg-name arg)))
1750 (unless (null (cdr enc-arg))
1751 (write-char #\space))
1752 (pprint-fill *standard-output* (cdr enc-arg) nil))))))
1753 (t ; required formal or provided actual arg
1754 (princ arg))))
1755 (print-space ()
1756 (ecase need-space
1757 ((nil))
1758 ((:miser)
1759 (write-char #\space)
1760 (pprint-newline :miser))
1761 ((t)
1762 (write-char #\space)
1763 (pprint-newline :fill)))
1764 (setq need-space t))
1765 (print-with-space (obj)
1766 (print-space)
1767 (print-arg obj))
1768 (print-with-highlight (arg &optional (index-ok-p #'=))
1769 (print-space)
1770 (cond
1771 ((and highlight (funcall index-ok-p index highlight))
1772 (princ "===> ")
1773 (print-arg arg)
1774 (princ " <==="))
1775 (t
1776 (print-arg arg)))
1777 (incf index)))
1778 (pprint-logical-block (nil nil :prefix "(" :suffix ")")
1779 (when operator
1780 (print-with-highlight operator)
1781 (setq need-space :miser))
1782 (mapc #'print-with-highlight
1783 (arglist.provided-args arglist))
1784 (mapc #'print-with-highlight
1785 (arglist.required-args arglist))
1786 (when (arglist.optional-args arglist)
1787 (print-with-space '&optional)
1788 (mapc #'print-with-highlight
1789 (arglist.optional-args arglist)))
1790 (when (arglist.key-p arglist)
1791 (print-with-space '&key)
1792 (mapc #'print-with-space
1793 (arglist.keyword-args arglist)))
1794 (when (arglist.allow-other-keys-p arglist)
1795 (print-with-space '&allow-other-keys))
1796 (when (arglist.any-args arglist)
1797 (print-with-space '&any)
1798 (mapc #'print-with-space
1799 (arglist.any-args arglist)))
1800 (cond ((not (arglist.rest arglist)))
1801 ((arglist.body-p arglist)
1802 (print-with-space '&body)
1803 (print-with-highlight (arglist.rest arglist) #'<=))
1804 (t
1805 (print-with-space '&rest)
1806 (print-with-highlight (arglist.rest arglist) #'<=)))
1807 (mapc #'print-with-space
1808 (arglist.unknown-junk arglist))))))
1809
1810 (defun decoded-arglist-to-string (arglist
1811 &key operator highlight (package *package*)
1812 print-right-margin print-lines)
1813 "Print the decoded ARGLIST for display in the echo area. The
1814 argument name are printed without package qualifiers and pretty
1815 printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
1816 non-nil, it must be the index of an argument; highlight this argument.
1817 If OPERATOR is non-nil, put it in front of the arglist."
1818 (with-output-to-string (*standard-output*)
1819 (with-standard-io-syntax
1820 (let ((*package* package) (*print-case* :downcase)
1821 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
1822 (*print-level* 10) (*print-length* 20)
1823 (*print-right-margin* print-right-margin)
1824 (*print-lines* print-lines)
1825 (*print-escape* nil)) ; no package qualifies.
1826 (print-arglist arglist :operator operator :highlight highlight)))))
1827
1828 (defslimefun variable-desc-for-echo-area (variable-name)
1829 "Return a short description of VARIABLE-NAME, or NIL."
1830 (with-buffer-syntax ()
1831 (let ((sym (parse-symbol variable-name)))
1832 (if (and sym (boundp sym))
1833 (let ((*print-pretty* nil) (*print-level* 4)
1834 (*print-length* 10) (*print-circle* t))
1835 (format nil "~A => ~A" sym (symbol-value sym)))))))
1836
1837 (defun decode-required-arg (arg)
1838 "ARG can be a symbol or a destructuring pattern."
1839 (etypecase arg
1840 (symbol arg)
1841 (list (decode-arglist arg))))
1842
1843 (defun encode-required-arg (arg)
1844 (etypecase arg
1845 (symbol arg)
1846 (arglist (encode-arglist arg))))
1847
1848 (defstruct (keyword-arg
1849 (:conc-name keyword-arg.)
1850 (:constructor make-keyword-arg (keyword arg-name default-arg)))
1851 keyword
1852 arg-name
1853 default-arg)
1854
1855 (defun decode-keyword-arg (arg)
1856 "Decode a keyword item of formal argument list.
1857 Return three values: keyword, argument name, default arg."
1858 (cond ((symbolp arg)
1859 (make-keyword-arg (intern (symbol-name arg) keyword-package)
1860 arg
1861 nil))
1862 ((and (consp arg)
1863 (consp (car arg)))
1864 (make-keyword-arg (caar arg)
1865 (decode-required-arg (cadar arg))
1866 (cadr arg)))
1867 ((consp arg)
1868 (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
1869 (car arg)
1870 (cadr arg)))
1871 (t
1872 (abort-request "Bad keyword item of formal argument list"))))
1873
1874 (defun encode-keyword-arg (arg)
1875 (cond
1876 ((arglist-p (keyword-arg.arg-name arg))
1877 ;; Destructuring pattern
1878 (let ((keyword/name (list (keyword-arg.keyword arg)
1879 (encode-required-arg
1880 (keyword-arg.arg-name arg)))))
1881 (if (keyword-arg.default-arg arg)
1882 (list keyword/name
1883 (keyword-arg.default-arg arg))
1884 (list keyword/name))))
1885 ((eql (intern (symbol-name (keyword-arg.arg-name arg))
1886 keyword-package)
1887 (keyword-arg.keyword arg))
1888 (if (keyword-arg.default-arg arg)
1889 (list (keyword-arg.arg-name arg)
1890 (keyword-arg.default-arg arg))
1891 (keyword-arg.arg-name arg)))
1892 (t
1893 (let ((keyword/name (list (keyword-arg.keyword arg)
1894 (keyword-arg.arg-name arg))))
1895 (if (keyword-arg.default-arg arg)
1896 (list keyword/name
1897 (keyword-arg.default-arg arg))
1898 (list keyword/name))))))
1899
1900 (progn
1901 (assert (equalp (decode-keyword-arg 'x)
1902 (make-keyword-arg :x 'x nil)))
1903 (assert (equalp (decode-keyword-arg '(x t))
1904 (make-keyword-arg :x 'x t)))
1905 (assert (equalp (decode-keyword-arg '((:x y)))
1906 (make-keyword-arg :x 'y nil)))
1907 (assert (equalp (decode-keyword-arg '((:x y) t))
1908 (make-keyword-arg :x 'y t))))
1909
1910 (defstruct (optional-arg
1911 (:conc-name optional-arg.)
1912 (:constructor make-optional-arg (arg-name default-arg)))
1913 arg-name
1914 default-arg)
1915
1916 (defun decode-optional-arg (arg)
1917 "Decode an optional item of a formal argument list.
1918 Return an OPTIONAL-ARG structure."
1919 (etypecase arg
1920 (symbol (make-optional-arg arg nil))
1921 (list (make-optional-arg (decode-required-arg (car arg))
1922 (cadr arg)))))
1923
1924 (defun encode-optional-arg (optional-arg)
1925 (if (or (optional-arg.default-arg optional-arg)
1926 (arglist-p (optional-arg.arg-name optional-arg)))
1927 (list (encode-required-arg
1928 (optional-arg.arg-name optional-arg))
1929 (optional-arg.default-arg optional-arg))
1930 (optional-arg.arg-name optional-arg)))
1931
1932 (progn
1933 (assert (equalp (decode-optional-arg 'x)
1934 (make-optional-arg 'x nil)))
1935 (assert (equalp (decode-optional-arg '(x t))
1936 (make-optional-arg 'x t))))
1937
1938 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
1939
1940 (defun decode-arglist (arglist)
1941 "Parse the list ARGLIST and return an ARGLIST structure."
1942 (let ((mode nil)
1943 (result (make-arglist)))
1944 (dolist (arg arglist)
1945 (cond
1946 ((eql mode '&unknown-junk)
1947 ;; don't leave this mode -- we don't know how the arglist
1948 ;; after unknown lambda-list keywords is interpreted
1949 (push arg (arglist.unknown-junk result)))
1950 ((eql arg '&allow-other-keys)
1951 (setf (arglist.allow-other-keys-p result) t))
1952 ((eql arg '&key)
1953 (setf (arglist.key-p result) t
1954 mode arg))
1955 ((member arg '(&optional &rest &body &aux))
1956 (setq mode arg))
1957 ((member arg '(&whole &environment))
1958 (setq mode arg)
1959 (push arg (arglist.known-junk result)))
1960 ((and (symbolp arg)
1961 (string= (symbol-name arg) (string '#:&ANY))) ; may be interned
1962 (setf (arglist.any-p result) t) ; in any *package*.
1963 (setq mode '&any))
1964 ((member arg lambda-list-keywords)
1965 (setq mode '&unknown-junk)
1966 (push arg (arglist.unknown-junk result)))
1967 (t
1968 (ecase mode
1969 (&key
1970 (push (decode-keyword-arg arg)
1971 (arglist.keyword-args result)))
1972 (&optional
1973 (push (decode-optional-arg arg)
1974 (arglist.optional-args result)))
1975 (&body
1976 (setf (arglist.body-p result) t
1977 (arglist.rest result) arg))
1978 (&rest
1979 (setf (arglist.rest result) arg))
1980 (&aux
1981 (push (decode-optional-arg arg)
1982 (arglist.aux-args result)))
1983 ((nil)
1984 (push (decode-required-arg arg)
1985 (arglist.required-args result)))
1986 ((&whole &environment)
1987 (setf mode nil)
1988 (push arg (arglist.known-junk result)))
1989 (&any
1990 (push arg (arglist.any-args result)))))))
1991 (nreversef (arglist.required-args result))
1992 (nreversef (arglist.optional-args result))
1993 (nreversef (arglist.keyword-args result))
1994 (nreversef (arglist.aux-args result))
1995 (nreversef (arglist.any-args result))
1996 (nreversef (arglist.known-junk result))
1997 (nreversef (arglist.unknown-junk result))
1998 (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result)))
1999 (exactly-one-p (arglist.key-p result) (arglist.any-p result))))
2000 result))
2001
2002 (defun encode-arglist (decoded-arglist)
2003 (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
2004 (when (arglist.optional-args decoded-arglist)
2005 '(&optional))
2006 (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
2007 (when (arglist.key-p decoded-arglist)
2008 '(&key))
2009 (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
2010 (when (arglist.allow-other-keys-p decoded-arglist)
2011 '(&allow-other-keys))
2012 (when (arglist.any-args decoded-arglist)
2013 `(&any ,@(arglist.any-args decoded-arglist)))
2014 (cond ((not (arglist.rest decoded-arglist))
2015 '())
2016 ((arglist.body-p decoded-arglist)
2017 `(&body ,(arglist.rest decoded-arglist)))
2018 (t
2019 `(&rest ,(arglist.rest decoded-arglist))))
2020 (when (arglist.aux-args decoded-arglist)
2021 `(&aux ,(arglist.aux-args decoded-arglist)))
2022 (arglist.known-junk decoded-arglist)
2023 (arglist.unknown-junk decoded-arglist)))
2024
2025 (defun arglist-keywords (arglist)
2026 "Return the list of keywords in ARGLIST.
2027 As a secondary value, return whether &allow-other-keys appears."
2028 (let ((decoded-arglist (decode-arglist arglist)))
2029 (values (arglist.keyword-args decoded-arglist)
2030 (arglist.allow-other-keys-p decoded-arglist))))
2031
2032 (defun methods-keywords (methods)
2033 "Collect all keywords in the arglists of METHODS.
2034 As a secondary value, return whether &allow-other-keys appears somewhere."
2035 (let ((keywords '())
2036 (allow-other-keys nil))
2037 (dolist (method methods)
2038 (multiple-value-bind (kw aok)
2039 (arglist-keywords
2040 (swank-mop:method-lambda-list method))
2041 (setq keywords (remove-duplicates (append keywords kw)
2042 :key #'keyword-arg.keyword)
2043 allow-other-keys (or allow-other-keys aok))))
2044 (values keywords allow-other-keys)))
2045
2046 (defun generic-function-keywords (generic-function)
2047 "Collect all keywords in the methods of GENERIC-FUNCTION.
2048 As a secondary value, return whether &allow-other-keys appears somewhere."
2049 (methods-keywords
2050 (swank-mop:generic-function-methods generic-function)))
2051
2052 (defun applicable-methods-keywords (generic-function arguments)
2053 "Collect all keywords in the methods of GENERIC-FUNCTION that are
2054 applicable for argument of CLASSES. As a secondary value, return
2055 whether &allow-other-keys appears somewhere."
2056 (methods-keywords
2057 (multiple-value-bind (amuc okp)
2058 (swank-mop:compute-applicable-methods-using-classes
2059 generic-function (mapcar #'class-of arguments))
2060 (if okp
2061 amuc
2062 (compute-applicable-methods generic-function arguments)))))
2063
2064 (defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
2065 (with-output-to-string (*standard-output*)
2066 (with-standard-io-syntax
2067 (let ((*package* package) (*print-case* :downcase)
2068 (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
2069 (*print-level* 10) (*print-length* 20))
2070 (print-decoded-arglist-as-template decoded-arglist
2071 :prefix prefix
2072 :suffix suffix)))))
2073
2074 (defun print-decoded-arglist-as-template (decoded-arglist &key
2075 (prefix "(") (suffix ")"))
2076 (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
2077 (let ((first-p t))
2078 (flet ((space ()
2079 (unless first-p
2080 (write-char #\space)
2081 (pprint-newline :fill))
2082 (setq first-p nil))
2083 (print-arg-or-pattern (arg)
2084 (etypecase arg
2085 (symbol (princ arg))
2086 (string (princ arg))
2087 (list (princ arg))
2088 (arglist (print-decoded-arglist-as-template arg)))))
2089 (dolist (arg (arglist.required-args decoded-arglist))
2090 (space)
2091 (print-arg-or-pattern arg))
2092 (dolist (arg (arglist.optional-args decoded-arglist))
2093 (space)
2094 (princ "[")
2095 (print-arg-or-pattern (optional-arg.arg-name arg))
2096 (princ "]"))
2097 (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
2098 (space)
2099 (let ((arg-name (keyword-arg.arg-name keyword-arg))
2100 (keyword (keyword-arg.keyword keyword-arg)))
2101 (format t "~W "
2102 (if (keywordp keyword) keyword `',keyword))
2103 (print-arg-or-pattern arg-name)))
2104 (dolist (any-arg (arglist.any-args decoded-arglist))
2105 (space)
2106 (print-arg-or-pattern any-arg))
2107 (when (and (arglist.rest decoded-arglist)
2108 (or (not (arglist.keyword-args decoded-arglist))
2109 (arglist.allow-other-keys-p decoded-arglist)))
2110 (if (arglist.body-p decoded-arglist)
2111 (pprint-newline :mandatory)
2112 (space))
2113 (format t "~A..." (arglist.rest decoded-arglist)))))
2114 (pprint-newline :fill)))
2115
2116
2117 (defgeneric extra-keywords (operator &rest args)
2118 (:documentation "Return a list of extra keywords of OPERATOR (a
2119 symbol) when applied to the (unevaluated) ARGS.
2120 As a secondary value, return whether other keys are allowed.
2121 As a tertiary value, return the initial sublist of ARGS that was needed
2122 to determine the extra keywords."))
2123
2124 (defun keywords-of-operator (operator)
2125 "Return a list of KEYWORD-ARGs that OPERATOR accepts.
2126 This function is useful for writing EXTRA-KEYWORDS methods for
2127 user-defined functions which are declared &ALLOW-OTHER-KEYS and which
2128 forward keywords to OPERATOR."
2129 (let ((arglist (arglist-from-form-spec (ensure-list operator)
2130 :remove-args nil)))
2131 (unless (eql arglist :not-available)
2132 (values
2133 (arglist.keyword-args arglist)
2134 (arglist.allow-other-keys-p arglist)))))
2135
2136 (defmethod extra-keywords (operator &rest args)
2137 ;; default method
2138 (declare (ignore args))
2139 (let ((symbol-function (symbol-function operator)))
2140 (if (typep symbol-function 'generic-function)
2141 (generic-function-keywords symbol-function)
2142 nil)))
2143
2144 (defun class-from-class-name-form (class-name-form)
2145 (when (and (listp class-name-form)
2146 (= (length class-name-form) 2)
2147 (eq (car class-name-form) 'quote))
2148 (let* ((class-name (cadr class-name-form))
2149 (class (find-class class-name nil)))
2150 (when (and class
2151 (not (swank-mop:class-finalized-p class)))
2152 ;; Try to finalize the class, which can fail if
2153 ;; superclasses are not defined yet
2154 (handler-case (swank-mop:finalize-inheritance class)
2155 (program-error (c)
2156 (declare (ignore c)))))
2157 class)))
2158
2159 (defun extra-keywords/slots (class)
2160 (multiple-value-bind (slots allow-other-keys-p)
2161 (if (swank-mop:class-finalized-p class)
2162 (values (swank-mop:class-slots class) nil)
2163 (values (swank-mop:class-direct-slots class) t))
2164 (let ((slot-init-keywords
2165 (loop for slot in slots append
2166 (mapcar (lambda (initarg)
2167 (make-keyword-arg
2168 initarg
2169 (swank-mop:slot-definition-name slot)
2170 (swank-mop:slot-definition-initform slot)))
2171 (swank-mop:slot-definition-initargs slot)))))
2172 (values slot-init-keywords allow-other-keys-p))))
2173
2174 (defun extra-keywords/make-instance (operator &rest args)
2175 (declare (ignore operator))
2176 (unless (null args)
2177 (let* ((class-name-form (car args))
2178 (class (class-from-class-name-form class-name-form)))
2179 (when class
2180 (multiple-value-bind (slot-init-keywords class-aokp)
2181 (extra-keywords/slots class)
2182 (multiple-value-bind (allocate-instance-keywords ai-aokp)
2183 (applicable-methods-keywords
2184 #'allocate-instance (list class))
2185 (multiple-value-bind (initialize-instance-keywords ii-aokp)
2186 (applicable-methods-keywords
2187 #'initialize-instance (list (swank-mop:class-prototype class)))
2188 (multiple-value-bind (shared-initialize-keywords si-aokp)
2189 (applicable-methods-keywords
2190 #'shared-initialize (list (swank-mop:class-prototype class) t))
2191 (values (append slot-init-keywords
2192 allocate-instance-keywords
2193 initialize-instance-keywords
2194 shared-initialize-keywords)
2195 (or class-aokp ai-aokp ii-aokp si-aokp)
2196 (list class-name-form))))))))))
2197
2198 (defun extra-keywords/change-class (operator &rest args)
2199 (declare (ignore operator))
2200 (unless (null args)
2201 (let* ((class-name-form (car args))
2202 (class (class-from-class-name-form class-name-form)))
2203 (when class
2204 (multiple-value-bind (slot-init-keywords class-aokp)
2205 (extra-keywords/slots class)
2206 (declare (ignore class-aokp))
2207 (multiple-value-bind (shared-initialize-keywords si-aokp)
2208 (applicable-methods-keywords
2209 #'shared-initialize (list (swank-mop:class-prototype class) t))
2210 ;; FIXME: much as it would be nice to include the
2211 ;; applicable keywords from
2212 ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
2213 ;; how to do it: so we punt, always declaring
2214 ;; &ALLOW-OTHER-KEYS.
2215 (declare (ignore si-aokp))
2216 (values (append slot-init-keywords shared-initialize-keywords)
2217 t
2218 (list class-name-form))))))))
2219
2220 (defmacro multiple-value-or (&rest forms)
2221 (if (null forms)
2222 nil
2223 (let ((first (first forms))
2224 (rest (rest forms)))
2225 `(let* ((values (multiple-value-list ,first))
2226 (primary-value (first values)))
2227 (if primary-value
2228 (values-list values)
2229 (multiple-value-or ,@rest))))))
2230
2231 (defmethod extra-keywords ((operator (eql 'make-instance))
2232 &rest args)
2233 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2234 (call-next-method)))
2235
2236 (defmethod extra-keywords ((operator (eql 'make-condition))
2237 &rest args)
2238 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2239 (call-next-method)))
2240
2241 (defmethod extra-keywords ((operator (eql 'error))
2242 &rest args)
2243 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2244 (call-next-method)))
2245
2246 (defmethod extra-keywords ((operator (eql 'signal))
2247 &rest args)
2248 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2249 (call-next-method)))
2250
2251 (defmethod extra-keywords ((operator (eql 'warn))
2252 &rest args)
2253 (multiple-value-or (apply #'extra-keywords/make-instance operator args)
2254 (call-next-method)))
2255
2256 (defmethod extra-keywords ((operator (eql 'cerror))
2257 &rest args)
2258 (multiple-value-bind (keywords aok determiners)
2259 (apply #'extra-keywords/make-instance operator
2260 (cdr args))
2261 (if keywords
2262 (values keywords aok
2263 (cons (car args) determiners))
2264 (call-next-method))))
2265
2266 (defmethod extra-keywords ((operator (eql 'change-class))
2267 &rest args)
2268 (multiple-value-bind (keywords aok determiners)
2269 (apply #'extra-keywords/change-class operator (cdr args))
2270 (if keywords
2271 (values keywords aok
2272 (cons (car args) determiners))
2273 (call-next-method))))
2274
2275 (defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
2276 "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
2277 (when keywords
2278 (setf (arglist.key-p decoded-arglist) t)
2279 (setf (arglist.keyword-args decoded-arglist)
2280 (remove-duplicates
2281 (append (arglist.keyword-args decoded-arglist)
2282 keywords)
2283 :key #'keyword-arg.keyword)))
2284 (setf (arglist.allow-other-keys-p decoded-arglist)
2285 (or (arglist.allow-other-keys-p decoded-arglist)
2286 allow-other-keys-p)))
2287
2288 (defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
2289 "Determine extra keywords from the function call FORM, and modify
2290 DECODED-ARGLIST to include them. As a secondary return value, return
2291 the initial sublist of ARGS that was needed to determine the extra
2292 keywords. As a tertiary return value, return whether any enrichment
2293 was done."
2294 (multiple-value-bind (extra-keywords extra-aok determining-args)
2295 (apply #'extra-keywords form)
2296 ;; enrich the list of keywords with the extra keywords
2297 (enrich-decoded-arglist-with-keywords decoded-arglist
2298 extra-keywords extra-aok)
2299 (values decoded-arglist
2300 determining-args
2301 (or extra-keywords extra-aok))))
2302
2303 (defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
2304 (:documentation
2305 "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
2306 ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
2307 If the arglist is not available, return :NOT-AVAILABLE."))
2308
2309 (defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
2310 (let ((arglist (arglist operator-form)))
2311 (etypecase arglist
2312 ((member :not-available)
2313 :not-available)
2314 (list
2315 (let ((decoded-arglist (decode-arglist arglist)))
2316 (enrich-decoded-arglist-with-extra-keywords decoded-arglist
2317 (cons operator-form
2318 argument-forms)))))))
2319
2320 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
2321 argument-forms)
2322 (declare (ignore argument-forms))
2323 (multiple-value-bind (decoded-arglist determining-args)
2324 (call-next-method)
2325 (let ((first-arg (first (arglist.required-args decoded-arglist)))
2326 (open-arglist (compute-enriched-decoded-arglist 'open nil)))
2327 (when (and (arglist-p first-arg) (arglist-p open-arglist))
2328 (enrich-decoded-arglist-with-keywords
2329 first-arg
2330 (arglist.keyword-args open-arglist)
2331 nil)))
2332 (values decoded-arglist determining-args t)))
2333
2334 (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
2335 argument-forms)
2336 (let ((function-name-form (car argument-forms)))
2337 (when (and (listp function-name-form)
2338 (length= function-name-form 2)
2339 (member (car function-name-form) '(quote function)))
2340 (let ((function-name (cadr function-name-form)))
2341 (when (valid-operator-symbol-p function-name)
2342 (let ((function-arglist
2343 (compute-enriched-decoded-arglist function-name
2344 (cdr argument-forms))))
2345 (return-from compute-enriched-decoded-arglist
2346 (values (make-arglist :required-args
2347 (list 'function)
2348 :optional-args
2349 (append
2350 (mapcar #'(lambda (arg)
2351 (make-optional-arg arg nil))
2352 (arglist.required-args function-arglist))
2353 (arglist.optional-args function-arglist))
2354 :key-p
2355 (arglist.key-p function-arglist)
2356 :keyword-args
2357 (arglist.keyword-args function-arglist)
2358 :rest
2359 'args
2360 :allow-other-keys-p
2361 (arglist.allow-other-keys-p function-arglist))
2362 (list function-name-form)
2363 t)))))))
2364 (call-next-method))
2365
2366 (defslimefun arglist-for-insertion (name)
2367 (with-buffer-syntax ()
2368 (let ((symbol (parse-symbol name)))
2369 (cond
2370 ((and symbol
2371 (valid-operator-name-p name))
2372 (let ((decoded-arglist
2373 (compute-enriched-decoded-arglist symbol nil)))
2374 (if (eql decoded-arglist :not-available)
2375 :not-available
2376 (decoded-arglist-to-template-string decoded-arglist
2377 *buffer-package*))))
2378 (t
2379 :not-available)))))
2380
2381 (defvar *remove-keywords-alist*
2382 '((:test :test-not)
2383 (:test-not :test)))
2384
2385 (defun remove-actual-args (decoded-arglist actual-arglist)
2386 "Remove from DECODED-ARGLIST the arguments that have already been
2387 provided in ACTUAL-ARGLIST."
2388 (assert (or (and (not (arglist.key-p decoded-arglist))
2389 (not (arglist.any-p decoded-arglist)))
2390 (exactly-one-p (arglist.key-p decoded-arglist)
2391 (arglist.any-p decoded-arglist))))
2392 (loop while (and actual-arglist
2393 (arglist.required-args decoded-arglist))
2394 do (progn (pop actual-arglist)
2395 (pop (arglist.required-args decoded-arglist))))
2396 (loop while (and actual-arglist
2397 (arglist.optional-args decoded-arglist))
2398 do (progn (pop actual-arglist)
2399 (pop (arglist.optional-args decoded-arglist))))
2400 (if (arglist.any-p decoded-arglist)
2401 (remove-&any-args decoded-arglist actual-arglist)
2402 (remove-&key-args decoded-arglist actual-arglist))
2403 decoded-arglist)
2404
2405 (defun remove-&key-args (decoded-arglist key-args)
2406 (loop for keyword in key-args by #'cddr
2407 for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
2408 do (setf (arglist.keyword-args decoded-arglist)
2409 (remove-if (lambda (kw)
2410 (or (eql kw keyword)
2411 (member kw keywords-to-remove)))
2412 (arglist.keyword-args decoded-arglist)
2413 :key #'keyword-arg.keyword))) )
2414
2415 (defun remove-&any-args (decoded-arglist any-args)
2416 (setf (arglist.any-args decoded-arglist)
2417 (remove-if #'(lambda (x) (member x any-args))
2418 (arglist.any-args decoded-arglist)
2419 :key #'(lambda (x) (first (ensure-list x))))))
2420
2421
2422 (defun arglist-from-form-spec (form-spec &key (remove-args t))
2423 "Returns the decoded arglist that corresponds to FORM-SPEC. If
2424 REMOVE-ARGS is T, the arguments that are contained in FORM-SPEC
2425 are removed from the result arglist.
2426
2427 Examples:
2428
2429 (arglist-from-form-spec '(defun))
2430
2431 ~=> (name args &body body)
2432
2433 (arglist-from-form-spec '(defun foo))
2434
2435 ~=> (args &body body))
2436
2437 (arglist-from-form-spec '(defun foo) :remove-args nil)
2438
2439 ~=> (name args &body body))
2440
2441 (arglist-from-form-spec '((:type-specifier float) 42) :remove-args nil)
2442
2443 ~=> (&optional lower-limit upper-limit)
2444 "
2445 (if (null form-spec)
2446 :not-available
2447 (multiple-value-bind (type operator arguments)
2448 (split-form-spec form-spec)
2449 (arglist-dispatch type operator arguments :remove-args remove-args))))
2450
2451
2452 (defmacro with-availability ((var) form &body body)
2453 `(let ((,var ,form))
2454 (if (eql ,var :not-available)
2455 :not-available
2456 (progn ,@body))))
2457
2458 (defgeneric arglist-dispatch (operator-type operator arguments &key remove-args))
2459
2460 (defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t))
2461 (when (and (symbolp operator)
2462 (valid-operator-symbol-p operator))
2463 (multiple-value-bind (decoded-arglist determining-args any-enrichment)
2464 (compute-enriched-decoded-arglist operator arguments)
2465 (etypecase decoded-arglist
2466 ((member :not-available)
2467 :not-available)
2468 (arglist
2469 (cond
2470 (remove-args
2471 ;; get rid of formal args already provided
2472 (remove-actual-args decoded-arglist arguments))
2473 (t
2474 ;; replace some formal args by determining actual args
2475 (remove-actual-args decoded-arglist determining-args)
2476 (setf (arglist.provided-args decoded-arglist)
2477 determining-args)))
2478 (return-from arglist-dispatch
2479 (values decoded-arglist any-enrichment))))))
2480 :not-available)
2481
2482 (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'defmethod))
2483 arguments &key (remove-args t))
2484 (when (and (listp arguments)
2485 (not (null arguments)) ;have generic function name
2486 (notany #'listp (rest arguments))) ;don't have arglist yet
2487 (let* ((gf-name (first arguments))
2488 (gf (and (or (symbolp gf-name)
2489 (and (listp gf-name)
2490 (eql (first gf-name) 'setf)))
2491 (fboundp gf-name)
2492 (fdefinition gf-name))))
2493 (when (typep gf 'generic-function)
2494 (with-availability (arglist) (arglist gf)
2495 (return-from arglist-dispatch
2496 (values (make-arglist :provided-args (if remove-args
2497 nil
2498 (list gf-name))
2499 :required-args (list arglist)
2500 :rest "body" :body-p t)
2501 t))))))
2502 (call-next-method))
2503
2504 (defmethod arglist-dispatch ((operator-type (eql :declaration))
2505 decl-identifier decl-args &key (remove-args t))
2506 (with-availability (arglist)
2507 (declaration-arglist decl-identifier)
2508 (maybecall remove-args #'remove-actual-args
2509 (decode-arglist arglist) decl-args))
2510 ;; We don't fall back to CALL-NEXT-METHOD because we're within a
2511 ;; different namespace!
2512 )
2513
2514 (defmethod arglist-dispatch ((operator-type (eql :type-specifier))
2515 type-specifier specifier-args &key (remove-args t))
2516 (with-availability (arglist)
2517 (type-specifier-arglist type-specifier)
2518 (maybecall remove-args #'remove-actual-args
2519 (decode-arglist arglist) specifier-args))
2520 ;; No CALL-NEXT-METHOD, see above.
2521 )
2522
2523
2524 (defun read-incomplete-form-from-string (form-string)
2525 (with-buffer-syntax ()
2526 (handler-case
2527 (read-from-string form-string)
2528 (reader-error (c)
2529 (declare (ignore c))
2530 nil)
2531 (stream-error (c)
2532 (declare (ignore c))
2533 nil))))
2534
2535
2536 (defslimefun complete-form (form-string)
2537 "Read FORM-STRING in the current buffer package, then complete it
2538 by adding a template for the missing arguments."
2539 (let ((form (parse-form-spec form-string)))
2540 (when (consp form)
2541 (let ((form-completion (arglist-from-form-spec form)))
2542 (unless (eql form-completion :not-available)
2543 (return-from complete-form
2544 (decoded-arglist-to-template-string form-completion
2545 *buffer-package*
2546 :prefix "")))))
2547 :not-available))
2548
2549
2550 (defun arglist-ref (decoded-arglist operator &rest indices)
2551 (cond
2552 ((null indices) decoded-arglist)
2553 ((not (arglist-p decoded-arglist)) nil)
2554 (t
2555 (let ((index (first indices))
2556 (args (append (and operator
2557 (list operator))
2558 (arglist.required-args decoded-arglist)
2559 (arglist.optional-args decoded-arglist))))
2560 (when (< index (length args))
2561 (let ((arg (elt args index)))
2562 (apply #'arglist-ref arg nil (rest indices))))))))
2563
2564 (defslimefun completions-for-keyword (raw-specs keyword-string arg-indices)
2565 (with-buffer-syntax ()
2566 (multiple-value-bind (form-spec index)
2567 (parse-first-valid-form-spec raw-specs arg-indices)
2568 (when form-spec
2569 (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
2570 (unless (eql arglist :not-available)
2571 (multiple-value-bind (type operator arguments) (split-form-spec form-spec)
2572 (declare (ignore type arguments))
2573 (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
2574 (arglist (apply #'arglist-ref arglist operator indices)))
2575 (when (and arglist (arglist-p arglist))
2576 ;; It would be possible to complete keywords only if we
2577 ;; are in a keyword position, but it is not clear if we
2578 ;; want that.
2579 (let* ((keywords
2580 (mapcar #'keyword-arg.keyword
2581 (arglist.keyword-args arglist)))
2582 (keyword-name
2583 (tokenize-symbol keyword-string))
2584 (matching-keywords
2585 (find-matching-symbols-in-list keyword-name keywords
2586 #'compound-prefix-match))
2587 (converter (completion-output-symbol-converter keyword-string))
2588 (strings
2589 (mapcar converter
2590 (mapcar #'symbol-name matching-keywords)))
2591 (completion-set
2592 (format-completion-set strings nil "")))
2593 (list completion-set
2594 (longest-compound-prefix completion-set))))))))))))
2595
2596
2597 (defun arglist-to-string (arglist package &key print-right-margin highlight)
2598 (decoded-arglist-to-string (decode-arglist arglist)
2599 :package package
2600 :print-right-margin print-right-margin
2601 :highlight highlight))
2602
2603 (defun test-print-arglist ()
2604 (flet ((test (list string)
2605 (let* ((p (find-package :swank))
2606 (actual (arglist-to-string list p)))
2607 (unless (string= actual string)
2608 (warn "Test failed: ~S => ~S~% Expected: ~S"
2609 list actual string)))))
2610 (test '(function cons) "(function cons)")
2611 (test '(quote cons) "(quote cons)")
2612 (test '(&key (function #'+)) "(&key (function #'+))")
2613 (test '(&whole x y z) "(y z)")
2614 (test '(x &aux y z) "(x)")
2615 (test '(x &environment env y) "(x y)")
2616 (test '(&key ((function f))) "(&key ((function f)))")))
2617
2618 (test-print-arglist)
2619
2620
2621 ;;;; Recording and accessing results of computations
2622
2623 (defvar *record-repl-results* t
2624 "Non-nil means that REPL results are saved for later lookup.")
2625
2626 (defvar *object-to-presentation-id*
2627 (make-weak-key-hash-table :test 'eq)
2628 "Store the mapping of objects to numeric identifiers")
2629
2630 (defvar *presentation-id-to-object*
2631 (make-weak-value-hash-table :test 'eql)
2632 "Store the mapping of numeric identifiers to objects")
2633
2634 (defun clear-presentation-tables ()
2635 (clrhash *object-to-presentation-id*)
2636 (clrhash *presentation-id-to-object*))
2637
2638 (defvar *presentation-counter* 0 "identifier counter")
2639
2640 (defvar *nil-surrogate* (make-symbol "nil-surrogate"))
2641
2642 ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
2643 ;; rest of slime isn't thread safe either), do we really care?
2644 (defun save-presented-object (object)
2645 "Save OBJECT and return the assigned id.
2646 If OBJECT was saved previously return the old id."
2647 (let ((object (if (null object) *nil-surrogate* object)))
2648 ;; We store *nil-surrogate* instead of nil, to distinguish it from
2649 ;; an object that was garbage collected.
2650 (or (gethash object *object-to-presentation-id*)
2651 (let ((id (incf *presentation-counter*)))
2652 (setf (gethash id *presentation-id-to-object*) object)
2653 (setf (gethash object *object-to-presentation-id*) id)
2654 id))))
2655
2656 (defun lookup-presented-object (id)
2657 "Retrieve the object corresponding to ID.
2658 The secondary value indicates the absence of an entry."
2659 (etypecase id
2660 (integer
2661 ;;
2662 (multiple-value-bind (object foundp)
2663 (gethash id *presentation-id-to-object*)
2664 (cond
2665 ((eql object *nil-surrogate*)
2666 ;; A stored nil object
2667 (values nil t))
2668 ((null object)
2669 ;; Object that was replaced by nil in the weak hash table
2670 ;; when the object was garbage collected.
2671 (values nil nil))
2672 (t
2673 (values object foundp)))))
2674 (cons
2675 (destructure-case id
2676 ((:frame-var thread-id frame index)
2677 (declare (ignore thread-id)) ; later
2678 (handler-case
2679 (frame-var-value frame index)
2680 (t (condition)
2681 (declare (ignore condition))
2682 (values nil nil))
2683 (:no-error (value)
2684 (values value t))))
2685 ((:inspected-part part-index)
2686 (declare (special *inspectee-parts*))
2687 (if (< part-index (length *inspectee-parts*))
2688 (values (inspector-nth-part part-index) t)
2689 (values nil nil)))))))
2690
2691 (defslimefun get-repl-result (id)
2692 "Get the result of the previous REPL evaluation with ID."
2693 (multiple-value-bind (object foundp) (lookup-presented-object id)
2694 (cond (foundp object)
2695 (t (abort-request "Attempt to access unrecorded object (id ~D)." id)))))
2696
2697 (defslimefun clear-repl-results ()
2698 "Forget the results of all previous REPL evaluations."
2699 (clear-presentation-tables)
2700 t)
2701
2702
2703 ;;;; Evaluation
2704
2705 (defvar *pending-continuations* '()
2706 "List of continuations for Emacs. (thread local)")
2707
2708 (defun guess-buffer-package (string)
2709 "Return a package for STRING.
2710 Fall back to the the current if no such package exists."
2711 (or (and string (guess-package string))
2712 *package*))
2713
2714 (defun eval-for-emacs (form buffer-package id)
2715 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2716 Return the result to the continuation ID.
2717 Errors are trapped and invoke our debugger."
2718 (call-with-debugger-hook
2719 #'swank-debugger-hook
2720 (lambda ()
2721 (let (ok result reason)
2722 (unwind-protect
2723 (let ((*buffer-package* (guess-buffer-package buffer-package))
2724 (*buffer-readtable* (guess-buffer-readtable buffer-package))
2725 (*pending-continuations* (cons id *pending-continuations*)))
2726 (check-type *buffer-package* package)
2727 (check-type *buffer-readtable* readtable)
2728 ;; APPLY would be cleaner than EVAL.
2729 ;;(setq result (apply (car form) (cdr form)))
2730 (handler-case
2731 (progn
2732 (setq result (eval form))
2733 (run-hook *pre-reply-hook*)
2734 (finish-output)
2735 (setq ok t))
2736 (request-abort (c)
2737 (setf ok nil)
2738 (setf reason (swank-backend::reason c)))))
2739 (force-user-output)
2740 (send-to-emacs `(:return ,(current-thread)
2741 ,(if ok
2742 `(:ok ,result)
2743 `(:abort ,reason))
2744 ,id)))))))
2745
2746 (defvar *echo-area-prefix* "=> "
2747 "A prefix that `format-values-for-echo-area' should use.")
2748
2749 (defun format-values-for-echo-area (values)
2750 (with-buffer-syntax ()
2751 (let ((*print-readably* nil))
2752 (cond ((null values) "; No value")
2753 ((and (length= values 1) (integerp (car values)))
2754 (let ((i (car values)))
2755 (format nil "~A~D (#x~X, #o~O, #b~B)"
2756 *echo-area-prefix* i i i i)))
2757 (t (with-output-to-string (s)
2758 (pprint-logical-block (s () :prefix *echo-area-prefix*)
2759 (format s "~{~S~^, ~}" values))))))))
2760
2761 (defslimefun interactive-eval (string)
2762 (with-buffer-syntax ()
2763 (let ((values (multiple-value-list (eval (from-string string)))))
2764 (fresh-line)
2765 (finish-output)
2766 (format-values-for-echo-area values))))
2767
2768 (defslimefun eval-and-grab-output (string)
2769 (with-buffer-syntax ()
2770 (let* ((s (make-string-output-stream))
2771 (*standard-output* s)
2772 (values (multiple-value-list (eval (from-string string)))))
2773 (list (get-output-stream-string s)
2774 (format nil "~{~S~^~%~}" values)))))
2775
2776 ;;; XXX do we need this stuff? What is it good for?
2777 (defvar *slime-repl-advance-history* nil
2778 "In the dynamic scope of a single form typed at the repl, is set to nil to
2779 prevent the repl from advancing the history - * ** *** etc.")
2780
2781 (defvar *slime-repl-suppress-output* nil
2782 "In the dynamic scope of a single form typed at the repl, is set to nil to
2783 prevent the repl from printing the result of the evalation.")
2784
2785 (defvar *slime-repl-eval-hook-pass* (gensym "PASS")
2786 "Token to indicate that a repl hook declines to evaluate the form")
2787
2788 (defvar *slime-repl-eval-hooks* nil
2789 "A list of functions. When the repl is about to eval a form, first try running each of
2790 these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
2791 is considered a replacement for calling eval. If there are no hooks, or all
2792 pass, then eval is used.")
2793
2794 (defslimefun repl-eval-hook-pass ()
2795 "call when repl hook declines to evaluate the form"
2796 (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
2797
2798 (defslimefun repl-suppress-output ()
2799 "In the dynamic scope of a single form typed at the repl, call to
2800 prevent the repl from printing the result of the evalation."
2801 (setq *slime-repl-suppress-output* t))
2802
2803 (defslimefun repl-suppress-advance-history ()
2804 "In the dynamic scope of a single form typed at the repl, call to
2805 prevent the repl from advancing the history - * ** *** etc."
2806 (setq *slime-repl-advance-history* nil))
2807
2808 (defun eval-region (string &optional package-update-p)
2809 "Evaluate STRING and return the result.
2810 If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package
2811 change, then send Emacs an update."
2812 (unwind-protect
2813 (with-input-from-string (stream string)
2814 (let (- values)
2815 (loop
2816 (let ((form (read stream nil stream)))
2817 (when (eq form stream)
2818 (fresh-line)
2819 (finish-output)
2820 (return (values values -)))
2821 (setq - form)
2822 (if *slime-repl-eval-hooks*
2823 (setq values (run-repl-eval-hooks form))
2824 (setq values (multiple-value-list (eval form))))
2825 (finish-output)))))
2826 (when (and package-update-p (not (eq *package* *buffer-package*)))
2827 (send-to-emacs
2828 (list :new-package (package-name *package*)
2829 (package-string-for-prompt *package*))))))
2830
2831 (defun run-repl-eval-hooks (form)
2832 (loop for hook in *slime-repl-eval-hooks*
2833 for res = (catch *slime-repl-eval-hook-pass*
2834 (multiple-value-list (funcall hook form)))
2835 until (not (eq res *slime-repl-eval-hook-pass*))
2836 finally (return
2837 (if (eq res *slime-repl-eval-hook-pass*)
2838 (multiple-value-list (eval form))
2839 res))))
2840
2841 (defun package-string-for-prompt (package)
2842 "Return the shortest nickname (or canonical name) of PACKAGE."
2843 (unparse-name
2844 (or (canonical-package-nickname package)
2845 (auto-abbreviated-package-name package)
2846 (shortest-package-nickname package))))
2847
2848 (defun canonical-package-nickname (package)
2849 "Return the canonical package nickname, if any, of PACKAGE."
2850 (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
2851 :test #'string=))))
2852 (and name (string name))))
2853
2854 (defun auto-abbreviated-package-name (package)
2855 "Return an abbreviated 'name' for PACKAGE.
2856
2857 N.B. this is not an actual package name or nickname."
2858 (when *auto-abbreviate-dotted-packages*
2859 (let ((last-dot (position #\. (package-name package) :from-end t)))
2860 (when last-dot (subseq (package-name package) (1+ last-dot))))))
2861
2862 (defun shortest-package-nickname (package)
2863 "Return the shortest nickname (or canonical name) of PACKAGE."
2864 (loop for name in (cons (package-name package) (package-nicknames package))
2865 for shortest = name then (if (< (length name) (length shortest))
2866 name
2867 shortest)
2868 finally (return shortest)))
2869
2870 (defslimefun interactive-eval-region (string)
2871 (with-buffer-syntax ()
2872 (format-values-for-echo-area (eval-region string))))
2873
2874 (defslimefun re-evaluate-defvar (form)
2875 (with-buffer-syntax ()
2876 (let ((form (read-from-string form)))
2877 (destructuring-bind (dv name &optional value doc) form
2878 (declare (ignore value doc))
2879 (assert (eq dv 'defvar))
2880 (makunbound name)
2881 (prin1-to-string (eval form))))))
2882
2883 (defvar *swank-pprint-bindings*
2884 `((*print-pretty* . t)
2885 (*print-level* . nil)
2886 (*print-length* . nil)
2887 (*print-circle* . t)
2888 (*print-gensym* . t)
2889 (*print-readably* . nil))
2890 "A list of variables bindings during pretty printing.
2891 Used by pprint-eval.")
2892
2893 (defun swank-pprint (list)
2894 "Bind some printer variables and pretty print each object in LIST."
2895 (with-buffer-syntax ()
2896 (with-bindings *swank-pprint-bindings*
2897 (cond ((null list) "; No value")
2898 (t (with-output-to-string (*standard-output*)
2899 (dolist (o list)
2900 (pprint o)
2901 (terpri))))))))
2902
2903 (defslimefun pprint-eval (string)
2904 (with-buffer-syntax ()
2905 (swank-pprint (multiple-value-list (eval (read-from-string string))))))
2906
2907 (defslimefun set-package (name)
2908 "Set *package* to the package named NAME.
2909 Return the full package-name and the string to use in the prompt."
2910 (let ((p (guess-package name)))
2911 (assert (packagep p))
2912 (setq *package* p)
2913 (list (package-name p) (package-string-for-prompt p))))
2914
2915 (defun send-repl-results-to-emacs (values)
2916 (flet ((send (value)
2917 (let ((id (and *record-repl-results*
2918 (save-presented-object value))))
2919 (send-to-emacs `(:write-string ,(prin1-to-string value)
2920 ,id :repl-result))
2921 (send-to-emacs `(:write-string ,(string #\Newline)
2922 nil :repl-result)))))
2923 (if (null values)
2924 (send-to-emacs `(:write-string "; No value" nil :repl-result))
2925 (mapc #'send values))))
2926
2927 (defslimefun listener-eval (string)
2928 (clear-user-input)
2929 (with-buffer-syntax ()
2930 (let ((*slime-repl-suppress-output* :unset)
2931 (*slime-repl-advance-history* :unset))
2932 (multiple-value-bind (values last-form) (eval-region string t)
2933 (unless (or (and (eq values nil) (eq last-form nil))
2934 (eq *slime-repl-advance-history* nil))
2935 (setq *** ** ** * * (car values)
2936 /// // // / / values))
2937 (setq +++ ++ ++ + + last-form)
2938 (unless (eq *slime-repl-suppress-output* t)
2939 (send-repl-results-to-emacs values)))))
2940 nil)
2941
2942 (defslimefun ed-in-emacs (&optional what)
2943 "Edit WHAT in Emacs.
2944
2945 WHAT can be:
2946 A pathname or a string,
2947 A list (PATHNAME-OR-STRING LINE [COLUMN]),
2948 A function name (symbol or cons),
2949 NIL.
2950
2951 Returns true if it actually called emacs, or NIL if not."
2952 (flet ((pathname-or-string-p (thing)
2953 (or (pathnamep thing) (typep thing 'string))))
2954 (let ((target
2955 (cond ((and (listp what) (pathname-or-string-p (first what)))
2956 (cons (canonicalize-filename (car what)) (cdr what)))
2957 ((pathname-or-string-p what)
2958 (canonicalize-filename what))
2959 ((symbolp what) what)
2960 ((consp what) what)
2961 (t (return-from ed-in-emacs nil)))))
2962 (cond
2963 (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
2964 ((default-connection)
2965 (with-connection ((default-connection))
2966 (send-oob-to-emacs `(:ed ,target))))
2967 (t nil)))))
2968
2969 (defslimefun inspect-in-emacs (what)
2970 "Inspect WHAT in Emacs."
2971 (flet ((send-it ()
2972 (with-buffer-syntax ()
2973 (reset-inspector)
2974 (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
2975 (cond
2976 (*emacs-connection*
2977 (send-it))
2978 ((default-connection)
2979 (with-connection ((default-connection))
2980 (send-it))))
2981 what))
2982
2983 (defslimefun value-for-editing (form)
2984 "Return a readable value of FORM for editing in Emacs.
2985 FORM is expected, but not required, to be SETF'able."
2986 ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
2987 (with-buffer-syntax ()
2988 (prin1-to-string (eval (read-from-string form)))))
2989
2990 (defslimefun commit-edited-value (form value)
2991 "Set the value of a setf'able FORM to VALUE.
2992 FORM and VALUE are both strings from Emacs."
2993 (with-buffer-syntax ()
2994 (eval `(setf ,(read-from-string form)
2995 ,(read-from-string (concatenate 'string "`" value))))
2996 t))
2997
2998 (defun background-message (format-string &rest args)
2999 "Display a message in Emacs' echo area.
3000
3001 Use this function for informative messages only. The message may even
3002 be dropped, if we are too busy with other things."
3003 (when *emacs-connection*
3004 (send-to-emacs `(:background-message
3005 ,(apply #'format nil format-string args)))))
3006
3007
3008 ;;;; Debugger
3009
3010 (defun swank-debugger-hook (condition hook)
3011 "Debugger function for binding *DEBUGGER-HOOK*.
3012 Sends a message to Emacs declaring that the debugger has been entered,
3013 then waits to handle further requests from Emacs. Eventually returns
3014 after Emacs causes a restart to be invoked."
3015 (declare (ignore hook))
3016 (cond (*emacs-connection*
3017 (debug-in-emacs condition))
3018 ((default-connection)
3019 (with-connection ((default-connection))
3020 (debug-in-emacs condition)))))
3021
3022 (defvar *global-debugger* t
3023 "Non-nil means the Swank debugger hook will be installed globally.")
3024
3025 (add-hook *new-connection-hook* 'install-debugger)
3026 (defun install-debugger (connection)
3027 (declare (ignore connection))
3028 (when *global-debugger*
3029 (install-debugger-globally #'swank-debugger-hook)))
3030
3031 ;;;;; Debugger loop
3032 ;;;
3033 ;;; These variables are dynamically bound during debugging.
3034 ;;;
3035 (defvar *swank-debugger-condition* nil
3036 "The condition being debugged.")
3037
3038 (defvar *sldb-level* 0
3039 "The current level of recursive debugging.")
3040
3041 (defvar *sldb-initial-frames* 20
3042 "The initial number of backtrace frames to send to Emacs.")
3043
3044 (defvar *sldb-restarts* nil
3045 "The list of currenlty active restarts.")
3046
3047 (defvar *sldb-stepping-p* nil
3048 "True during execution of a step command.")
3049
3050 (defun debug-in-emacs (condition)
3051 (let ((*swank-debugger-condition* condition)
3052 (*sldb-restarts* (compute-sane-restarts condition))
3053 (*package* (or (and (boundp '*buffer-package*)
3054 (symbol-value '*buffer-package*))
3055 *package*))
3056 (*sldb-level* (1+ *sldb-level*))
3057 (*sldb-stepping-p* nil)
3058 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
3059 (force-user-output)
3060 (call-with-debugging-environment
3061 (lambda ()
3062 (with-bindings *sldb-printer-bindings*
3063 (sldb-loop *sldb-level*))))))
3064
3065 (defun sldb-loop (level)
3066 (unwind-protect
3067 (catch 'sldb-enter-default-debugger
3068 (send-to-emacs
3069 (list* :debug (current-thread) level
3070 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
3071 (loop (catch 'sldb-loop-catcher
3072 (with-simple-restart (abort "Return to sldb level ~D." level)
3073 (send-to-emacs (list :debug-activate (current-thread)
3074 level))
3075 (handler-bind ((sldb-condition #'handle-sldb-condition))
3076 (read-from-emacs))))))
3077 (send-to-emacs `(:debug-return
3078 ,(current-thread) ,level ,*sldb-stepping-p*))))
3079
3080 (defun handle-sldb-condition (condition)
3081 "Handle an internal debugger condition.
3082 Rather than recursively debug the debugger (a dangerous idea!), these
3083 conditions are simply reported."
3084 (let ((real-condition (original-condition condition)))
3085 (send-to-emacs `(:debug-condition ,(current-thread)
3086 ,(princ-to-string real-condition))))
3087 (throw 'sldb-loop-catcher nil))
3088
3089 (defun safe-condition-message (condition)
3090 "Safely print condition to a string, handling any errors during
3091 printing."
3092 (let ((*print-pretty* t))
3093 (handler-case
3094 (format-sldb-condition condition)
3095 (error (cond)
3096 ;; Beware of recursive errors in printing, so only use the condition
3097 ;; if it is printable itself:
3098 (format nil "Unable to display error condition~@[: ~A~]"
3099 (ignore-errors (princ-to-string cond)))))))
3100
3101 (defun debugger-condition-for-emacs ()
3102 (list (safe-condition-message *swank-debugger-condition*)
3103 (format nil " [Condition of type ~S]"
3104 (type-of *swank-debugger-condition*))
3105 (condition-references *swank-debugger-condition*)
3106 (condition-extras *swank-debugger-condition*)))
3107
3108 (defun format-restarts-for-emacs ()
3109 "Return a list of restarts for *swank-debugger-condition* in a
3110 format suitable for Emacs."
3111 (let ((*print-right-margin* most-positive-fixnum))
3112 (loop for restart in *sldb-restarts*
3113 collect (list (princ-to-string (restart-name restart))
3114 (princ-to-string restart)))))
3115
3116
3117 ;;;;; SLDB entry points
3118
3119 (defslimefun sldb-break-with-default-debugger ()
3120 "Invoke the default debugger by returning from our debugger-loop."
3121 (throw 'sldb-enter-default-debugger nil))
3122
3123 (defslimefun backtrace (start end)
3124 "Return a list ((I FRAME) ...) of frames from START to END.
3125 I is an integer describing and FRAME a string."
3126 (loop for frame in (compute-backtrace start end)
3127 for i from start
3128 collect (list i (with-output-to-string (stream)
3129 (handler-case
3130 (print-frame frame stream)
3131 (t ()
3132 (format stream "[error printing frame]")))))))
3133
3134 (defslimefun debugger-info-for-emacs (start end)
3135 "Return debugger state, with stack frames from START to END.
3136 The result is a list:
3137 (condition ({restart}*) ({stack-frame}*) (cont*))
3138 where
3139 condition ::= (description type [extra])
3140 restart ::= (name description)
3141 stack-frame ::= (number description)
3142 extra ::= (:references and other random things)
3143 cont ::= continutation
3144 condition---a pair of strings: message, and type. If show-source is
3145 not nil it is a frame number for which the source should be displayed.
3146
3147 restart---a pair of strings: restart name, and description.
3148
3149 stack-frame---a number from zero (the top), and a printed
3150 representation of the frame's call.
3151
3152 continutation---the id of a pending Emacs continuation.
3153
3154 Below is an example return value. In this case the condition was a
3155 division by zero (multi-line description), and only one frame is being
3156 fetched (start=0, end=1).
3157
3158 ((\"Arithmetic error DIVISION-BY-ZERO signalled.
3159 Operation was KERNEL::DIVISION, operands (1 0).\"
3160 \"[Condition of type DIVISION-BY-ZERO]\")
3161 ((\"ABORT\" \"Return to Slime toplevel.\")
3162 (\"ABORT\" \"Return to Top-Level.\"))
3163 ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
3164 (4))"
3165 (list (debugger-condition-for-emacs)
3166 (format-restarts-for-emacs)
3167 (backtrace start end)
3168 *pending-continuations*))
3169
3170 (defun nth-restart (index)
3171 (nth index *sldb-restarts*))
3172
3173 (defslimefun invoke-nth-restart (index)
3174 (invoke-restart-interactively (nth-restart index)))
3175
3176 (defslimefun sldb-abort ()
3177 (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
3178
3179 (defslimefun sldb-continue ()
3180 (continue))
3181
3182 (defslimefun throw-to-toplevel ()
3183 "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
3184 If we are not evaluating an RPC then ABORT instead."
3185 (let ((restart (find-restart *sldb-quit-restart*)))
3186 (cond (restart (invoke-restart restart))
3187 (t (format nil
3188 "Restart not found: ~a"
3189 *sldb-quit-restart*)))))
3190
3191 (defslimefun invoke-nth-restart-for-emacs (sldb-level n)
3192 "Invoke the Nth available restart.
3193 SLDB-LEVEL is the debug level when the request was made. If this
3194 has changed, ignore the request."
3195 (when (= sldb-level *sldb-level*)
3196 (invoke-nth-restart n)))
3197
3198 (defun wrap-sldb-vars (form)
3199 `(let ((*sldb-level* ,*sldb-level*))
3200 ,form))
3201
3202 (defslimefun eval-string-in-frame (string index)
3203 (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
3204 index)))
3205
3206 (defslimefun pprint-eval-string-in-frame (string index)
3207 (swank-pprint
3208 (multiple-value-list
3209 (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
3210
3211 (defslimefun frame-locals-for-emacs (index)
3212 "Return a property list ((&key NAME ID VALUE) ...) describing
3213 the local variables in the frame INDEX."
3214 (mapcar (lambda (frame-locals)
3215 (destructuring-bind (&key name id value) frame-locals
3216 (list :name (prin1-to-string name) :id id
3217 :value (to-string value))))
3218 (frame-locals index)))
3219
3220 (defslimefun frame-catch-tags-for-emacs (frame-index)
3221 (mapcar #'to-string (frame-catch-tags frame-index)))
3222
3223 (defslimefun sldb-disassemble (index)
3224 (with-output-to-string (*standard-output*)
3225 (disassemble-frame index)))
3226
3227 (defslimefun sldb-return-from-frame (index string)
3228 (let ((form (from-string string)))
3229 (to-string (multiple-value-list (return-from-frame index form)))))
3230
3231 (defslimefun sldb-break (name)
3232 (with-buffer-syntax ()
3233 (sldb-break-at-start (read-from-string name))))
3234
3235 (defmacro define-stepper-function (name backend-function-name)
3236 `(defslimefun ,name (frame)
3237 (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
3238 (setq *sldb-stepping-p* t)
3239 (,backend-function-name))
3240 ((find-restart 'continue)
3241 (activate-stepping frame)
3242 (setq *sldb-stepping-p* t)
3243 (continue))
3244 (t
3245 (error "Not currently single-stepping, and no continue restart available.")))))
3246
3247 (define-stepper-function sldb-step sldb-step-into)
3248 (define-stepper-function sldb-next sldb-step-next)
3249 (define-stepper-function sldb-out sldb-step-out)
3250
3251
3252 ;;;; Compilation Commands.
3253
3254 (defvar *compiler-notes* '()
3255 "List of compiler notes for the last compilation unit.")
3256
3257 (defun clear-compiler-notes ()
3258 (setf *compiler-notes* '()))
3259
3260 (defun canonicalize-filename (filename)
3261 (namestring (truename filename)))
3262
3263 (defslimefun compiler-notes-for-emacs ()
3264 "Return the list of compiler notes for the last compilation unit."
3265 (reverse *compiler-notes*))
3266
3267 (defun measure-time-interval (fn)
3268 "Call FN and return the first return value and the elapsed time.
3269 The time is measured in microseconds."
3270 (declare (type function fn))
3271 (let ((before (get-internal-real-time)))
3272 (values
3273 (funcall fn)
3274 (* (- (get-internal-real-time) before)
3275 (/ 1000000 internal-time-units-per-second)))))
3276
3277 (defun record-note-for-condition (condition)
3278 "Record a note for a compiler-condition."
3279 (push (make-compiler-note condition) *compiler-notes*))
3280
3281 (defun make-compiler-note (condition)
3282 "Make a compiler note data structure from a compiler-condition."
3283 (declare (type compiler-condition condition))
3284 (list* :message (message condition)
3285 :severity (severity condition)
3286 :location (location condition)
3287 :references (references condition)
3288 (let ((s (short-message condition)))
3289 (if s (list :short-message s)))))
3290
3291 (defun swank-compiler (function)
3292 (clear-compiler-notes)
3293 (multiple-value-bind (result usecs)
3294 (with-simple-restart (abort "Abort SLIME compilation.")
3295 (handler-bind ((compiler-condition #'record-note-for-condition))
3296 (measure-time-interval function)))
3297 ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
3298 ;; unfortunately the SWANK protocol doesn't support returning multiple
3299 ;; values, so we gotta convert it explicitely to a list in either case.
3300 (if (and (not result) (eq usecs 't))
3301 (list nil nil)
3302 (list (to-string result)
3303 (format nil "~,2F" (/ usecs 1000000.0))))))
3304
3305 (defslimefun compile-file-for-emacs (filename load-p)
3306 "Compile FILENAME and, when LOAD-P, load the result.
3307 Record compiler notes signalled as `compiler-condition's."
3308 (with-buffer-syntax ()
3309 (let ((*compile-print* nil))
3310 (swank-compiler
3311 (lambda ()
3312 (swank-compile-file filename load-p
3313 (or (guess-external-format filename)
3314 :default)))))))
3315
3316 (defslimefun compile-string-for-emacs (string buffer position directory)
3317 "Compile STRING (exerpted from BUFFER at POSITION).
3318 Record compiler notes signalled as `compiler-condition's."
3319 (with-buffer-syntax ()
3320 (swank-compiler
3321 (lambda ()
3322 (let ((*compile-print* nil) (*compile-verbose* t))
3323 (swank-compile-string string :buffer buffer :position position
3324 :directory directory))))))
3325
3326 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
3327 "Compile and load SYSTEM using ASDF.
3328 Record compiler notes signalled as `compiler-condition's."
3329 (swank-compiler
3330 (lambda ()
3331 (apply #'operate-on-system system-name operation keywords))))
3332
3333 (defun asdf-central-registry ()
3334 (when (find-package :asdf)
3335 (symbol-value (find-symbol (string :*central-registry*) :asdf))))
3336
3337 (defslimefun list-all-systems-in-central-registry ()
3338 "Returns a list of all systems in ASDF's central registry."
3339 (mapcar #'pathname-name
3340 (delete-duplicates
3341 (loop for dir in (asdf-central-registry)
3342 for defaults = (eval dir)
3343 when defaults
3344 nconc (mapcar #'file-namestring
3345 (directory
3346 (make-pathname :defaults defaults
3347 :version :newest
3348 :type "asd"
3349 :name :wild
3350 :case :local))))
3351 :test #'string=)))
3352
3353 (defslimefun list-all-systems-known-to-asdf ()
3354 "Returns a list of all systems ASDF knows already."
3355 (unless (find-package :asdf)
3356 (error "ASDF not loaded"))
3357 ;; ugh, yeah, it's unexported - but do we really expect this to
3358 ;; change anytime soon?
3359 (loop for name being the hash-keys of (read-from-string
3360 "#.asdf::*defined-systems*")
3361 collect name))
3362
3363 (defslimefun list-asdf-systems ()
3364 "Returns the systems in ASDF's central registry and those which ASDF
3365 already knows."
3366 (nunion (list-all-systems-known-to-asdf)
3367 (list-all-systems-in-central-registry)
3368 :test #'string=))
3369
3370 (defun file-newer-p (new-file old-file)
3371 "Returns true if NEW-FILE is newer than OLD-FILE."
3372 (> (file-write-date new-file) (file-write-date old-file)))
3373
3374 (defun requires-compile-p (source-file)
3375 (let ((fasl-file (probe-file (compile-file-pathname source-file))))
3376 (or (not fasl-file)
3377 (file-newer-p source-file fasl-file))))
3378
3379 (defslimefun compile-file-if-needed (filename loadp)
3380 (cond ((requires-compile-p filename)
3381 (compile-file-for-emacs filename loadp))
3382 (loadp
3383 (load (compile-file-pathname filename))
3384 nil)))
3385
3386
3387 ;;;; Loading
3388
3389 (defslimefun load-file (filename)
3390 (to-string (load filename)))
3391
3392 (defslimefun load-file-set-package (filename &optional package)
3393 (load-file filename)
3394 (if package
3395 (set-package package)))
3396
3397
3398 ;;;;; swank-require
3399
3400 (defslimefun swank-require (module &optional filename)
3401 "Load the module MODULE."
3402 (require module (or filename (module-filename module)))
3403 nil)
3404
3405 (defvar *find-module* 'find-module
3406 "Pluggable function to locate modules.
3407 The function receives a module name as argument and should return
3408 the filename of the module (or nil if the file doesn't exist).")
3409
3410 (defun module-filename (module)
3411 "Return the filename for the module MODULE."
3412 (or (funcall *find-module* module)
3413 (error "Can't locate module: ~s" module)))
3414
3415 ;;;;;; Simple *find-module* function.
3416
3417 (defun merged-directory (dirname defaults)
3418 (pathname-directory
3419 (merge-pathnames
3420 (make-pathname :directory `(:relative ,dirname) :defaults defaults)
3421 defaults)))
3422
3423 (defvar *load-path*
3424 (list (make-pathname :directory (merged-directory "contrib" *load-truename*)
3425 :name nil :type nil :version nil
3426 :defaults *load-truename*))
3427 "A list of directories to search for modules.")
3428
3429 (defun module-canditates (name dir)
3430 (list (compile-file-pathname (make-pathname :name name :defaults dir))
3431 (make-pathname :name name :type "lisp" :defaults dir)))
3432
3433 (defun find-module (module)
3434 (let ((name (string-downcase module)))
3435 (some (lambda (dir) (some #'probe-file (module-canditates name dir)))
3436 *load-path*)))
3437
3438
3439 ;;;; Macroexpansion
3440
3441 (defvar *macroexpand-printer-bindings*
3442 '((*print-circle* . nil)
3443 (*print-pretty* . t)
3444 (*print-escape* . t)
3445 (*print-lines* . nil)
3446 (*print-level* . nil)
3447 (*print-length* . nil)))
3448
3449 (defun apply-macro-expander (expander string)
3450 (with-buffer-syntax ()
3451 (with-bindings *macroexpand-printer-bindings*
3452 (prin1-to-string (funcall expander (from-string string))))))
3453
3454 (defslimefun swank-macroexpand-1 (string)
3455 (apply-macro-expander #'macroexpand-1 string))
3456
3457 (defslimefun swank-macroexpand (string)
3458 (apply-macro-expander #'macroexpand string))
3459
3460 (defslimefun swank-macroexpand-all (string)
3461 (apply-macro-expander #'macroexpand-all string))
3462
3463 (defslimefun swank-compiler-macroexpand-1 (string)
3464 (apply-macro-expander #'compiler-macroexpand-1 string))
3465
3466 (defslimefun swank-compiler-macroexpand (string)
3467 (apply-macro-expander #'compiler-macroexpand string))
3468
3469 (defslimefun disassemble-symbol (name)
3470 (with-buffer-syntax ()
3471 (with-output-to-string (*standard-output*)
3472 (let ((*print-readably* nil))
3473 (disassemble (fdefinition (from-string name)))))))
3474
3475
3476 ;;;; Basic completion
3477
3478 (defslimefun completions (string default-package-name)
3479 "Return a list of completions for a symbol designator STRING.
3480
3481 The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
3482 COMPLETION-SET is the list of all matching completions, and
3483 COMPLETED-PREFIX is the best (partial) completion of the input
3484 string.
3485
3486 Simple compound matching is supported on a per-hyphen basis:
3487
3488 (completions \"m-v-\" \"COMMON-LISP\")
3489 ==> ((\"multiple-value-bind\" \"multiple-value-call\"
3490 \"multiple-value-list\" \"multiple-value-prog1\"
3491 \"multiple-value-setq\" \"multiple-values-limit\")
3492 \"multiple-value\")
3493
3494 \(For more advanced compound matching, see FUZZY-COMPLETIONS.)
3495
3496 If STRING is package qualified the result list will also be
3497 qualified. If string is non-qualified the result strings are
3498 also not qualified and are considered relative to
3499 DEFAULT-PACKAGE-NAME.
3500
3501 The way symbols are matched depends on the symbol designator's
3502 format. The cases are as follows:
3503 FOO - Symbols with matching prefix and accessible in the buffer package.
3504 PKG:FOO - Symbols with matching prefix and external in package PKG.
3505 PKG::FOO - Symbols with matching prefix and accessible in package PKG.
3506 "
3507 (let ((completion-set (completion-set string default-package-name
3508 #'compound-prefix-match)))
3509 (when completion-set
3510 (list completion-set (longest-compound-prefix completion-set)))))
3511
3512
3513 (defslimefun simple-completions (string default-package-name)
3514 "Return a list of completions for a symbol designator STRING."
3515 (let ((completion-set (completion-set string default-package-name
3516 #'prefix-match-p)))
3517 (list completion-set (longest-common-prefix completion-set))))
3518
3519 ;;;;; Find completion set
3520
3521 (defun completion-set (string default-package-name matchp)
3522 "Return the set of completion-candidates as strings."
3523 (multiple-value-bind (name package-name package internal-p)
3524 (parse-completion-arguments string default-package-name)
3525 (let* ((symbols (mapcar (completion-output-symbol-converter name)
3526 (and package
3527 (mapcar #'symbol-name
3528 (find-matching-symbols name
3529 package
3530 (and (not internal-p)
3531 package-name)
3532 matchp)))))
3533 (packs (mapcar (completion-output-package-converter name)
3534 (and (not package-name)
3535 (find-matching-packages name matchp)))))
3536 (format-completion-set (nconc symbols packs) internal-p package-name))))
3537
3538 (defun find-matching-symbols (string package external test)
3539 "Return a list of symbols in PACKAGE matching STRING.
3540 TEST is called with two strings. If EXTERNAL is true, only external
3541 symbols are returned."
3542 (let ((completions '())
3543 (converter (completion-output-symbol-converter string)))
3544 (flet ((symbol-matches-p (symbol)
3545 (and (or (not external)
3546 (symbol-external-p symbol package))
3547 (funcall test string
3548 (funcall converter (symbol-name symbol))))))
3549 (do-symbols* (symbol package)
3550 (when (symbol-matches-p symbol)
3551 (push symbol completions))))
3552 completions))
3553
3554 (defun find-matching-symbols-in-list (string list test)
3555 "Return a list of symbols in LIST matching STRING.
3556 TEST is called with two strings."
3557 (let ((completions '())
3558 (converter (completion-output-symbol-converter string)))
3559 (flet ((symbol-matches-p (symbol)
3560 (funcall test string
3561 (funcall converter (symbol-name symbol)))))
3562 (dolist (symbol list)
3563 (when (symbol-matches-p symbol)
3564 (push symbol completions))))
3565 (remove-duplicates completions)))
3566
3567 (defun find-matching-packages (name matcher)
3568 "Return a list of package names matching NAME with MATCHER.
3569 MATCHER is a two-argument predicate."
3570 (let ((to-match (string-upcase name)))
3571 (remove-if-not (lambda (x) (funcall matcher to-match x))
3572 (mapcar (lambda (pkgname)
3573 (concatenate 'string pkgname ":"))
3574 (loop for package in (list-all-packages)
3575 collect (package-name package)
3576 append (package-nicknames package))))))
3577
3578
3579 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
3580 "Returns one of
3581
3582 :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
3583
3584 :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
3585
3586 :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
3587 but is not _present_ in PACKAGE,
3588
3589 or NIL if SYMBOL is not _accessible_ in PACKAGE.
3590
3591
3592 Be aware not to get confused with :INTERNAL and how \"internal
3593 symbols\" are defined in the spec; there is a slight mismatch of
3594 definition with the Spec and what's commonly meant when talking
3595 about internal symbols most times. As the spec says:
3596
3597 In a package P, a symbol S is
3598
3599 _accessible_ if S is either _present_ in P itself or was
3600 inherited from another package Q (which implies
3601 that S is _external_ in Q.)
3602
3603 You can check that with: (AND (SYMBOL-STATUS S P) T)
3604
3605
3606 _present_ if either P is the /home package/ of S or S has been
3607 imported into P or exported from P by IMPORT, or
3608 EXPORT respectively.
3609
3610 Or more simply, if S is not _inherited_.
3611
3612 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
3613 (AND STATUS
3614 (NOT (EQ STATUS :INHERITED))))
3615
3616
3617 _external_ if S is going to be inherited into any package that
3618 /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
3619 DEFPACKAGE.
3620
3621 Note that _external_ implies _present_, since to
3622 make a symbol _external_, you'd have to use EXPORT
3623 which will automatically make the symbol _present_.
3624
3625 You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
3626
3627
3628 _internal_ if S is _accessible_ but not _external_.
3629
3630 You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
3631 (AND STATUS
3632 (NOT (EQ STATUS :EXTERNAL))))
3633
3634
3635 Notice that this is *different* to
3636 (EQ (SYMBOL-STATUS S P) :INTERNAL)
3637 because what the spec considers _internal_ is split up into two
3638 explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
3639 CL:FIND-SYMBOL does.
3640
3641 The rationale is that most times when you speak about \"internal\"
3642 symbols, you're actually not including the symbols inherited
3643 from other packages, but only about the symbols directly specific
3644 to the package in question.
3645 "
3646 (when package ; may be NIL when symbol is completely uninterned.
3647 (check-type symbol symbol) (check-type package package)
3648 (multiple-value-bind (present-symbol status)
3649 (find-symbol (symbol-name symbol) package)
3650 (and (eq symbol present-symbol) status))))
3651
3652 (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
3653 "True if SYMBOL is external in PACKAGE.
3654 If PACKAGE is not specified, the home package of SYMBOL is used."
3655 (eq (symbol-status symbol package) :external))
3656
3657
3658 ;; PARSE-COMPLETION-ARGUMENTS return table:
3659 ;;
3660 ;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
3661 ;; ----------------+--------+--------------+-----------------------------------
3662 ;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
3663 ;; | | | or *BUFFER-PACKAGE*
3664 ;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
3665 ;; | | |
3666 ;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
3667 ;; | | |
3668 ;; as:fo [tab] | "fo" | "as" | NIL
3669 ;; | | |
3670 ;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
3671 ;; | | |
3672 ;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
3673 ;;
3674 (defun parse-completion-arguments (string default-package-name)
3675 "Parse STRING as a symbol designator.
3676 Return these values:
3677 SYMBOL-NAME
3678 PACKAGE-NAME, or nil if the designator does not include an explicit package.
3679 PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
3680 NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
3681 if PACKAGE is non-NIL but a package cannot be found under that name,
3682 return NIL.)
3683 INTERNAL-P, if the symbol is qualified with `::'."
3684 (multiple-value-bind (name package-name internal-p)
3685 (tokenize-symbol string)
3686 (if package-name
3687 (let ((package (guess-package (if (equal package-name "")
3688 "KEYWORD"
3689 package-name))))
3690 (values name package-name package internal-p))
3691 (let ((package (guess-package default-package-name)))
3692 (values name package-name (or package *buffer-package*) internal-p))
3693 )))
3694
3695
3696 ;;;;; Format completion results
3697 ;;;
3698 ;;; We try to format results in the case as inputs. If you complete
3699 ;;; `FOO' then your result should include `FOOBAR' rather than
3700 ;;; `foobar'.
3701
3702 (defun format-completion-set (strings internal-p package-name)
3703 "Format a set of completion strings.
3704 Returns a list of completions with package qualifiers if needed."
3705 (mapcar (lambda (string)
3706 (format-completion-result string internal-p package-name))
3707 (sort strings #'string<)))
3708
3709 (defun format-completion-result (string internal-p package-name)
3710 (let ((result (untokenize-symbol package-name internal-p string)))
3711 ;; We return the length of the possibly added prefix as second value.
3712 (values result (search string result))))
3713
3714
3715 (defun completion-output-case-converter (input &optional with-escaping-p)
3716 "Return a function to convert strings for the completion output.
3717 INPUT is used to guess the preferred case."
3718 (ecase (readtable-case *readtable*)
3719 (:upcase (cond ((or with-escaping-p
3720 (not (some #'lower-case-p input)))
3721 #'identity)
3722 (t #'string-downcase)))
3723 (:invert (lambda (output)
3724 (multiple-value-bind (lower upper) (determine-case output)
3725 (cond ((and lower upper) output)
3726 (lower (string-upcase output))
3727 (upper (string-downcase output))
3728 (t output)))))
3729 (:downcase (cond ((or with-escaping-p
3730 (not (some #'upper-case-p input)))
3731 #'identity)
3732 (t #'string-upcase)))
3733 (:preserve #'identity)))
3734
3735 (defun completion-output-package-converter (input)
3736 "Return a function to convert strings for the completion output.
3737 INPUT is used to guess the preferred case."
3738 (completion-output-case-converter input))
3739
3740 (defun completion-output-symbol-converter (input)
3741 "Return a function to convert strings for the completion output.
3742 INPUT is used to guess the preferred case. Escape symbols when needed."
3743 (let ((case-converter (completion-output-case-converter input))
3744 (case-converter-with-escaping (completion-output-case-converter input t)))
3745 (lambda (str)
3746 (if (or (multiple-value-bind (lowercase uppercase)
3747 (determine-case str)
3748 ;; In these readtable cases, symbols with letters from
3749 ;; the wrong case need escaping
3750 (case (readtable-case *readtable*)
3751 (:upcase lowercase)
3752 (:downcase uppercase)
3753 (t nil)))
3754 (some (lambda (el)
3755 (or (member el '(#\: #\Space #\Newline #\Tab))
3756 (multiple-value-bind (macrofun nonterminating)
3757 (get-macro-character el)
3758 (and macrofun
3759 (not nonterminating)))))
3760 str))
3761 (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
3762 (funcall case-converter str)))))
3763
3764
3765 (defun determine-case (string)
3766 "Return two booleans LOWER and UPPER indicating whether STRING
3767 contains lower or upper case characters."
3768 (values (some #'lower-case-p string)
3769 (some #'upper-case-p string)))
3770
3771
3772 ;;;;; Compound-prefix matching
3773
3774 (defun make-compound-prefix-matcher (delimeter &key (test #'char=))
3775 "Returns a matching function that takes a `prefix' and a
3776 `target' string and which returns T if `prefix' is a
3777 compound-prefix of `target', and otherwise NIL.
3778
3779 Viewing each of `prefix' and `target' as a series of substrings
3780 delimited by DELIMETER, if each substring of `prefix' is a prefix
3781 of the corresponding substring in `target' then we call `prefix'
3782 a compound-prefix of `target'."
3783 (lambda (prefix target)
3784 (declare (type simple-string prefix target))
3785 (loop for ch across prefix
3786 with tpos = 0
3787 always (and (< tpos (length target))
3788 (if (char= ch delimeter)
3789 (setf tpos (position #\- target :start tpos))
3790 (funcall test ch (aref target tpos))))
3791 do (incf tpos))))
3792
3793 (defun compound-prefix-match (prefix target)
3794 "Examples:
3795 \(compound-prefix-match \"foo\" \"foobar\") => t
3796 \(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
3797 \(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL
3798 "
3799 (funcall (make-compound-prefix-matcher #\-) prefix target))
3800
3801 (defun prefix-match-p (prefix string)
3802 "Return true if PREFIX is a prefix of STRING."
3803 (not (mismatch prefix string :end2 (min