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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.779 - (hide annotations)
Sat Dec 10 12:33:52 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.778: +1 -152 lines
* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.
1 heller 1.418 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 dbarlow 1.27 ;;;
3 lgorrie 1.194 ;;; This code has been placed in the Public Domain. All warranties
4     ;;; are disclaimed.
5 dbarlow 1.27 ;;;
6 lgorrie 1.194 ;;;; swank.lisp
7 dbarlow 1.27 ;;;
8 lgorrie 1.194 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9     ;;; code in this file is purely portable Common Lisp. We do require a
10     ;;; smattering of non-portable functions in order to write the server,
11     ;;; so we have defined them in `swank-backend.lisp' and implemented
12     ;;; them separately for each Lisp implementation. These extensions are
13     ;;; available to us here via the `SWANK-BACKEND' package.
14 heller 1.26
15 heller 1.58 (defpackage :swank
16 tnorderhaug 1.684 (:use :cl :swank-backend :swank-match :swank-rpc)
17 lgorrie 1.152 (:export #:startup-multiprocessing
18 heller 1.138 #:start-server
19 heller 1.178 #:create-server
20 heller 1.521 #:stop-server
21     #:restart-server
22 heller 1.138 #:ed-in-emacs
23 nsiivola 1.426 #:inspect-in-emacs
24 lgorrie 1.157 #:print-indentation-lossage
25 heller 1.561 #:invoke-slime-debugger
26 lgorrie 1.177 #:swank-debugger-hook
27 heller 1.528 #:emacs-inspect
28     ;;#:inspect-slot-for-emacs
29 lgorrie 1.194 ;; These are user-configurable variables:
30 lgorrie 1.152 #:*communication-style*
31 mbaringer 1.413 #:*dont-close*
32 heller 1.639 #:*fasl-pathname-function*
33 lgorrie 1.152 #:*log-events*
34 lgorrie 1.283 #:*log-output*
35 lgorrie 1.152 #:*use-dedicated-output-stream*
36 mbaringer 1.313 #:*dedicated-output-stream-port*
37 lgorrie 1.157 #:*configure-emacs-indentation*
38 heller 1.189 #:*readtable-alist*
39 lgorrie 1.197 #:*globally-redirect-io*
40 lgorrie 1.223 #:*global-debugger*
41 trittweiler 1.676 #:*sldb-quit-restart*
42 nsiivola 1.599 #:*backtrace-printer-bindings*
43     #:*default-worker-thread-bindings*
44     #:*macroexpand-printer-bindings*
45 heller 1.282 #:*swank-pprint-bindings*
46 lgorrie 1.300 #:*record-repl-results*
47 nsiivola 1.600 #:*inspector-verbose*
48 trittweiler 1.674 ;; This is SETFable.
49     #:debug-on-swank-error
50 lgorrie 1.194 ;; These are re-exported directly from the backend:
51 lgorrie 1.209 #:buffer-first-change
52 heller 1.649 #:frame-source-location
53 trittweiler 1.704 #:gdb-initial-commands
54 wjenkner 1.146 #:restart-frame
55 trittweiler 1.548 #:sldb-step
56 heller 1.240 #:sldb-break
57     #:sldb-break-on-return
58 heller 1.142 #:profiled-functions
59     #:profile-report
60     #:profile-reset
61     #:unprofile-all
62     #:profile-package
63 heller 1.189 #:default-directory
64 heller 1.150 #:set-default-directory
65 sboukarev 1.723 #:quit-lisp
66 sboukarev 1.736 #:eval-for-emacs
67 sboukarev 1.752 #:eval-in-emacs
68     #:y-or-n-p-in-emacs))
69 dbarlow 1.27
70 heller 1.265 (in-package :swank)
71 heller 1.189
72 heller 1.343
73 lgorrie 1.194 ;;;; Top-level variables, constants, macros
74    
75     (defconstant cl-package (find-package :cl)
76     "The COMMON-LISP package.")
77    
78     (defconstant keyword-package (find-package :keyword)
79     "The KEYWORD package.")
80 heller 1.31
81 lgorrie 1.194 (defconstant default-server-port 4005
82     "The default TCP port for the server (when started manually).")
83 dbarlow 1.28
84     (defvar *swank-debug-p* t
85     "When true, print extra debugging information.")
86    
87 heller 1.574 (defvar *backtrace-pprint-dispatch-table*
88     (let ((table (copy-pprint-dispatch nil)))
89 heller 1.642 (flet ((print-string (stream string)
90 heller 1.594 (cond (*print-escape*
91 heller 1.642 (escape-string string stream
92     :map '((#\" . "\\\"")
93     (#\\ . "\\\\")
94     (#\newline . "\\n")
95     (#\return . "\\r"))))
96 heller 1.602 (t (write-string string stream)))))
97 heller 1.642 (set-pprint-dispatch 'string #'print-string 0 table)
98 heller 1.574 table)))
99    
100 heller 1.520 (defvar *backtrace-printer-bindings*
101 heller 1.574 `((*print-pretty* . t)
102     (*print-readably* . nil)
103 heller 1.520 (*print-level* . 4)
104 heller 1.574 (*print-length* . 6)
105     (*print-lines* . 1)
106     (*print-right-margin* . 200)
107     (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
108 heller 1.520 "Pretter settings for printing backtraces.")
109    
110 heller 1.282 (defvar *default-worker-thread-bindings* '()
111     "An alist to initialize dynamic variables in worker threads.
112     The list has the form ((VAR . VALUE) ...). Each variable VAR will be
113     bound to the corresponding VALUE.")
114    
115     (defun call-with-bindings (alist fun)
116     "Call FUN with variables bound according to ALIST.
117     ALIST is a list of the form ((VAR . VAL) ...)."
118 heller 1.735 (if (null alist)
119     (funcall fun)
120     (let* ((rlist (reverse alist))
121     (vars (mapcar #'car rlist))
122     (vals (mapcar #'cdr rlist)))
123     (progv vars vals
124     (funcall fun)))))
125 heller 1.282
126 heller 1.288 (defmacro with-bindings (alist &body body)
127     "See `call-with-bindings'."
128     `(call-with-bindings ,alist (lambda () ,@body)))
129    
130 lgorrie 1.194 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
131     ;;; RPC.
132 heller 1.47
133 lgorrie 1.157 (defmacro defslimefun (name arglist &body rest)
134 lgorrie 1.194 "A DEFUN for functions that Emacs can call by RPC."
135 heller 1.47 `(progn
136 heller 1.250 (defun ,name ,arglist ,@rest)
137     ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
138     (eval-when (:compile-toplevel :load-toplevel :execute)
139 heller 1.568 (export ',name (symbol-package ',name)))))
140 heller 1.47
141 heller 1.113 (defun missing-arg ()
142 lgorrie 1.194 "A function that the compiler knows will never to return a value.
143     You can use (MISSING-ARG) as the initform for defstruct slots that
144     must always be supplied. This way the :TYPE slot option need not
145     include some arbitrary initial value like NIL."
146 heller 1.113 (error "A required &KEY or &OPTIONAL argument was not supplied."))
147    
148 heller 1.343
149 lgorrie 1.197 ;;;; Hooks
150     ;;;
151     ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
152     ;;; simple indirection. The interface is more CLish than the Emacs
153     ;;; Lisp one.
154    
155     (defmacro add-hook (place function)
156 heller 1.222 "Add FUNCTION to the list of values on PLACE."
157 lgorrie 1.197 `(pushnew ,function ,place))
158    
159     (defun run-hook (functions &rest arguments)
160     "Call each of FUNCTIONS with ARGUMENTS."
161     (dolist (function functions)
162     (apply function arguments)))
163    
164     (defvar *new-connection-hook* '()
165     "This hook is run each time a connection is established.
166     The connection structure is given as the argument.
167     Backend code should treat the connection structure as opaque.")
168    
169     (defvar *connection-closed-hook* '()
170     "This hook is run when a connection is closed.
171     The connection as passed as an argument.
172     Backend code should treat the connection structure as opaque.")
173    
174     (defvar *pre-reply-hook* '()
175     "Hook run (without arguments) immediately before replying to an RPC.")
176    
177 heller 1.405 (defvar *after-init-hook* '()
178     "Hook run after user init files are loaded.")
179    
180 heller 1.343
181 lgorrie 1.96 ;;;; Connections
182     ;;;
183     ;;; Connection structures represent the network connections between
184     ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
185     ;;; streams that redirect to Emacs, and optionally a second socket
186 heller 1.628 ;;; used solely to pipe user-output to Emacs (an optimization). This
187     ;;; is also the place where we keep everything that needs to be
188     ;;; freed/closed/killed when we disconnect.
189 lgorrie 1.90
190     (defstruct (connection
191 trittweiler 1.700 (:constructor %make-connection)
192 lgorrie 1.215 (:conc-name connection.)
193     (:print-function print-connection))
194 heller 1.707 ;; The listening socket. (usually closed)
195 trittweiler 1.700 (socket (missing-arg) :type t :read-only t)
196 heller 1.707 ;; Character I/O stream of socket connection. Read-only to avoid
197     ;; race conditions during initialization.
198     (socket-io (missing-arg) :type stream :read-only t)
199 lgorrie 1.96 ;; Optional dedicated output socket (backending `user-output' slot).
200     ;; Has a slot so that it can be closed with the connection.
201     (dedicated-output nil :type (or stream null))
202 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
203 lgorrie 1.96 ;; redirected to Emacs.
204     (user-input nil :type (or stream null))
205     (user-output nil :type (or stream null))
206 heller 1.112 (user-io nil :type (or stream null))
207 heller 1.615 ;; Bindings used for this connection (usually streams)
208 heller 1.779 (env '() :type list)
209 mkoeppe 1.499 ;; A stream that we use for *trace-output*; if nil, we user user-output.
210     (trace-output nil :type (or stream null))
211 mkoeppe 1.445 ;; A stream where we send REPL results.
212     (repl-results nil :type (or stream null))
213 lgorrie 1.194 ;; Cache of macro-indentation information that has been sent to Emacs.
214     ;; This is used for preparing deltas to update Emacs's knowledge.
215     ;; Maps: symbol -> indentation-specification
216 lgorrie 1.157 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
217 lgorrie 1.194 ;; The list of packages represented in the cache:
218 heller 1.261 (indentation-cache-packages '())
219     ;; The communication style used.
220     (communication-style nil :type (member nil :spawn :sigio :fd-handler))
221 heller 1.771 )
222    
223     (defun print-connection (conn stream depth)
224     (declare (ignore depth))
225     (print-unreadable-object (conn stream :type t :identity t)))
226    
227     (defstruct (singlethreaded-connection (:include connection)
228     (:conc-name sconn.))
229 heller 1.566 ;; The SIGINT handler we should restore when the connection is
230     ;; closed.
231 heller 1.775 saved-sigint-handler
232     ;; A queue of events. Not all events can be processed in order and
233     ;; we need a place to stored them.
234     (event-queue '() :type list)
235     ;; A counter that is incremented whenever an event is added to the
236     ;; queue. This is used to detected modifications to the event queue
237     ;; by interrupts. The counter wraps around.
238     (events-enqueued 0 :type fixnum))
239 lgorrie 1.215
240 heller 1.771 (defstruct (multithreaded-connection (:include connection)
241     (:conc-name mconn.))
242     ;; In multithreaded systems we delegate certain tasks to specific
243     ;; threads. The `reader-thread' is responsible for reading network
244     ;; requests from Emacs and sending them to the `control-thread'; the
245     ;; `control-thread' is responsible for dispatching requests to the
246     ;; threads that should handle them; the `repl-thread' is the one
247     ;; that evaluates REPL expressions. The control thread dispatches
248     ;; all REPL evaluations to the REPL thread and for other requests it
249     ;; spawns new threads.
250     reader-thread
251     control-thread
252     repl-thread
253 heller 1.777 auto-flush-thread
254     indentation-cache-thread
255 heller 1.778 ;; List of threads that are currently processing requests. We use
256     ;; this to find the newest/current thread for an interrupt. In the
257     ;; future we may store here (thread . request-tag) pairs so that we
258     ;; can interrupt specific requests.
259     (active-threads '() :type list)
260 heller 1.777 )
261 heller 1.115
262 lgorrie 1.157 (defvar *connections* '()
263     "List of all active connections, with the most recent at the front.")
264    
265 heller 1.112 (defvar *emacs-connection* nil
266 lgorrie 1.194 "The connection to Emacs currently in use.")
267 lgorrie 1.96
268 lgorrie 1.157 (defun default-connection ()
269     "Return the 'default' Emacs connection.
270 lgorrie 1.194 This connection can be used to talk with Emacs when no specific
271     connection is in use, i.e. *EMACS-CONNECTION* is NIL.
272    
273 lgorrie 1.157 The default connection is defined (quite arbitrarily) as the most
274     recently established one."
275 lgorrie 1.194 (first *connections*))
276 lgorrie 1.157
277 heller 1.763 (defun make-connection (socket stream style)
278 heller 1.771 (let ((conn (funcall (ecase style
279     (:spawn
280     #'make-multithreaded-connection)
281     ((:sigio nil :fd-handler)
282     #'make-singlethreaded-connection))
283     :socket socket
284     :socket-io stream
285     :communication-style style)))
286     (run-hook *new-connection-hook* conn)
287     (push conn *connections*)
288     conn))
289 heller 1.707
290 heller 1.587 (defslimefun ping (tag)
291     tag)
292    
293 heller 1.556 (defun safe-backtrace ()
294     (ignore-errors
295     (call-with-debugging-environment
296     (lambda () (backtrace 0 nil)))))
297 lgorrie 1.90
298 heller 1.716 (define-condition swank-error (error)
299     ((backtrace :initarg :backtrace :reader swank-error.backtrace)
300     (condition :initarg :condition :reader swank-error.condition))
301     (:report (lambda (c s) (princ (swank-error.condition c) s)))
302     (:documentation "Condition which carries a backtrace."))
303 heller 1.708
304 heller 1.716 (defun make-swank-error (condition &optional (backtrace (safe-backtrace)))
305     (make-condition 'swank-error :condition condition :backtrace backtrace))
306 heller 1.708
307 trittweiler 1.674 (defvar *debug-on-swank-protocol-error* nil
308     "When non-nil invoke the system debugger on errors that were
309     signalled during decoding/encoding the wire protocol. Do not set this
310     to T unless you want to debug swank internals.")
311 heller 1.563
312 heller 1.716 (defmacro with-swank-error-handler ((connection) &body body)
313     "Close the connection on internal `swank-error's."
314     (let ((conn (gensym)))
315     `(let ((,conn ,connection))
316 heller 1.563 (handler-case
317 heller 1.716 (handler-bind ((swank-error
318 heller 1.563 (lambda (condition)
319 trittweiler 1.674 (when *debug-on-swank-protocol-error*
320 heller 1.563 (invoke-default-debugger condition)))))
321 heller 1.716 (progn . ,body))
322     (swank-error (condition)
323     (close-connection ,conn
324     (swank-error.condition condition)
325     (swank-error.backtrace condition)))))))
326 trittweiler 1.648
327 heller 1.563 (defmacro with-panic-handler ((connection) &body body)
328 heller 1.716 "Close the connection on unhandled `serious-condition's."
329     (let ((conn (gensym)))
330     `(let ((,conn ,connection))
331 heller 1.563 (handler-bind ((serious-condition
332     (lambda (condition)
333 heller 1.716 (close-connection ,conn condition (safe-backtrace)))))
334 heller 1.563 . ,body))))
335    
336 lgorrie 1.197 (add-hook *new-connection-hook* 'notify-backend-of-connection)
337     (defun notify-backend-of-connection (connection)
338 heller 1.261 (declare (ignore connection))
339     (emacs-connected))
340 lgorrie 1.197
341 heller 1.343
342 trittweiler 1.505 ;;;; Utilities
343    
344 heller 1.708
345     ;;;;; Logging
346    
347     (defvar *swank-io-package*
348     (let ((package (make-package :swank-io-package :use '())))
349     (import '(nil t quote) package)
350     package))
351    
352     (defvar *log-events* nil)
353     (defvar *log-output* nil) ; should be nil for image dumpers
354    
355     (defun init-log-output ()
356     (unless *log-output*
357     (setq *log-output* (real-output-stream *error-output*))))
358    
359 trittweiler 1.714 (add-hook *after-init-hook* 'init-log-output)
360    
361 heller 1.708 (defun real-input-stream (stream)
362     (typecase stream
363     (synonym-stream
364     (real-input-stream (symbol-value (synonym-stream-symbol stream))))
365     (two-way-stream
366     (real-input-stream (two-way-stream-input-stream stream)))
367     (t stream)))
368    
369     (defun real-output-stream (stream)
370     (typecase stream
371     (synonym-stream
372     (real-output-stream (symbol-value (synonym-stream-symbol stream))))
373     (two-way-stream
374     (real-output-stream (two-way-stream-output-stream stream)))
375     (t stream)))
376    
377     (defvar *event-history* (make-array 40 :initial-element nil)
378     "A ring buffer to record events for better error messages.")
379     (defvar *event-history-index* 0)
380     (defvar *enable-event-history* t)
381    
382     (defun log-event (format-string &rest args)
383     "Write a message to *terminal-io* when *log-events* is non-nil.
384     Useful for low level debugging."
385     (with-standard-io-syntax
386     (let ((*print-readably* nil)
387     (*print-pretty* nil)
388     (*package* *swank-io-package*))
389     (when *enable-event-history*
390     (setf (aref *event-history* *event-history-index*)
391     (format nil "~?" format-string args))
392     (setf *event-history-index*
393     (mod (1+ *event-history-index*) (length *event-history*))))
394     (when *log-events*
395     (write-string (escape-non-ascii (format nil "~?" format-string args))
396     *log-output*)
397     (force-output *log-output*)))))
398    
399     (defun event-history-to-list ()
400     "Return the list of events (older events first)."
401     (let ((arr *event-history*)
402     (idx *event-history-index*))
403     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
404    
405     (defun clear-event-history ()
406     (fill *event-history* nil)
407     (setq *event-history-index* 0))
408    
409     (defun dump-event-history (stream)
410     (dolist (e (event-history-to-list))
411     (dump-event e stream)))
412    
413     (defun dump-event (event stream)
414     (cond ((stringp event)
415     (write-string (escape-non-ascii event) stream))
416     ((null event))
417     (t
418     (write-string
419     (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
420     stream))))
421    
422     (defun escape-non-ascii (string)
423     "Return a string like STRING but with non-ascii chars escaped."
424     (cond ((ascii-string-p string) string)
425     (t (with-output-to-string (out)
426     (loop for c across string do
427     (cond ((ascii-char-p c) (write-char c out))
428     (t (format out "\\x~4,'0X" (char-code c)))))))))
429    
430     (defun ascii-string-p (o)
431     (and (stringp o)
432     (every #'ascii-char-p o)))
433    
434     (defun ascii-char-p (c)
435     (<= (char-code c) 127))
436    
437    
438 trittweiler 1.505 ;;;;; Helper macros
439 lgorrie 1.96
440 heller 1.708 (defmacro destructure-case (value &rest patterns)
441     "Dispatch VALUE to one of PATTERNS.
442     A cross between `case' and `destructuring-bind'.
443     The pattern syntax is:
444     ((HEAD . ARGS) . BODY)
445     The list of patterns is searched for a HEAD `eq' to the car of
446     VALUE. If one is found, the BODY is executed with ARGS bound to the
447     corresponding values in the CDR of VALUE."
448     (let ((operator (gensym "op-"))
449     (operands (gensym "rand-"))
450     (tmp (gensym "tmp-")))
451     `(let* ((,tmp ,value)
452     (,operator (car ,tmp))
453     (,operands (cdr ,tmp)))
454     (case ,operator
455     ,@(loop for (pattern . body) in patterns collect
456     (if (eq pattern t)
457     `(t ,@body)
458     (destructuring-bind (op &rest rands) pattern
459     `(,op (destructuring-bind ,rands ,operands
460     ,@body)))))
461     ,@(if (eq (caar (last patterns)) t)
462     '()
463     `((t (error "destructure-case failed: ~S" ,tmp))))))))
464    
465 heller 1.769
466     ;;;; Interrupt handling
467    
468 heller 1.776 ;; Usually we'd like to enter the debugger when an interrupt happens.
469     ;; But for some operations, in particular send&receive, it's crucial
470     ;; that those are not interrupted when the mailbox is in an
471     ;; inconsistent/locked state. Obviously, if send&receive don't work we
472     ;; can't communicate and the debugger will not work. To solve that
473     ;; problem, we try to handle interrupts only at certain safe-points.
474     ;;
475     ;; Whenever an interrupt happens we call the function
476     ;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the
477     ;; debugger, but if interrupts are disabled the interrupt is put in a
478     ;; queue for later processing. At safe-points, we call
479     ;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the
480     ;; debugger if needed.
481     ;;
482     ;; The queue for interrupts is stored in a thread local variable.
483     ;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows
484     ;; interrupts, i.e. the debugger is entered immediately. When we call
485     ;; "user code" or non-problematic code we allow interrupts. When
486     ;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we
487     ;; switch from "user code" to more delicate operations we need to
488     ;; disable interrupts. In particular, interrupts should be disabled
489     ;; for SEND and RECEIVE-IF.
490 heller 1.769
491 heller 1.588 ;; If true execute interrupts, otherwise queue them.
492     ;; Note: `with-connection' binds *pending-slime-interrupts*.
493 heller 1.566 (defvar *slime-interrupts-enabled*)
494    
495 heller 1.588 (defmacro with-interrupts-enabled% (flag body)
496 heller 1.566 `(progn
497 heller 1.709 ,@(if flag '((check-slime-interrupts)))
498 heller 1.587 (multiple-value-prog1
499 heller 1.588 (let ((*slime-interrupts-enabled* ,flag))
500 heller 1.587 ,@body)
501 heller 1.709 ,@(if flag '((check-slime-interrupts))))))
502 heller 1.566
503 heller 1.588 (defmacro with-slime-interrupts (&body body)
504     `(with-interrupts-enabled% t ,body))
505    
506 heller 1.566 (defmacro without-slime-interrupts (&body body)
507 heller 1.588 `(with-interrupts-enabled% nil ,body))
508 heller 1.566
509     (defun invoke-or-queue-interrupt (function)
510 heller 1.619 (log-event "invoke-or-queue-interrupt: ~a~%" function)
511 heller 1.566 (cond ((not (boundp '*slime-interrupts-enabled*))
512     (without-slime-interrupts
513     (funcall function)))
514     (*slime-interrupts-enabled*
515 heller 1.619 (log-event "interrupts-enabled~%")
516 heller 1.566 (funcall function))
517     (t
518 heller 1.587 (setq *pending-slime-interrupts*
519     (nconc *pending-slime-interrupts*
520     (list function)))
521     (cond ((cdr *pending-slime-interrupts*)
522 heller 1.619 (log-event "too many queued interrupts~%")
523 heller 1.709 (with-simple-restart (continue "Continue from interrupt")
524     (handler-bind ((serious-condition #'invoke-slime-debugger))
525     (check-slime-interrupts))))
526 heller 1.587 (t
527 heller 1.709 (log-event "queue-interrupt: ~a~%" function)
528 heller 1.634 (when *interrupt-queued-handler*
529     (funcall *interrupt-queued-handler*)))))))
530 heller 1.566
531    
532 heller 1.769 ;;; FIXME: poor name?
533 lgorrie 1.174 (defmacro with-io-redirection ((connection) &body body)
534 heller 1.615 "Execute BODY I/O redirection to CONNECTION. "
535     `(with-bindings (connection.env ,connection)
536     . ,body))
537 heller 1.773
538     ;; Thread local variable used for flow-control.
539 heller 1.776 ;; It's bound by `with-connection'.
540 heller 1.773 (defvar *send-counter*)
541    
542 heller 1.153 (defmacro with-connection ((connection) &body body)
543     "Execute BODY in the context of CONNECTION."
544 heller 1.718 `(let ((connection ,connection)
545     (function (lambda () . ,body)))
546     (if (eq *emacs-connection* connection)
547     (funcall function)
548     (let ((*emacs-connection* connection)
549 heller 1.773 (*pending-slime-interrupts* '())
550     (*send-counter* 0))
551 heller 1.718 (without-slime-interrupts
552     (with-swank-error-handler (connection)
553     (with-io-redirection (connection)
554 heller 1.769 (call-with-debugger-hook #'swank-debugger-hook
555     function))))))))
556 lgorrie 1.96
557 trittweiler 1.584 (defun call-with-retry-restart (msg thunk)
558 heller 1.605 (loop (with-simple-restart (retry "~a" msg)
559     (return (funcall thunk)))))
560 trittweiler 1.584
561     (defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
562     (check-type msg string)
563 heller 1.720 `(call-with-retry-restart ,msg (lambda () ,@body)))
564 trittweiler 1.584
565 heller 1.556 (defmacro with-struct* ((conc-name get obj) &body body)
566     (let ((var (gensym)))
567     `(let ((,var ,obj))
568     (macrolet ((,get (slot)
569     (let ((getter (intern (concatenate 'string
570     ',(string conc-name)
571     (string slot))
572     (symbol-package ',conc-name))))
573     `(,getter ,',var))))
574     ,@body))))
575    
576 trittweiler 1.676 (defmacro define-special (name doc)
577     "Define a special variable NAME with doc string DOC.
578     This is like defvar, but NAME will not be initialized."
579     `(progn
580     (defvar ,name)
581     (setf (documentation ',name 'variable) ,doc)))
582 trittweiler 1.584
583 trittweiler 1.505
584 trittweiler 1.714 ;;;;; Misc
585 trittweiler 1.505
586 trittweiler 1.714 (defun use-threads-p ()
587     (eq (connection.communication-style *emacs-connection*) :spawn))
588    
589     (defun current-thread-id ()
590     (thread-id (current-thread)))
591    
592     (declaim (inline ensure-list))
593     (defun ensure-list (thing)
594     (if (listp thing) thing (list thing)))
595 heller 1.560
596 trittweiler 1.505
597     ;;;;; Symbols
598    
599 heller 1.769 ;; FIXME: this docstring is more confusing than helpful.
600 trittweiler 1.505 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
601     "Returns one of
602    
603     :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
604    
605     :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
606    
607     :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
608     but is not _present_ in PACKAGE,
609    
610     or NIL if SYMBOL is not _accessible_ in PACKAGE.
611    
612    
613     Be aware not to get confused with :INTERNAL and how \"internal
614     symbols\" are defined in the spec; there is a slight mismatch of
615     definition with the Spec and what's commonly meant when talking
616     about internal symbols most times. As the spec says:
617    
618     In a package P, a symbol S is
619    
620     _accessible_ if S is either _present_ in P itself or was
621     inherited from another package Q (which implies
622     that S is _external_ in Q.)
623    
624     You can check that with: (AND (SYMBOL-STATUS S P) T)
625    
626    
627     _present_ if either P is the /home package/ of S or S has been
628     imported into P or exported from P by IMPORT, or
629     EXPORT respectively.
630    
631     Or more simply, if S is not _inherited_.
632    
633     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
634     (AND STATUS
635     (NOT (EQ STATUS :INHERITED))))
636    
637    
638     _external_ if S is going to be inherited into any package that
639     /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
640     DEFPACKAGE.
641    
642     Note that _external_ implies _present_, since to
643     make a symbol _external_, you'd have to use EXPORT
644     which will automatically make the symbol _present_.
645    
646     You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
647    
648    
649     _internal_ if S is _accessible_ but not _external_.
650    
651     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
652     (AND STATUS
653     (NOT (EQ STATUS :EXTERNAL))))
654    
655    
656     Notice that this is *different* to
657     (EQ (SYMBOL-STATUS S P) :INTERNAL)
658     because what the spec considers _internal_ is split up into two
659     explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
660     CL:FIND-SYMBOL does.
661    
662     The rationale is that most times when you speak about \"internal\"
663     symbols, you're actually not including the symbols inherited
664     from other packages, but only about the symbols directly specific
665     to the package in question.
666     "
667     (when package ; may be NIL when symbol is completely uninterned.
668     (check-type symbol symbol) (check-type package package)
669     (multiple-value-bind (present-symbol status)
670     (find-symbol (symbol-name symbol) package)
671     (and (eq symbol present-symbol) status))))
672    
673     (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
674     "True if SYMBOL is external in PACKAGE.
675     If PACKAGE is not specified, the home package of SYMBOL is used."
676     (eq (symbol-status symbol package) :external))
677    
678 heller 1.343
679 lgorrie 1.90 ;;;; TCP Server
680 dbarlow 1.28
681 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
682 heller 1.79
683 mbaringer 1.413 (defvar *dont-close* nil
684     "Default value of :dont-close argument to start-server and
685     create-server.")
686    
687 heller 1.521 (defvar *listener-sockets* nil
688     "A property list of lists containing style, socket pairs used
689     by swank server listeners, keyed on socket port number. They
690     are used to close sockets on server shutdown or restart.")
691    
692 heller 1.264 (defun start-server (port-file &key (style *communication-style*)
693 heller 1.763 (dont-close *dont-close*))
694 lgorrie 1.212 "Start the server and write the listen port number to PORT-FILE.
695     This is the entry point for Emacs."
696 heller 1.681 (setup-server 0
697     (lambda (port) (announce-server-port port-file port))
698 heller 1.764 style dont-close nil))
699 heller 1.178
700 lgorrie 1.194 (defun create-server (&key (port default-server-port)
701 heller 1.763 (style *communication-style*)
702 heller 1.764 (dont-close *dont-close*)
703     backlog)
704 lgorrie 1.212 "Start a SWANK server on PORT running in STYLE.
705     If DONT-CLOSE is true then the listen socket will accept multiple
706     connections, otherwise it will be closed after the first."
707 trittweiler 1.696 (setup-server port #'simple-announce-function
708 heller 1.764 style dont-close backlog))
709 heller 1.418
710     (defun find-external-format-or-lose (coding-system)
711     (or (find-external-format coding-system)
712     (error "Unsupported coding system: ~s" coding-system)))
713 heller 1.178
714 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
715    
716 heller 1.764 (defun setup-server (port announce-fn style dont-close backlog)
717 heller 1.111 (declare (type function announce-fn))
718 heller 1.560 (init-log-output)
719 heller 1.764 (let* ((socket (create-socket *loopback-interface* port :backlog backlog))
720 heller 1.707 (local-port (local-port socket)))
721 heller 1.521 (funcall announce-fn local-port)
722 heller 1.264 (flet ((serve ()
723 heller 1.763 (accept-connections socket style dont-close)))
724 heller 1.264 (ecase style
725     (:spawn
726 heller 1.516 (initialize-multiprocessing
727     (lambda ()
728 sboukarev 1.725 (spawn (lambda ()
729 heller 1.537 (cond ((not dont-close) (serve))
730     (t (loop (ignore-errors (serve))))))
731     :name (cat "Swank " (princ-to-string port))))))
732 heller 1.264 ((:fd-handler :sigio)
733     (add-fd-handler socket (lambda () (serve))))
734 heller 1.349 ((nil) (loop do (serve) while dont-close)))
735 heller 1.521 (setf (getf *listener-sockets* port) (list style socket))
736     local-port)))
737    
738     (defun stop-server (port)
739     "Stop server running on PORT."
740     (let* ((socket-description (getf *listener-sockets* port))
741     (style (first socket-description))
742     (socket (second socket-description)))
743     (ecase style
744     (:spawn
745     (let ((thread-position
746     (position-if
747     (lambda (x)
748 heller 1.613 (string-equal (second x)
749     (cat "Swank " (princ-to-string port))))
750 heller 1.521 (list-threads))))
751     (when thread-position
752 sboukarev 1.663 (kill-nth-thread (1- thread-position))
753 heller 1.521 (close-socket socket)
754     (remf *listener-sockets* port))))
755     ((:fd-handler :sigio)
756     (remove-fd-handlers socket)
757     (close-socket socket)
758     (remf *listener-sockets* port)))))
759    
760     (defun restart-server (&key (port default-server-port)
761     (style *communication-style*)
762 heller 1.763 (dont-close *dont-close*))
763 heller 1.521 "Stop the server listening on PORT, then start a new SWANK server
764     on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
765     will accept multiple connections, otherwise it will be closed after the
766     first."
767     (stop-server port)
768     (sleep 5)
769 heller 1.763 (create-server :port port :style style :dont-close dont-close))
770 heller 1.521
771 heller 1.763 (defun accept-connections (socket style dont-close)
772 sboukarev 1.759 (let ((client (unwind-protect
773     (accept-connection socket :external-format nil
774     :buffering t)
775     (unless dont-close
776     (close-socket socket)))))
777 heller 1.707 (authenticate-client client)
778 heller 1.763 (serve-requests (make-connection socket client style))))
779 heller 1.707
780     (defun authenticate-client (stream)
781     (let ((secret (slime-secret)))
782     (when secret
783     (set-stream-timeout stream 20)
784     (let ((first-val (decode-message stream)))
785     (unless (and (stringp first-val) (string= first-val secret))
786     (error "Incoming connection doesn't know the password.")))
787     (set-stream-timeout stream nil))))
788 lgorrie 1.296
789     (defun slime-secret ()
790     "Finds the magic secret from the user's home directory. Returns nil
791     if the file doesn't exist; otherwise the first line of the file."
792     (with-open-file (in
793 lgorrie 1.297 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
794 lgorrie 1.296 :if-does-not-exist nil)
795     (and in (read-line in nil ""))))
796    
797 heller 1.112 (defun serve-requests (connection)
798 heller 1.115 "Read and process all requests on connections."
799 heller 1.771 (etypecase connection
800     (multithreaded-connection
801     (spawn-threads-for-connection connection))
802     (singlethreaded-connection
803     (ecase (connection.communication-style connection)
804     ((nil) (simple-serve-requests connection))
805     (:sigio (install-sigio-handler connection))
806     (:fd-handler (install-fd-handler connection))))))
807    
808     (defun stop-serving-requests (connection)
809     (etypecase connection
810     (multithreaded-connection
811     (cleanup-connection-threads connection))
812     (singlethreaded-connection
813     (ecase (connection.communication-style connection)
814     ((nil))
815     (:sigio (deinstall-sigio-handler connection))
816     (:fd-handler (deinstall-fd-handler connection))))))
817 heller 1.112
818 heller 1.94 (defun announce-server-port (file port)
819     (with-open-file (s file
820     :direction :output
821 lgorrie 1.296 :if-exists :error
822 heller 1.94 :if-does-not-exist :create)
823     (format s "~S~%" port))
824     (simple-announce-function port))
825 lgorrie 1.90
826 heller 1.115 (defun simple-announce-function (port)
827     (when *swank-debug-p*
828 heller 1.511 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
829     (force-output *log-output*)))
830 heller 1.115
831 heller 1.708
832     ;;;;; Event Decoding/Encoding
833    
834     (defun decode-message (stream)
835     "Read an S-expression from STREAM using the SLIME protocol."
836     (log-event "decode-message~%")
837     (without-slime-interrupts
838 heller 1.716 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
839 heller 1.708 (handler-case (read-message stream *swank-io-package*)
840     (swank-reader-error (c)
841     `(:reader-error ,(swank-reader-error.packet c)
842     ,(swank-reader-error.cause c)))))))
843    
844     (defun encode-message (message stream)
845     "Write an S-expression to STREAM using the SLIME protocol."
846     (log-event "encode-message~%")
847     (without-slime-interrupts
848 heller 1.716 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
849 heller 1.708 (write-message message *swank-io-package* stream))))
850    
851    
852     ;;;;; Event Processing
853 heller 1.716
854 heller 1.718 (defvar *sldb-quit-restart* nil
855     "The restart that will be invoked when the user calls sldb-quit.")
856 heller 1.597
857     ;; Establish a top-level restart and execute BODY.
858     ;; Execute K if the restart is invoked.
859     (defmacro with-top-level-restart ((connection k) &body body)
860     `(with-connection (,connection)
861 trittweiler 1.704 (restart-case
862 heller 1.717 (let ((*sldb-quit-restart* (find-restart 'abort)))
863 trittweiler 1.704 ,@body)
864     (abort (&optional v)
865     :report "Return to SLIME's top level."
866     (declare (ignore v))
867     (force-user-output)
868     ,k))))
869 heller 1.456
870 heller 1.597 (defun handle-requests (connection &optional timeout)
871     "Read and process :emacs-rex requests.
872 heller 1.562 The processing is done in the extent of the toplevel restart."
873 heller 1.718 (with-connection (connection)
874     (cond (*sldb-quit-restart*
875     (process-requests timeout))
876     (t
877     (tagbody
878     start
879     (with-top-level-restart (connection (go start))
880     (process-requests timeout)))))))
881 heller 1.562
882 heller 1.597 (defun process-requests (timeout)
883 heller 1.562 "Read and process requests from Emacs."
884     (loop
885 heller 1.589 (multiple-value-bind (event timeout?)
886 heller 1.623 (wait-for-event `(or (:emacs-rex . _)
887     (:emacs-channel-send . _))
888     timeout)
889 heller 1.597 (when timeout? (return))
890 heller 1.623 (destructure-case event
891     ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
892     ((:emacs-channel-send channel (selector &rest args))
893     (channel-send channel selector args))))))
894 heller 1.97
895 heller 1.112 (defun current-socket-io ()
896     (connection.socket-io *emacs-connection*))
897    
898 heller 1.556 (defun close-connection (c condition backtrace)
899 heller 1.566 (let ((*debugger-hook* nil))
900 heller 1.755 (log-event "close-connection: ~a ...~%" condition))
901     (format *log-output* "~&;; swank:close-connection: ~A~%"
902     (escape-non-ascii (safe-condition-message condition)))
903 heller 1.771 (stop-serving-requests c)
904 heller 1.112 (close (connection.socket-io c))
905     (when (connection.dedicated-output c)
906 lgorrie 1.157 (close (connection.dedicated-output c)))
907 lgorrie 1.197 (setf *connections* (remove c *connections*))
908 lgorrie 1.217 (run-hook *connection-closed-hook* c)
909 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
910 heller 1.511 (finish-output *log-output*)
911     (format *log-output* "~&;; Event history start:~%")
912     (dump-event-history *log-output*)
913     (format *log-output* ";; Event history end.~%~
914 heller 1.390 ;; Backtrace:~%~{~A~%~}~
915 heller 1.356 ;; Connection to Emacs lost. [~%~
916     ;; condition: ~A~%~
917     ;; type: ~S~%~
918 heller 1.771 ;; style: ~S]~%"
919 heller 1.756 (loop for (i f) in backtrace collect
920     (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f))))
921 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
922     (type-of condition)
923 heller 1.771 (connection.communication-style c)))
924 heller 1.755 (finish-output *log-output*)
925     (log-event "close-connection ~a ... done.~%" condition))
926 heller 1.180
927     ;;;;;; Thread based communication
928    
929 heller 1.555 (defun read-loop (connection)
930 heller 1.556 (let ((input-stream (connection.socket-io connection))
931 heller 1.771 (control-thread (mconn.control-thread connection)))
932 heller 1.716 (with-swank-error-handler (connection)
933 heller 1.555 (loop (send control-thread (decode-message input-stream))))))
934    
935     (defun dispatch-loop (connection)
936 heller 1.556 (let ((*emacs-connection* connection))
937 heller 1.563 (with-panic-handler (connection)
938 heller 1.771 (loop (dispatch-event connection (receive))))))
939 heller 1.241
940 heller 1.554 (defvar *auto-flush-interval* 0.2)
941    
942     (defun auto-flush-loop (stream)
943     (loop
944 nsiivola 1.747 (when (not (and (open-stream-p stream)
945     (output-stream-p stream)))
946     (return nil))
947     ;; Use an IO timeout to avoid deadlocks
948     ;; on the stream we're flushing.
949     (call-with-io-timeout
950     (lambda () (finish-output stream))
951     :seconds 0.1)
952     (sleep *auto-flush-interval*)))
953 heller 1.554
954 heller 1.778 ;; FIXME: drop dependency on find-repl-thread
955     (defun find-worker-thread (connection id)
956 heller 1.241 (etypecase id
957     ((member t)
958 heller 1.778 (etypecase connection
959     (multithreaded-connection (car (mconn.active-threads connection)))
960     (singlethreaded-connection (current-thread))))
961 heller 1.241 ((member :repl-thread)
962 heller 1.778 (find-repl-thread connection))
963 heller 1.241 (fixnum
964     (find-thread id))))
965    
966 heller 1.778 (defun interrupt-worker-thread (connection id)
967     (let ((thread (or (find-worker-thread connection id)
968 heller 1.619 ;; FIXME: to something better here
969     (spawn (lambda ()) :name "ephemeral"))))
970     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
971     (assert thread)
972 heller 1.778 (etypecase connection
973     (multithreaded-connection
974     (interrupt-thread thread
975     (lambda ()
976     ;; safely interrupt THREAD
977     (invoke-or-queue-interrupt #'simple-break))))
978     (singlethreaded-connection
979     (simple-break)))))
980 heller 1.112
981 heller 1.778 (defun thread-for-evaluation (connection id)
982 heller 1.180 "Find or create a thread to evaluate the next request."
983 heller 1.778 (etypecase id
984     ((member t)
985     (etypecase connection
986     (multithreaded-connection (spawn-worker-thread connection))
987     (singlethreaded-connection (current-thread))))
988     ((member :repl-thread)
989     (find-repl-thread connection))
990     (fixnum
991     (find-thread id))))
992 heller 1.274
993     (defun spawn-worker-thread (connection)
994     (spawn (lambda ()
995 heller 1.288 (with-bindings *default-worker-thread-bindings*
996 heller 1.597 (with-top-level-restart (connection nil)
997     (apply #'eval-for-emacs
998     (cdr (wait-for-event `(:emacs-rex . _)))))))
999 heller 1.274 :name "worker"))
1000    
1001 heller 1.778 (defun add-active-thread (connection thread)
1002     (etypecase connection
1003     (multithreaded-connection
1004     (push thread (mconn.active-threads connection)))
1005     (singlethreaded-connection)))
1006    
1007     (defun remove-active-thread (connection thread)
1008     (etypecase connection
1009     (multithreaded-connection
1010     (setf (mconn.active-threads connection)
1011     (delete thread (mconn.active-threads connection) :count 1)))
1012     (singlethreaded-connection)))
1013    
1014 heller 1.771 (defun dispatch-event (connection event)
1015 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
1016 heller 1.556 (log-event "dispatch-event: ~s~%" event)
1017 heller 1.112 (destructure-case event
1018 heller 1.204 ((:emacs-rex form package thread-id id)
1019 heller 1.778 (let ((thread (thread-for-evaluation connection thread-id)))
1020     (cond (thread
1021     (add-active-thread connection thread)
1022 heller 1.635 (send-event thread `(:emacs-rex ,form ,package ,id)))
1023     (t
1024     (encode-message
1025     (list :invalid-rpc id
1026     (format nil "Thread not found: ~s" thread-id))
1027     (current-socket-io))))))
1028 heller 1.112 ((:return thread &rest args)
1029 heller 1.778 (remove-active-thread connection thread)
1030 heller 1.557 (encode-message `(:return ,@args) (current-socket-io)))
1031 heller 1.204 ((:emacs-interrupt thread-id)
1032 heller 1.778 (interrupt-worker-thread connection thread-id))
1033 heller 1.773 (((:write-string
1034 heller 1.622 :debug :debug-condition :debug-activate :debug-return :channel-send
1035 heller 1.557 :presentation-start :presentation-end
1036 trittweiler 1.700 :new-package :new-features :ed :indentation-update
1037 heller 1.557 :eval :eval-no-wait :background-message :inspect :ping
1038 heller 1.773 :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay)
1039 heller 1.112 &rest _)
1040     (declare (ignore _))
1041 heller 1.773 (encode-message event (current-socket-io)))
1042     (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1043 heller 1.566 (send-event (find-thread thread-id) (cons (car event) args)))
1044 heller 1.623 ((:emacs-channel-send channel-id msg)
1045     (let ((ch (find-channel channel-id)))
1046     (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1047 heller 1.569 ((:reader-error packet condition)
1048     (encode-message `(:reader-error ,packet
1049     ,(safe-condition-message condition))
1050 heller 1.773 (current-socket-io)))))
1051 heller 1.771
1052    
1053 heller 1.556 (defun send-event (thread event)
1054     (log-event "send-event: ~s ~s~%" thread event)
1055 heller 1.775 (let ((c *emacs-connection*))
1056     (etypecase c
1057     (multithreaded-connection
1058     (send thread event))
1059     (singlethreaded-connection
1060     (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event)))
1061     (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c))
1062     most-positive-fixnum))))))
1063 heller 1.556
1064     (defun send-to-emacs (event)
1065     "Send EVENT to Emacs."
1066 heller 1.566 ;;(log-event "send-to-emacs: ~a" event)
1067 heller 1.774 (without-slime-interrupts
1068     (let ((c *emacs-connection*))
1069     (etypecase c
1070     (multithreaded-connection
1071     (send (mconn.control-thread c) event))
1072     (singlethreaded-connection
1073     (dispatch-event c event)))
1074     (maybe-slow-down))))
1075    
1076 heller 1.773
1077     ;;;;;; Flow control
1078    
1079     ;; After sending N (usually 100) messages we slow down and ping Emacs
1080     ;; to make sure that everything we have sent so far was received.
1081    
1082     (defconstant send-counter-limit 100)
1083    
1084     (defun maybe-slow-down ()
1085     (let ((counter (incf *send-counter*)))
1086     (when (< send-counter-limit counter)
1087     (setf *send-counter* 0)
1088     (ping-pong))))
1089    
1090     (defun ping-pong ()
1091     (let* ((tag (make-tag))
1092     (pattern `(:emacs-pong ,tag)))
1093     (send-to-emacs `(:ping ,(current-thread-id) ,tag))
1094     (wait-for-event pattern)))
1095    
1096    
1097 heller 1.589 (defun wait-for-event (pattern &optional timeout)
1098 heller 1.709 "Scan the event queue for PATTERN and return the event.
1099     If TIMEOUT is 'nil wait until a matching event is enqued.
1100     If TIMEOUT is 't only scan the queue without waiting.
1101     The second return value is t if the timeout expired before a matching
1102     event was found."
1103 heller 1.562 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1104 heller 1.587 (without-slime-interrupts
1105 heller 1.771 (let ((c *emacs-connection*))
1106     (etypecase c
1107     (multithreaded-connection
1108     (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1109     (singlethreaded-connection
1110     (wait-for-event/event-loop c pattern timeout))))))
1111 heller 1.556
1112 heller 1.771 (defun wait-for-event/event-loop (connection pattern timeout)
1113 heller 1.562 (assert (or (not timeout) (eq timeout t)))
1114 heller 1.556 (loop
1115 heller 1.589 (check-slime-interrupts)
1116 heller 1.775 (let ((event (poll-for-event connection pattern)))
1117 heller 1.587 (when event (return (car event))))
1118 heller 1.775 (let ((events-enqueued (sconn.events-enqueued connection))
1119 heller 1.587 (ready (wait-for-input (list (current-socket-io)) timeout)))
1120     (cond ((and timeout (not ready))
1121     (return (values nil t)))
1122 heller 1.775 ((or (/= events-enqueued (sconn.events-enqueued connection))
1123 heller 1.587 (eq ready :interrupt))
1124     ;; rescan event queue, interrupts may enqueue new events
1125     )
1126     (t
1127     (assert (equal ready (list (current-socket-io))))
1128 heller 1.771 (dispatch-event connection
1129     (decode-message (current-socket-io))))))))
1130 heller 1.587
1131 heller 1.775 (defun poll-for-event (connection pattern)
1132     (let* ((c connection)
1133     (tail (member-if (lambda (e) (event-match-p e pattern))
1134     (sconn.event-queue c))))
1135 heller 1.587 (when tail
1136 heller 1.775 (setf (sconn.event-queue c)
1137     (nconc (ldiff (sconn.event-queue c) tail) (cdr tail)))
1138 heller 1.587 tail)))
1139 heller 1.556
1140 trittweiler 1.669 ;;; FIXME: Make this use SWANK-MATCH.
1141 heller 1.556 (defun event-match-p (event pattern)
1142     (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1143     (member pattern '(nil t)))
1144     (equal event pattern))
1145     ((symbolp pattern) t)
1146     ((consp pattern)
1147 heller 1.589 (case (car pattern)
1148     ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1149     (t (and (consp event)
1150     (and (event-match-p (car event) (car pattern))
1151     (event-match-p (cdr event) (cdr pattern)))))))
1152     (t (error "Invalid pattern: ~S" pattern))))
1153 heller 1.112
1154 heller 1.773
1155    
1156 heller 1.153 (defun spawn-threads-for-connection (connection)
1157 heller 1.771 (setf (mconn.control-thread connection)
1158 heller 1.555 (spawn (lambda () (control-thread connection))
1159     :name "control-thread"))
1160     connection)
1161    
1162     (defun control-thread (connection)
1163 heller 1.771 (with-struct* (mconn. @ connection)
1164 heller 1.556 (setf (@ control-thread) (current-thread))
1165     (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1166     :name "reader-thread"))
1167 heller 1.777 (setf (@ indentation-cache-thread)
1168     (spawn (lambda () (indentation-cache-loop connection))
1169     :name "swank-indentation-cache-thread"))
1170 heller 1.556 (dispatch-loop connection)))
1171 heller 1.153
1172 lgorrie 1.236 (defun cleanup-connection-threads (connection)
1173 heller 1.771 (let* ((c connection)
1174     (threads (list (mconn.repl-thread c)
1175     (mconn.reader-thread c)
1176     (mconn.control-thread c)
1177 heller 1.777 (mconn.auto-flush-thread c)
1178     (mconn.indentation-cache-thread c))))
1179 heller 1.266 (dolist (thread threads)
1180 heller 1.777 (when (and thread
1181 heller 1.357 (thread-alive-p thread)
1182     (not (equal (current-thread) thread)))
1183 heller 1.266 (kill-thread thread)))))
1184 lgorrie 1.236
1185 heller 1.123 ;;;;;; Signal driven IO
1186    
1187 heller 1.112 (defun install-sigio-handler (connection)
1188 heller 1.566 (add-sigio-handler (connection.socket-io connection)
1189     (lambda () (process-io-interrupt connection)))
1190 heller 1.597 (handle-requests connection t))
1191 heller 1.566
1192 heller 1.579 (defvar *io-interupt-level* 0)
1193    
1194 heller 1.566 (defun process-io-interrupt (connection)
1195 heller 1.578 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1196     (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1197     (invoke-or-queue-interrupt
1198 heller 1.597 (lambda () (handle-requests connection t))))
1199 heller 1.578 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1200 heller 1.566
1201 heller 1.123 (defun deinstall-sigio-handler (connection)
1202 heller 1.566 (log-event "deinstall-sigio-handler...~%")
1203 heller 1.579 (remove-sigio-handlers (connection.socket-io connection))
1204 heller 1.566 (log-event "deinstall-sigio-handler...done~%"))
1205 heller 1.123
1206     ;;;;;; SERVE-EVENT based IO
1207    
1208     (defun install-fd-handler (connection)
1209 heller 1.566 (add-fd-handler (connection.socket-io connection)
1210 heller 1.597 (lambda () (handle-requests connection t)))
1211 heller 1.771 (setf (sconn.saved-sigint-handler connection)
1212 heller 1.567 (install-sigint-handler
1213     (lambda ()
1214     (invoke-or-queue-interrupt
1215 trittweiler 1.698 (lambda () (dispatch-interrupt-event connection))))))
1216 heller 1.597 (handle-requests connection t))
1217 heller 1.123
1218 trittweiler 1.698 (defun dispatch-interrupt-event (connection)
1219     (with-connection (connection)
1220 heller 1.771 (dispatch-event connection `(:emacs-interrupt ,(current-thread-id)))))
1221 heller 1.587
1222 heller 1.123 (defun deinstall-fd-handler (connection)
1223 heller 1.577 (log-event "deinstall-fd-handler~%")
1224 heller 1.566 (remove-fd-handlers (connection.socket-io connection))
1225 heller 1.771 (install-sigint-handler (sconn.saved-sigint-handler connection)))
1226 heller 1.123
1227     ;;;;;; Simple sequential IO
1228 heller 1.112
1229     (defun simple-serve-requests (connection)
1230 trittweiler 1.698 (unwind-protect
1231 heller 1.640 (with-connection (connection)
1232     (call-with-user-break-handler
1233 trittweiler 1.698 (lambda ()
1234     (invoke-or-queue-interrupt
1235 heller 1.717 (lambda () (dispatch-interrupt-event connection))))
1236 heller 1.640 (lambda ()
1237 heller 1.717 (with-simple-restart (close-connection "Close SLIME connection.")
1238 heller 1.640 (let* ((stdin (real-input-stream *standard-input*))
1239     (*standard-input* (make-repl-input-stream connection
1240     stdin)))
1241 heller 1.717 (tagbody toplevel
1242     (with-top-level-restart (connection (go toplevel))
1243     (simple-repl))))))))
1244 heller 1.556 (close-connection connection nil (safe-backtrace))))
1245 heller 1.112
1246 heller 1.722 ;; this is signalled when our custom stream thinks the end-of-file is reached.
1247     ;; (not when the end-of-file on the socket is reached)
1248     (define-condition end-of-repl-input (end-of-file) ())
1249    
1250 heller 1.614 (defun simple-repl ()
1251 heller 1.717 (loop
1252     (format t "~a> " (package-string-for-prompt *package*))
1253     (force-output)
1254     (let ((form (handler-case (read)
1255 heller 1.722 (end-of-repl-input () (return)))))
1256 heller 1.717 (let ((- form)
1257     (values (multiple-value-list (eval form))))
1258     (setq *** ** ** * * (car values)
1259     /// // // / / values
1260     +++ ++ ++ + + form)
1261     (cond ((null values) (format t "; No values~&"))
1262     (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
1263 heller 1.614
1264     (defun make-repl-input-stream (connection stdin)
1265     (make-input-stream
1266 heller 1.718 (lambda () (repl-input-stream-read connection stdin))))
1267    
1268     (defun repl-input-stream-read (connection stdin)
1269     (loop
1270     (let* ((socket (connection.socket-io connection))
1271     (inputs (list socket stdin))
1272     (ready (wait-for-input inputs)))
1273     (cond ((eq ready :interrupt)
1274     (check-slime-interrupts))
1275     ((member socket ready)
1276     ;; A Slime request from Emacs is pending; make sure to
1277     ;; redirect IO to the REPL buffer.
1278     (with-simple-restart (process-input "Continue reading input.")
1279     (let ((*sldb-quit-restart* (find-restart 'process-input)))
1280     (with-io-redirection (connection)
1281     (handle-requests connection t)))))
1282     ((member stdin ready)
1283     ;; User typed something into the *inferior-lisp* buffer,
1284     ;; so do not redirect.
1285     (return (read-non-blocking stdin)))
1286     (t (assert (null ready)))))))
1287 heller 1.614
1288     (defun read-non-blocking (stream)
1289     (with-output-to-string (str)
1290 heller 1.722 (handler-case
1291     (loop (let ((c (read-char-no-hang stream)))
1292     (unless c (return))
1293     (write-char c str)))
1294     (end-of-file () (error 'end-of-repl-input :stream stream)))))
1295    
1296 lgorrie 1.80
1297 heller 1.623 ;;; Channels
1298    
1299 heller 1.769 ;; FIXME: should be per connection not global.
1300 heller 1.623 (defvar *channels* '())
1301     (defvar *channel-counter* 0)
1302    
1303     (defclass channel ()
1304     ((id :reader channel-id)
1305     (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1306     (name :initarg :name :initform nil)))
1307    
1308 heller 1.769 (defmethod initialize-instance :after ((ch channel) &key)
1309 heller 1.623 (with-slots (id) ch
1310     (setf id (incf *channel-counter*))
1311     (push (cons id ch) *channels*)))
1312    
1313     (defmethod print-object ((c channel) stream)
1314     (print-unreadable-object (c stream :type t)
1315     (with-slots (id name) c
1316     (format stream "~d ~a" id name))))
1317    
1318     (defun find-channel (id)
1319     (cdr (assoc id *channels*)))
1320    
1321     (defgeneric channel-send (channel selector args))
1322    
1323     (defmacro define-channel-method (selector (channel &rest args) &body body)
1324     `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1325     (destructuring-bind ,args args
1326     . ,body)))
1327    
1328     (defun send-to-remote-channel (channel-id msg)
1329     (send-to-emacs `(:channel-send ,channel-id ,msg)))
1330    
1331 sboukarev 1.665
1332 trittweiler 1.545
1333 lgorrie 1.50 (defvar *slime-features* nil
1334     "The feature list that has been sent to Emacs.")
1335    
1336 lgorrie 1.104 (defun send-oob-to-emacs (object)
1337 heller 1.112 (send-to-emacs object))
1338    
1339 heller 1.769 ;; FIXME: belongs to swank-repl.lisp
1340 heller 1.112 (defun force-user-output ()
1341 heller 1.551 (force-output (connection.user-io *emacs-connection*)))
1342 heller 1.112
1343 heller 1.592 (add-hook *pre-reply-hook* 'force-user-output)
1344    
1345 heller 1.769 ;; FIXME: belongs to swank-repl.lisp
1346 heller 1.112 (defun clear-user-input ()
1347     (clear-input (connection.user-input *emacs-connection*)))
1348 lgorrie 1.62
1349 heller 1.557 (defvar *tag-counter* 0)
1350 lgorrie 1.91
1351 heller 1.557 (defun make-tag ()
1352     (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1353 heller 1.232
1354 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1355 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1356 heller 1.557 (let ((tag (make-tag))
1357 heller 1.330 (question (apply #'format nil format-string arguments)))
1358 mkoeppe 1.327 (force-output)
1359 heller 1.557 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1360 trittweiler 1.647 (third (wait-for-event `(:emacs-return ,tag result)))))
1361    
1362     (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1363     "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1364     entered nothing, returns NIL when user pressed C-g."
1365     (check-type prompt string) (check-type initial-value (or null string))
1366     (let ((tag (make-tag)))
1367     (force-output)
1368     (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1369     ,prompt ,initial-value))
1370     (third (wait-for-event `(:emacs-return ,tag result)))))
1371    
1372 mbaringer 1.279
1373 mbaringer 1.346 (defun process-form-for-emacs (form)
1374     "Returns a string which emacs will read as equivalent to
1375     FORM. FORM can contain lists, strings, characters, symbols and
1376     numbers.
1377    
1378     Characters are converted emacs' ?<char> notaion, strings are left
1379     as they are (except for espacing any nested \" chars, numbers are
1380 alendvai 1.447 printed in base 10 and symbols are printed as their symbol-name
1381 mbaringer 1.346 converted to lower case."
1382     (etypecase form
1383     (string (format nil "~S" form))
1384     (cons (format nil "(~A . ~A)"
1385     (process-form-for-emacs (car form))
1386     (process-form-for-emacs (cdr form))))
1387     (character (format nil "?~C" form))
1388 alendvai 1.447 (symbol (concatenate 'string (when (eq (symbol-package form)
1389     #.(find-package "KEYWORD"))
1390     ":")
1391     (string-downcase (symbol-name form))))
1392 mbaringer 1.346 (number (let ((*print-base* 10))
1393     (princ-to-string form)))))
1394    
1395 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1396 sboukarev 1.737 "Eval FORM in Emacs.
1397 sboukarev 1.736 `slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
1398 mbaringer 1.346 (cond (nowait
1399     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1400     (t
1401     (force-output)
1402 heller 1.557 (let ((tag (make-tag)))
1403     (send-to-emacs `(:eval ,(current-thread-id) ,tag
1404     ,(process-form-for-emacs form)))
1405     (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1406     (destructure-case value
1407 heller 1.739 ((:ok value) value)
1408     ((:error kind . data) (error "~a: ~{~a~}" kind data))
1409 heller 1.557 ((:abort) (abort))))))))
1410 heller 1.337
1411 mbaringer 1.414 (defvar *swank-wire-protocol-version* nil
1412 heller 1.418 "The version of the swank/slime communication protocol.")
1413 mbaringer 1.414
1414 heller 1.126 (defslimefun connection-info ()
1415 heller 1.343 "Return a key-value list of the form:
1416 heller 1.418 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1417 heller 1.343 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1418     STYLE: the communication style
1419 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1420 heller 1.343 FEATURES: a list of keywords
1421 mbaringer 1.413 PACKAGE: a list (&key NAME PROMPT)
1422 heller 1.418 VERSION: the protocol version"
1423 trittweiler 1.696 (let ((c *emacs-connection*))
1424     (setq *slime-features* *features*)
1425     `(:pid ,(getpid) :style ,(connection.communication-style c)
1426 heller 1.763 :encoding (:coding-systems
1427     ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix")
1428     when (find-external-format cs) collect cs))
1429 trittweiler 1.696 :lisp-implementation (:type ,(lisp-implementation-type)
1430     :name ,(lisp-implementation-type-name)
1431 trittweiler 1.705 :version ,(lisp-implementation-version)
1432     :program ,(lisp-implementation-program))
1433 trittweiler 1.696 :machine (:instance ,(machine-instance)
1434     :type ,(machine-type)
1435     :version ,(machine-version))
1436     :features ,(features-for-emacs)
1437     :modules ,*modules*
1438     :package (:name ,(package-name *package*)
1439     :prompt ,(package-string-for-prompt *package*))
1440     :version ,*swank-wire-protocol-version*)))
1441 lgorrie 1.62
1442 trittweiler 1.674 (defun debug-on-swank-error ()
1443     (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1444     *debug-on-swank-protocol-error*)
1445    
1446     (defun (setf debug-on-swank-error) (new-value)
1447     (setf *debug-on-swank-protocol-error* new-value)
1448     (setf *debug-swank-backend* new-value))
1449    
1450     (defslimefun toggle-debug-on-swank-error ()
1451     (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1452    
1453 lgorrie 1.62
1454     ;;;; Reading and printing
1455 dbarlow 1.28
1456 heller 1.207 (define-special *buffer-package*
1457     "Package corresponding to slime-buffer-package.
1458 dbarlow 1.28
1459 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1460 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1461    
1462 heller 1.207 (define-special *buffer-readtable*
1463     "Readtable associated with the current buffer")
1464 heller 1.189
1465 heller 1.568 (defmacro with-buffer-syntax ((&optional package) &body body)
1466 heller 1.189 "Execute BODY with appropriate *package* and *readtable* bindings.
1467    
1468     This should be used for code that is conceptionally executed in an
1469     Emacs buffer."
1470 heller 1.568 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1471 heller 1.293
1472 heller 1.568 (defun call-with-buffer-syntax (package fun)
1473 heller 1.760 (let ((*package* (if package
1474     (guess-buffer-package package)
1475 heller 1.568 *buffer-package*)))
1476 heller 1.293 ;; Don't shadow *readtable* unnecessarily because that prevents
1477     ;; the user from assigning to it.
1478     (if (eq *readtable* *buffer-readtable*)
1479     (call-with-syntax-hooks fun)
1480     (let ((*readtable* *buffer-readtable*))
1481     (call-with-syntax-hooks fun)))))
1482 heller 1.189
1483 trittweiler 1.664 (defmacro without-printing-errors ((&key object stream
1484     (msg "<<error printing object>>"))
1485     &body body)
1486     "Catches errors during evaluation of BODY and prints MSG instead."
1487     `(handler-case (progn ,@body)
1488     (serious-condition ()
1489     ,(cond ((and stream object)
1490     (let ((gstream (gensym "STREAM+")))
1491     `(let ((,gstream ,stream))
1492 heller 1.766 (print-unreadable-object (,object ,gstream :type t
1493     :identity t)
1494 trittweiler 1.664 (write-string ,msg ,gstream)))))
1495     (stream
1496     `(write-string ,msg ,stream))
1497     (object
1498     `(with-output-to-string (s)
1499     (print-unreadable-object (,object s :type t :identity t)
1500     (write-string ,msg s))))
1501     (t msg)))))
1502    
1503 heller 1.330 (defun to-string (object)
1504     "Write OBJECT in the *BUFFER-PACKAGE*.
1505 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1506     gracefully."
1507 heller 1.330 (with-buffer-syntax ()
1508     (let ((*print-readably* nil))
1509 trittweiler 1.664 (without-printing-errors (:object object :stream nil)
1510     (prin1-to-string object)))))
1511    
1512 dbarlow 1.28 (defun from-string (string)
1513     "Read string in the *BUFFER-PACKAGE*"
1514 heller 1.189 (with-buffer-syntax ()
1515     (let ((*read-suppress* nil))
1516 trittweiler 1.666 (values (read-from-string string)))))
1517 lgorrie 1.60
1518 heller 1.568 (defun parse-string (string package)
1519     "Read STRING in PACKAGE."
1520     (with-buffer-syntax (package)
1521     (let ((*read-suppress* nil))
1522     (read-from-string string))))
1523    
1524 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
1525     (defun tokenize-symbol (string)
1526 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
1527     and is tokenized accordingly. The result is returned in three
1528     values: The package identifier part, the actual symbol identifier
1529     part, and a flag if the STRING represents a symbol that is
1530     internal to the package identifier part. (Notice that the flag is
1531     also true with an empty package identifier part, as the STRING is
1532     considered to represent a symbol internal to some current package.)"
1533 heller 1.245 (let ((package (let ((pos (position #\: string)))
1534     (if pos (subseq string 0 pos) nil)))
1535     (symbol (let ((pos (position #\: string :from-end t)))
1536     (if pos (subseq string (1+ pos)) string)))
1537 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
1538 heller 1.245 (values symbol package internp)))
1539    
1540 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1541 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
1542 mkoeppe 1.370 (let ((package nil)
1543     (token (make-array (length string) :element-type 'character
1544     :fill-pointer 0))
1545     (backslash nil)
1546     (vertical nil)
1547     (internp nil))
1548 trittweiler 1.648 (loop for char across string do
1549     (cond
1550 mkoeppe 1.370 (backslash
1551     (vector-push-extend char token)
1552     (setq backslash nil))
1553     ((char= char #\\) ; Quotes next character, even within |...|
1554     (setq backslash t))
1555     ((char= char #\|)
1556 trittweiler 1.648 (setq vertical (not vertical)))
1557 mkoeppe 1.370 (vertical
1558     (vector-push-extend char token))
1559     ((char= char #\:)
1560 trittweiler 1.648 (cond ((and package internp)
1561 sboukarev 1.670 (return-from tokenize-symbol-thoroughly))
1562 trittweiler 1.648 (package
1563     (setq internp t))
1564     (t
1565     (setq package token
1566     token (make-array (length string)
1567     :element-type 'character
1568     :fill-pointer 0)))))
1569 mkoeppe 1.370 (t
1570     (vector-push-extend (casify-char char) token))))
1571 sboukarev 1.670 (unless vertical
1572     (values token package (or (not package) internp)))))
1573 mkoeppe 1.370
1574 trittweiler 1.488 (defun untokenize-symbol (package-name internal-p symbol-name)
1575     "The inverse of TOKENIZE-SYMBOL.
1576    
1577     (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1578     (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1579     (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1580     "
1581 heller 1.507 (cond ((not package-name) symbol-name)
1582     (internal-p (cat package-name "::" symbol-name))
1583     (t (cat package-name ":" symbol-name))))
1584 trittweiler 1.488
1585 mkoeppe 1.370 (defun casify-char (char)
1586     "Convert CHAR accoring to readtable-case."
1587 heller 1.245 (ecase (readtable-case *readtable*)
1588 mkoeppe 1.370 (:preserve char)
1589     (:upcase (char-upcase char))
1590     (:downcase (char-downcase char))
1591     (:invert (if (upper-case-p char)
1592     (char-downcase char)
1593     (char-upcase char)))))
1594 heller 1.245
1595 trittweiler 1.668
1596 heller 1.740 (defun find-symbol-with-status (symbol-name status
1597     &optional (package *package*))
1598 trittweiler 1.668 (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
1599     (if (and flag (eq flag status))
1600     (values symbol flag)
1601     (values nil nil))))
1602    
1603 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1604 heller 1.189 "Find the symbol named STRING.
1605 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1606 trittweiler 1.668 (multiple-value-bind (sname pname internalp)
1607     (tokenize-symbol-thoroughly string)
1608 sboukarev 1.670 (when sname
1609     (let ((package (cond ((string= pname "") keyword-package)
1610     (pname (find-package pname))
1611     (t package))))
1612     (if package
1613     (multiple-value-bind (symbol flag)
1614     (if internalp
1615     (find-symbol sname package)
1616     (find-symbol-with-status sname ':external package))
1617     (values symbol flag sname package))
1618     (values nil nil nil nil))))))
1619 heller 1.189
1620 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1621     (multiple-value-bind (symbol status) (parse-symbol string package)
1622     (if status
1623     (values symbol status)
1624 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
1625 heller 1.207
1626 heller 1.189 (defun parse-package (string)
1627     "Find the package named STRING.
1628     Return the package or nil."
1629 heller 1.517 ;; STRING comes usually from a (in-package STRING) form.
1630     (ignore-errors
1631     (find-package (let ((*package* *swank-io-package*))
1632     (read-from-string string)))))
1633 heller 1.190
1634 heller 1.458 (defun unparse-name (string)
1635     "Print the name STRING according to the current printer settings."
1636     ;; this is intended for package or symbol names
1637     (subseq (prin1-to-string (make-symbol string)) 2))
1638    
1639 heller 1.459 (defun guess-package (string)
1640     "Guess which package corresponds to STRING.
1641     Return nil if no package matches."
1642 nsiivola 1.595 (when string
1643     (or (find-package string)
1644     (parse-package string)
1645     (if (find #\! string) ; for SBCL
1646     (guess-package (substitute #\- #\! string))))))
1647 dbarlow 1.28
1648 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1649 heller 1.189 "An alist mapping package names to readtables.")
1650    
1651 heller 1.459 (defun guess-buffer-readtable (package-name)
1652     (let ((package (guess-package package-name)))
1653     (or (and package
1654     (cdr (assoc (package-name package) *readtable-alist*
1655     :test #'string=)))
1656     *readtable*)))
1657 heller 1.189
1658 lgorrie 1.62
1659 lgorrie 1.218 ;;;; Evaluation
1660    
1661 heller 1.278 (defvar *pending-continuations* '()
1662     "List of continuations for Emacs. (thread local)")
1663    
1664 lgorrie 1.218 (defun guess-buffer-package (string)
1665     "Return a package for STRING.
1666     Fall back to the the current if no such package exists."
1667 heller 1.459 (or (and string (guess-package string))
1668 lgorrie 1.218 *package*))
1669    
1670     (defun eval-for-emacs (form buffer-package id)
1671 mbaringer 1.466 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
1672 lgorrie 1.218 Return the result to the continuation ID.
1673     Errors are trapped and invoke our debugger."
1674 sboukarev 1.729 (let (ok result condition)
1675 heller 1.567 (unwind-protect
1676     (let ((*buffer-package* (guess-buffer-package buffer-package))
1677     (*buffer-readtable* (guess-buffer-readtable buffer-package))
1678     (*pending-continuations* (cons id *pending-continuations*)))
1679     (check-type *buffer-package* package)
1680     (check-type *buffer-readtable* readtable)
1681 trittweiler 1.584 ;; APPLY would be cleaner than EVAL.
1682 trittweiler 1.688 ;; (setq result (apply (car form) (cdr form)))
1683 sboukarev 1.729 (handler-bind ((t (lambda (c) (setf condition c))))
1684     (setq result (with-slime-interrupts (eval form))))
1685 heller 1.567 (run-hook *pre-reply-hook*)
1686     (setq ok t))
1687     (send-to-emacs `(:return ,(current-thread)
1688     ,(if ok
1689     `(:ok ,result)
1690 sboukarev 1.729 `(:abort ,(prin1-to-string condition)))
1691 heller 1.567 ,id)))))
1692 lgorrie 1.218
1693 heller 1.337 (defvar *echo-area-prefix* "=> "
1694     "A prefix that `format-values-for-echo-area' should use.")
1695    
1696 lgorrie 1.218 (defun format-values-for-echo-area (values)
1697     (with-buffer-syntax ()
1698     (let ((*print-readably* nil))
1699 heller 1.242 (cond ((null values) "; No value")
1700 heller 1.525 ((and (integerp (car values)) (null (cdr values)))
1701 heller 1.242 (let ((i (car values)))
1702 sboukarev 1.713 (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)"
1703     *echo-area-prefix*
1704     i (integer-length i) i i i)))
1705 heller 1.511 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
1706 lgorrie 1.218
1707 heller 1.692 (defmacro values-to-string (values)
1708     `(format-values-for-echo-area (multiple-value-list ,values)))
1709    
1710 lgorrie 1.218 (defslimefun interactive-eval (string)
1711 heller 1.331 (with-buffer-syntax ()
1712 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
1713     (let ((values (multiple-value-list (eval (from-string string)))))
1714     (finish-output)
1715     (format-values-for-echo-area values)))))
1716 lgorrie 1.218
1717 heller 1.278 (defslimefun eval-and-grab-output (string)
1718     (with-buffer-syntax ()
1719 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME evaluation request.")
1720     (let* ((s (make-string-output-stream))
1721     (*standard-output* s)
1722     (values (multiple-value-list (eval (from-string string)))))
1723     (list (get-output-stream-string s)
1724     (format nil "~{~S~^~%~}" values))))))
1725 heller 1.278
1726 heller 1.503 (defun eval-region (string)
1727     "Evaluate STRING.
1728     Return the results of the last form as a list and as secondary value the
1729     last form."
1730     (with-input-from-string (stream string)
1731     (let (- values)
1732     (loop
1733     (let ((form (read stream nil stream)))
1734     (when (eq form stream)
1735 heller 1.612 (finish-output)
1736 heller 1.503 (return (values values -)))
1737     (setq - form)
1738     (setq values (multiple-value-list (eval form)))
1739     (finish-output))))))
1740 lgorrie 1.218
1741     (defslimefun interactive-eval-region (string)
1742     (with-buffer-syntax ()
1743 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
1744     (format-values-for-echo-area (eval-region string)))))
1745 lgorrie 1.218
1746     (defslimefun re-evaluate-defvar (form)
1747     (with-buffer-syntax ()
1748 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME evaluation request.")
1749     (let ((form (read-from-string form)))
1750     (destructuring-bind (dv name &optional value doc) form
1751     (declare (ignore value doc))
1752     (assert (eq dv 'defvar))
1753     (makunbound name)
1754     (prin1-to-string (eval form)))))))
1755 lgorrie 1.218
1756 heller 1.288 (defvar *swank-pprint-bindings*
1757     `((*print-pretty* . t)
1758     (*print-level* . nil)
1759     (*print-length* . nil)
1760     (*print-circle* . t)
1761     (*print-gensym* . t)
1762     (*print-readably* . nil))
1763     "A list of variables bindings during pretty printing.
1764     Used by pprint-eval.")
1765    
1766 heller 1.692 (defun swank-pprint (values)
1767     "Bind some printer variables and pretty print each object in VALUES."
1768 lgorrie 1.218 (with-buffer-syntax ()
1769 heller 1.288 (with-bindings *swank-pprint-bindings*
1770 heller 1.692 (cond ((null values) "; No value")
1771 heller 1.288 (t (with-output-to-string (*standard-output*)
1772 heller 1.692 (dolist (o values)
1773 heller 1.288 (pprint o)
1774     (terpri))))))))
1775 heller 1.250
1776 lgorrie 1.218 (defslimefun pprint-eval (string)
1777     (with-buffer-syntax ()
1778 heller 1.633 (let* ((s (make-string-output-stream))
1779     (values
1780     (let ((*standard-output* s)
1781     (*trace-output* s))
1782     (multiple-value-list (eval (read-from-string string))))))
1783     (cat (get-output-stream-string s)
1784     (swank-pprint values)))))
1785 lgorrie 1.218
1786 heller 1.459 (defslimefun set-package (name)
1787     "Set *package* to the package named NAME.
1788     Return the full package-name and the string to use in the prompt."
1789     (let ((p (guess-package name)))
1790 sboukarev 1.662 (assert (packagep p) nil "Package ~a doesn't exist." name)
1791 heller 1.458 (setq *package* p)
1792 lgorrie 1.218 (list (package-name p) (package-string-for-prompt p))))
1793    
1794 heller 1.503 (defun cat (&rest strings)
1795     "Concatenate all arguments and make the result a string."
1796     (with-output-to-string (out)
1797     (dolist (s strings)
1798     (etypecase s
1799     (string (write-string s out))
1800     (character (write-char s out))))))
1801    
1802 heller 1.573 (defun truncate-string (string width &optional ellipsis)
1803     (let ((len (length string)))
1804     (cond ((< len width) string)
1805     (ellipsis (cat (subseq string 0 width) ellipsis))
1806     (t (subseq string 0 width)))))
1807    
1808 heller 1.575 (defun call/truncated-output-to-string (length function
1809     &optional (ellipsis ".."))
1810     "Call FUNCTION with a new stream, return the output written to the stream.
1811     If FUNCTION tries to write more than LENGTH characters, it will be
1812     aborted and return immediately with the output written so far."
1813     (let ((buffer (make-string (+ length (length ellipsis))))
1814     (fill-pointer 0))
1815     (block buffer-full
1816     (flet ((write-output (string)
1817     (let* ((free (- length fill-pointer))
1818     (count (min free (length string))))
1819     (replace buffer string :start1 fill-pointer :end2 count)
1820     (incf fill-pointer count)
1821     (when (> (length string) free)
1822     (replace buffer ellipsis :start1 fill-pointer)
1823     (return-from buffer-full buffer)))))
1824     (let ((stream (make-output-stream #'write-output)))
1825     (funcall function stream)
1826     (finish-output stream)
1827     (subseq buffer 0 fill-pointer))))))
1828    
1829 heller 1.724 (defmacro with-string-stream ((var &key length bindings)
1830     &body body)
1831     (cond ((and (not bindings) (not length))
1832     `(with-output-to-string (,var) . ,body))
1833     ((not bindings)
1834     `(call/truncated-output-to-string
1835     ,length (lambda (,var) . ,body)))
1836     (t
1837     `(with-bindings ,bindings
1838     (with-string-stream (,var :length ,length)
1839     . ,body)))))
1840    
1841 heller 1.765 (defun to-line (object &optional width)
1842 heller 1.724 "Print OBJECT to a single line. Return the string."
1843 heller 1.765 (let ((width (or width 512)))
1844     (without-printing-errors (:object object :stream nil)
1845     (with-string-stream (stream :length width)
1846     (write object :stream stream :right-margin width :lines 1)))))
1847 heller 1.724
1848 heller 1.642 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
1849     (#\\ . "\\\\"))))
1850 heller 1.643 "Write STRING to STREAM surronded by double-quotes.
1851 heller 1.642 LENGTH -- if non-nil truncate output after LENGTH chars.
1852 heller 1.644 MAP -- rewrite the chars in STRING according to this alist."
1853 heller 1.642 (let ((limit (or length array-dimension-limit)))
1854     (write-char #\" stream)
1855     (loop for c across string
1856     for i from 0 do
1857     (when (= i limit)
1858     (write-string "..." stream)
1859     (return))
1860     (let ((probe (assoc c map)))
1861 heller 1.645 (cond (probe (write-string (cdr probe) stream))
1862 heller 1.642 (t (write-char c stream)))))
1863     (write-char #\" stream)))
1864    
1865 heller 1.769
1866     ;;;; Prompt
1867    
1868     ;; FIXME: do we really need 45 lines of code just to figure out the
1869     ;; prompt?
1870    
1871     (defvar *canonical-package-nicknames*
1872     `((:common-lisp-user . :cl-user))
1873     "Canonical package names to use instead of shortest name/nickname.")
1874    
1875     (defvar *auto-abbreviate-dotted-packages* t
1876     "Abbreviate dotted package names to their last component if T.")
1877    
1878 heller 1.503 (defun package-string-for-prompt (package)
1879     "Return the shortest nickname (or canonical name) of PACKAGE."
1880     (unparse-name
1881     (or (canonical-package-nickname package)
1882     (auto-abbreviated-package-name package)
1883     (shortest-package-nickname package))))
1884    
1885     (defun canonical-package-nickname (package)
1886     "Return the canonical package nickname, if any, of PACKAGE."
1887     (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
1888     :test #'string=))))
1889     (and name (string name))))
1890    
1891     (defun auto-abbreviated-package-name (package)
1892     "Return an abbreviated 'name' for PACKAGE.
1893    
1894     N.B. this is not an actual package name or nickname."
1895     (when *auto-abbreviate-dotted-packages*
1896 trittweiler 1.582 (loop with package-name = (package-name package)
1897     with offset = nil
1898     do (let ((last-dot-pos (position #\. package-name :end offset :from-end t)))
1899     (unless last-dot-pos
1900     (return nil))
1901     ;; If a dot chunk contains only numbers, that chunk most
1902     ;; likely represents a version number; so we collect the
1903     ;; next chunks, too, until we find one with meat.
1904     (let ((name (subseq package-name (1+ last-dot-pos) offset)))
1905     (if (notevery #'digit-char-p name)
1906     (return (subseq package-name (1+ last-dot-pos)))
1907     (setq offset last-dot-pos)))))))
1908 heller 1.503
1909     (defun shortest-package-nickname (package)
1910 trittweiler 1.582 "Return the shortest nickname of PACKAGE."
1911 heller 1.503 (loop for name in (cons (package-name package) (package-nicknames package))
1912     for shortest = name then (if (< (length name) (length shortest))
1913     name
1914     shortest)
1915     finally (return shortest)))
1916    
1917 heller 1.769
1918    
1919 lgorrie 1.218 (defslimefun ed-in-emacs (&optional what)
1920     "Edit WHAT in Emacs.
1921    
1922     WHAT can be:
1923 crhodes 1.307 A pathname or a string,
1924 heller 1.654 A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
1925 crhodes 1.371 A function name (symbol or cons),
1926 heller 1.654 NIL. "
1927     (flet ((canonicalize-filename (filename)
1928 heller 1.598 (pathname-to-filename (or (probe-file filename) filename))))
1929 heller 1.654 (let ((target
1930     (etypecase what
1931     (null nil)
1932     ((or string pathname)
1933     `(:filename ,(canonicalize-filename what)))
1934     ((cons (or string pathname) *)
1935     `(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
1936     ((or symbol cons)
1937 heller 1.717 `(:function-name ,(prin1-to-string what))))))
1938 heller 1.654 (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
1939     ((default-connection)
1940     (with-connection ((default-connection))
1941     (send-oob-to-emacs `(:ed ,target))))
1942     (t (error "No connection"))))))
1943 lgorrie 1.218
1944 nsiivola 1.650 (defslimefun inspect-in-emacs (what &key wait)
1945     "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
1946     inspector has been closed in Emacs."
1947 nsiivola 1.426 (flet ((send-it ()
1948 nsiivola 1.650 (let ((tag (when wait (make-tag)))
1949     (thread (when wait (current-thread-id))))
1950     (with-buffer-syntax ()
1951     (reset-inspector)
1952     (send-oob-to-emacs `(:inspect ,(inspect-object what)
1953     ,thread
1954     ,tag)))
1955     (when wait
1956     (wait-for-event `(:emacs-return ,tag result))))))
1957     (cond
1958 nsiivola 1.426 (*emacs-connection*
1959     (send-it))
1960     ((default-connection)
1961     (with-connection ((default-connection))
1962 alendvai 1.438 (send-it))))
1963     what))
1964 nsiivola 1.426
1965 lgorrie 1.286 (defslimefun value-for-editing (form)
1966     "Return a readable value of FORM for editing in Emacs.
1967     FORM is expected, but not required, to be SETF'able."
1968     ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
1969 heller 1.288 (with-buffer-syntax ()
1970 heller 1.634 (let* ((value (eval (read-from-string form)))
1971     (*print-length* nil))
1972     (prin1-to-string value))))
1973 lgorrie 1.286
1974     (defslimefun commit-edited-value (form value)
1975     "Set the value of a setf'able FORM to VALUE.
1976     FORM and VALUE are both strings from Emacs."
1977 heller 1.289 (with-buffer-syntax ()
1978 heller 1.330 (eval `(setf ,(read-from-string form)
1979     ,(read-from-string (concatenate 'string "`" value))))
1980 heller 1.289 t))
1981 lgorrie 1.286
1982 heller 1.330 (defun background-message (format-string &rest args)
1983     "Display a message in Emacs' echo area.
1984    
1985     Use this function for informative messages only. The message may even
1986 heller 1.772 be dropped if we are too busy with other things."
1987 heller 1.773 (when *emacs-connection*
1988 heller 1.774 (send-to-emacs `(:background-message
1989 heller 1.330 ,(apply #'format nil format-string args)))))
1990    
1991 heller 1.621 ;; This is only used by the test suite.
1992     (defun sleep-for (seconds)
1993 heller 1.623 "Sleep for at least SECONDS seconds.
1994     This is just like cl:sleep but guarantees to sleep
1995 heller 1.621 at least SECONDS."
1996     (let* ((start (get-internal-real-time))
1997     (end (+ start
1998     (* seconds internal-time-units-per-second))))
1999     (loop
2000     (let ((now (get-internal-real-time)))
2001     (cond ((< end now) (return))
2002     (t (sleep (/ (- end now)
2003     internal-time-units-per-second))))))))
2004    
2005 lgorrie 1.218
2006 lgorrie 1.62 ;;;; Debugger
2007 heller 1.47
2008 heller 1.561 (defun invoke-slime-debugger (condition)
2009     "Sends a message to Emacs declaring that the debugger has been entered,
2010 lgorrie 1.62 then waits to handle further requests from Emacs. Eventually returns
2011     after Emacs causes a restart to be invoked."
2012 heller 1.561 (without-slime-interrupts
2013     (cond (*emacs-connection*
2014     (debug-in-emacs condition))
2015     ((default-connection)
2016     (with-connection ((default-connection))
2017     (debug-in-emacs condition))))))
2018    
2019 heller 1.610 (define-condition invoke-default-debugger () ())
2020 heller 1.716
2021 heller 1.561 (defun swank-debugger-hook (condition hook)
2022     "Debugger function for binding *DEBUGGER-HOOK*."
2023 heller 1.571 (declare (ignore hook))
2024 heller 1.610 (handler-case
2025     (call-with-debugger-hook #'swank-debugger-hook
2026     (lambda () (invoke-slime-debugger condition)))
2027     (invoke-default-debugger ()
2028     (invoke-default-debugger condition))))
2029 lgorrie 1.223
2030 heller 1.563 (defun invoke-default-debugger (condition)
2031 trittweiler 1.674 (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
2032 heller 1.563
2033 heller 1.565 (defvar *global-debugger* t
2034 lgorrie 1.223 "Non-nil means the Swank debugger hook will be installed globally.")
2035    
2036     (add-hook *new-connection-hook* 'install-debugger)
2037     (defun install-debugger (connection)
2038     (declare (ignore connection))
2039     (when *global-debugger*
2040 heller 1.348 (install-debugger-globally #'swank-debugger-hook)))
2041 lgorrie 1.157
2042 lgorrie 1.212 ;;;;; Debugger loop
2043     ;;;
2044     ;;; These variables are dynamically bound during debugging.
2045     ;;;
2046     (defvar *swank-debugger-condition* nil
2047     "The condition being debugged.")
2048    
2049     (defvar *sldb-level* 0
2050     "The current level of recursive debugging.")
2051    
2052     (defvar *sldb-initial-frames* 20
2053     "The initial number of backtrace frames to send to Emacs.")
2054    
2055     (defvar *sldb-restarts* nil
2056     "The list of currenlty active restarts.")
2057    
2058 heller 1.256 (defvar *sldb-stepping-p* nil
2059 jsnellman 1.400 "True during execution of a step command.")
2060 heller 1.256
2061 lgorrie 1.157 (defun debug-in-emacs (condition)
2062 heller 1.38 (let ((*swank-debugger-condition* condition)
2063 heller 1.606 (*sldb-restarts* (compute-restarts condition))
2064 heller 1.718 (*sldb-quit-restart* (and *sldb-quit-restart*
2065     (find-restart *sldb-quit-restart*)))
2066 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
2067     (symbol-value '*buffer-package*))
2068 heller 1.112 *package*))
2069     (*sldb-level* (1+ *sldb-level*))
2070 trittweiler 1.683 (*sldb-stepping-p* nil))
2071 lgorrie 1.157 (force-user-output)
2072 alendvai 1.435 (call-with-debugging-environment
2073 mbaringer 1.470 (lambda ()
2074 trittweiler 1.638 (sldb-loop *sldb-level*)))))
2075 lgorrie 1.80
2076 lgorrie 1.62 (defun sldb-loop (level)
2077 heller 1.119 (unwind-protect
2078 heller 1.558 (loop
2079     (with-simple-restart (abort "Return to sldb level ~D." level)
2080 heller 1.761 (send-to-emacs
2081 heller 1.558 (list* :debug (current-thread-id) level
2082 heller 1.761 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2083 heller 1.589 (send-to-emacs
2084     (list :debug-activate (current-thread-id) level nil))
2085 heller 1.558 (loop
2086 heller 1.589 (handler-case
2087     (destructure-case (wait-for-event
2088     `(or (:emacs-rex . _)
2089     (:sldb-return ,(1+ level))))
2090     ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
2091 heller 1.634 ((:sldb-return _) (declare (ignore _)) (return nil)))
2092 heller 1.558 (sldb-condition (c)
2093     (handle-sldb-condition c))))))
2094     (send-to-emacs `(:debug-return
2095 heller 1.589 ,(current-thread-id) ,level ,*sldb-stepping-p*))
2096     (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
2097     (when (> level 1)
2098     (send-event (current-thread) `(:sldb-return ,level)))))
2099 heller 1.117
2100 lgorrie 1.62 (defun handle-sldb-condition (condition)
2101     "Handle an internal debugger condition.
2102     Rather than recursively debug the debugger (a dangerous idea!), these
2103     conditions are simply reported."
2104     (let ((real-condition (original-condition condition)))
2105 heller 1.557 (send-to-emacs `(:debug-condition ,(current-thread-id)
2106 heller 1.558 ,(princ-to-string real-condition)))))
2107 lgorrie 1.62
2108 mbaringer 1.524 (defvar *sldb-condition-printer* #'format-sldb-condition
2109     "Function called to print a condition to an SLDB buffer.")
2110    
2111 heller 1.86 (defun safe-condition-message (condition)
2112     "Safely print condition to a string, handling any errors during
2113     printing."
2114 heller 1.516 (let ((*print-pretty* t) (*print-right-margin* 65))
2115 heller 1.147 (handler-case
2116 mbaringer 1.524 (funcall