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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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