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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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