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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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