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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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