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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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