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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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