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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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