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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.679 - (hide annotations)
Thu Dec 17 10:15:19 2009 UTC (4 years, 4 months ago) by trittweiler
Branch: MAIN
Changes since 1.678: +19 -6 lines
	* swank.lisp (with-top-level-restart): Bind local special.
	(top-level-restart-p): Check for it; this tells us if where's in
	the dynamic extent of with-top-level-restart.
	(handle-requests): Use it.
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 trittweiler 1.679 (let ((*sldb-quit-restart* (find-restart 'abort))
1002     (*toplevel-restart-available* t))
1003     (declare (special *toplevel-restart-available*))
1004     ,@body)
1005 heller 1.597 (abort (&optional v)
1006     :report "Return to SLIME's top level."
1007     (declare (ignore v))
1008     (force-user-output)
1009     ,k))))
1010 heller 1.456
1011 trittweiler 1.679 (defun top-level-restart-p ()
1012     ;; FIXME: this could probably be done better; previously this used
1013     ;; *SLDB-QUIT-RESTART* but we cannot use that anymore because it's
1014     ;; exported now, and might hence be bound globally.
1015     ;;
1016     ;; The caveat is that for slime rex requests, we do not want to use
1017     ;; the global value of *sldb-quit-restart* because that might be
1018     ;; bound to terminate-thread, and hence `q' in the debugger would
1019     ;; kill the repl thread.
1020     (boundp '*toplevel-restart-available*))
1021    
1022 heller 1.597 (defun handle-requests (connection &optional timeout)
1023     "Read and process :emacs-rex requests.
1024 heller 1.562 The processing is done in the extent of the toplevel restart."
1025 trittweiler 1.679 (cond ((top-level-restart-p)
1026     (assert (boundp '*sldb-quit-restart*))
1027     (assert *emacs-connection*)
1028 heller 1.597 (process-requests timeout))
1029 trittweiler 1.676 (t
1030 heller 1.597 (tagbody
1031 trittweiler 1.679 start
1032 heller 1.597 (with-top-level-restart (connection (go start))
1033     (process-requests timeout))))))
1034 heller 1.562
1035 heller 1.597 (defun process-requests (timeout)
1036 heller 1.562 "Read and process requests from Emacs."
1037     (loop
1038 heller 1.589 (multiple-value-bind (event timeout?)
1039 heller 1.623 (wait-for-event `(or (:emacs-rex . _)
1040     (:emacs-channel-send . _))
1041     timeout)
1042 heller 1.597 (when timeout? (return))
1043 heller 1.623 (destructure-case event
1044     ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
1045     ((:emacs-channel-send channel (selector &rest args))
1046     (channel-send channel selector args))))))
1047 heller 1.97
1048 heller 1.112 (defun current-socket-io ()
1049     (connection.socket-io *emacs-connection*))
1050    
1051 heller 1.556 (defun close-connection (c condition backtrace)
1052 heller 1.566 (let ((*debugger-hook* nil))
1053 heller 1.579 (log-event "close-connection: ~a ...~%" condition)
1054 heller 1.511 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
1055 heller 1.113 (let ((cleanup (connection.cleanup c)))
1056     (when cleanup
1057     (funcall cleanup c)))
1058 heller 1.112 (close (connection.socket-io c))
1059     (when (connection.dedicated-output c)
1060 lgorrie 1.157 (close (connection.dedicated-output c)))
1061 lgorrie 1.197 (setf *connections* (remove c *connections*))
1062 lgorrie 1.217 (run-hook *connection-closed-hook* c)
1063 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
1064 heller 1.511 (finish-output *log-output*)
1065     (format *log-output* "~&;; Event history start:~%")
1066     (dump-event-history *log-output*)
1067     (format *log-output* ";; Event history end.~%~
1068 heller 1.390 ;; Backtrace:~%~{~A~%~}~
1069 heller 1.356 ;; Connection to Emacs lost. [~%~
1070     ;; condition: ~A~%~
1071     ;; type: ~S~%~
1072 heller 1.418 ;; encoding: ~A style: ~S dedicated: ~S]~%"
1073 heller 1.390 backtrace
1074 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
1075     (type-of condition)
1076 heller 1.418 (ignore-errors (stream-external-format (connection.socket-io c)))
1077 heller 1.356 (connection.communication-style c)
1078     *use-dedicated-output-stream*)
1079 heller 1.579 (finish-output *log-output*))
1080     (log-event "close-connection ~a ... done.~%" condition)))
1081 heller 1.180
1082     ;;;;;; Thread based communication
1083    
1084 heller 1.204 (defvar *active-threads* '())
1085    
1086 heller 1.555 (defun read-loop (connection)
1087 heller 1.556 (let ((input-stream (connection.socket-io connection))
1088     (control-thread (connection.control-thread connection)))
1089 trittweiler 1.674 (with-swank-protocol-error-handler (connection)
1090 heller 1.555 (loop (send control-thread (decode-message input-stream))))))
1091    
1092     (defun dispatch-loop (connection)
1093 heller 1.556 (let ((*emacs-connection* connection))
1094 trittweiler 1.674 ;; FIXME: Why do we use WITH-PANIC-HANDLER here, and why is it not
1095     ;; appropriate here to use WITH-SWANK-PROTOCOL-ERROR-HANDLER?
1096     ;; I think this should be documented.
1097 heller 1.563 (with-panic-handler (connection)
1098 heller 1.587 (loop (dispatch-event (receive))))))
1099 heller 1.241
1100 heller 1.554 (defvar *auto-flush-interval* 0.2)
1101    
1102     (defun auto-flush-loop (stream)
1103     (loop
1104     (when (not (and (open-stream-p stream)
1105     (output-stream-p stream)))
1106     (return nil))
1107     (finish-output stream)
1108     (sleep *auto-flush-interval*)))
1109    
1110 heller 1.556 (defun find-repl-thread (connection)
1111     (cond ((not (use-threads-p))
1112     (current-thread))
1113     (t
1114     (let ((thread (connection.repl-thread connection)))
1115 heller 1.619 (cond ((not thread) nil)
1116     ((thread-alive-p thread) thread)
1117 heller 1.556 (t
1118     (setf (connection.repl-thread connection)
1119     (spawn-repl-thread connection "new-repl-thread"))))))))
1120    
1121 heller 1.241 (defun find-worker-thread (id)
1122     (etypecase id
1123     ((member t)
1124     (car *active-threads*))
1125     ((member :repl-thread)
1126 heller 1.556 (find-repl-thread *emacs-connection*))
1127 heller 1.241 (fixnum
1128     (find-thread id))))
1129    
1130 heller 1.204 (defun interrupt-worker-thread (id)
1131 heller 1.241 (let ((thread (or (find-worker-thread id)
1132 heller 1.619 (find-repl-thread *emacs-connection*)
1133     ;; FIXME: to something better here
1134     (spawn (lambda ()) :name "ephemeral"))))
1135     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1136     (assert thread)
1137 heller 1.556 (signal-interrupt thread
1138 heller 1.619 (lambda ()
1139 heller 1.553 (invoke-or-queue-interrupt #'simple-break)))))
1140 heller 1.112
1141 heller 1.204 (defun thread-for-evaluation (id)
1142 heller 1.180 "Find or create a thread to evaluate the next request."
1143     (let ((c *emacs-connection*))
1144 heller 1.204 (etypecase id
1145 heller 1.180 ((member t)
1146 heller 1.556 (cond ((use-threads-p) (spawn-worker-thread c))
1147     (t (current-thread))))
1148 heller 1.180 ((member :repl-thread)
1149 heller 1.556 (find-repl-thread c))
1150 heller 1.180 (fixnum
1151 heller 1.204 (find-thread id)))))
1152 heller 1.274
1153     (defun spawn-worker-thread (connection)
1154     (spawn (lambda ()
1155 heller 1.288 (with-bindings *default-worker-thread-bindings*
1156 heller 1.597 (with-top-level-restart (connection nil)
1157     (apply #'eval-for-emacs
1158     (cdr (wait-for-event `(:emacs-rex . _)))))))
1159 heller 1.274 :name "worker"))
1160    
1161 heller 1.291 (defun spawn-repl-thread (connection name)
1162     (spawn (lambda ()
1163     (with-bindings *default-worker-thread-bindings*
1164     (repl-loop connection)))
1165     :name name))
1166    
1167 heller 1.557 (defun dispatch-event (event)
1168 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
1169 heller 1.556 (log-event "dispatch-event: ~s~%" event)
1170 heller 1.112 (destructure-case event
1171 heller 1.204 ((:emacs-rex form package thread-id id)
1172     (let ((thread (thread-for-evaluation thread-id)))
1173 heller 1.635 (cond (thread
1174     (push thread *active-threads*)
1175     (send-event thread `(:emacs-rex ,form ,package ,id)))
1176     (t
1177     (encode-message
1178     (list :invalid-rpc id
1179     (format nil "Thread not found: ~s" thread-id))
1180     (current-socket-io))))))
1181 heller 1.112 ((:return thread &rest args)
1182 heller 1.204 (let ((tail (member thread *active-threads*)))
1183     (setq *active-threads* (nconc (ldiff *active-threads* tail)
1184 heller 1.557 (cdr tail))))
1185     (encode-message `(:return ,@args) (current-socket-io)))
1186 heller 1.204 ((:emacs-interrupt thread-id)
1187     (interrupt-worker-thread thread-id))
1188 heller 1.622 (((:write-string
1189     :debug :debug-condition :debug-activate :debug-return :channel-send
1190 heller 1.557 :presentation-start :presentation-end
1191     :new-package :new-features :ed :%apply :indentation-update
1192     :eval :eval-no-wait :background-message :inspect :ping
1193 trittweiler 1.647 :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
1194 heller 1.112 &rest _)
1195     (declare (ignore _))
1196 heller 1.557 (encode-message event (current-socket-io)))
1197     (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1198 heller 1.566 (send-event (find-thread thread-id) (cons (car event) args)))
1199 heller 1.623 ((:emacs-channel-send channel-id msg)
1200     (let ((ch (find-channel channel-id)))
1201     (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1202 heller 1.566 (((:end-of-stream))
1203 heller 1.569 (close-connection *emacs-connection* nil (safe-backtrace)))
1204     ((:reader-error packet condition)
1205     (encode-message `(:reader-error ,packet
1206     ,(safe-condition-message condition))
1207     (current-socket-io)))))
1208 heller 1.556
1209     (defvar *event-queue* '())
1210 heller 1.587 (defvar *events-enqueued* 0)
1211 heller 1.556
1212     (defun send-event (thread event)
1213     (log-event "send-event: ~s ~s~%" thread event)
1214     (cond ((use-threads-p) (send thread event))
1215 heller 1.587 (t (setf *event-queue* (nconc *event-queue* (list event)))
1216     (setf *events-enqueued* (mod (1+ *events-enqueued*)
1217     most-positive-fixnum)))))
1218 heller 1.556
1219     (defun send-to-emacs (event)
1220     "Send EVENT to Emacs."
1221 heller 1.566 ;;(log-event "send-to-emacs: ~a" event)
1222 heller 1.556 (cond ((use-threads-p)
1223     (send (connection.control-thread *emacs-connection*) event))
1224     (t (dispatch-event event))))
1225    
1226 heller 1.619 (defun signal-interrupt (thread interrupt)
1227     (log-event "signal-interrupt [~a]: ~a ~a~%" (use-threads-p) thread interrupt)
1228 heller 1.556 (cond ((use-threads-p) (interrupt-thread thread interrupt))
1229     (t (funcall interrupt))))
1230    
1231 heller 1.589 (defun wait-for-event (pattern &optional timeout)
1232 heller 1.562 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1233 heller 1.587 (without-slime-interrupts
1234     (cond ((use-threads-p)
1235     (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1236     (t
1237 heller 1.589 (wait-for-event/event-loop pattern timeout)))))
1238 heller 1.556
1239 heller 1.589 (defun wait-for-event/event-loop (pattern timeout)
1240 heller 1.562 (assert (or (not timeout) (eq timeout t)))
1241 heller 1.556 (loop
1242 heller 1.589 (check-slime-interrupts)
1243 heller 1.587 (let ((event (poll-for-event pattern)))
1244     (when event (return (car event))))
1245     (let ((events-enqueued *events-enqueued*)
1246     (ready (wait-for-input (list (current-socket-io)) timeout)))
1247     (cond ((and timeout (not ready))
1248     (return (values nil t)))
1249     ((or (/= events-enqueued *events-enqueued*)
1250     (eq ready :interrupt))
1251     ;; rescan event queue, interrupts may enqueue new events
1252     )
1253     (t
1254     (assert (equal ready (list (current-socket-io))))
1255     (dispatch-event (decode-message (current-socket-io))))))))
1256    
1257     (defun poll-for-event (pattern)
1258     (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1259     *event-queue*)))
1260     (when tail
1261     (setq *event-queue* (nconc (ldiff *event-queue* tail)
1262     (cdr tail)))
1263     tail)))
1264 heller 1.556
1265 trittweiler 1.669 ;;; FIXME: Make this use SWANK-MATCH.
1266 heller 1.556 (defun event-match-p (event pattern)
1267     (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1268     (member pattern '(nil t)))
1269     (equal event pattern))
1270     ((symbolp pattern) t)
1271     ((consp pattern)
1272 heller 1.589 (case (car pattern)
1273     ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1274     (t (and (consp event)
1275     (and (event-match-p (car event) (car pattern))
1276     (event-match-p (cdr event) (cdr pattern)))))))
1277     (t (error "Invalid pattern: ~S" pattern))))
1278 heller 1.112
1279 heller 1.153 (defun spawn-threads-for-connection (connection)
1280 heller 1.555 (setf (connection.control-thread connection)
1281     (spawn (lambda () (control-thread connection))
1282     :name "control-thread"))
1283     connection)
1284    
1285     (defun control-thread (connection)
1286 heller 1.556 (with-struct* (connection. @ connection)
1287     (setf (@ control-thread) (current-thread))
1288     (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1289     :name "reader-thread"))
1290     (dispatch-loop connection)))
1291 heller 1.153
1292 lgorrie 1.236 (defun cleanup-connection-threads (connection)
1293 heller 1.266 (let ((threads (list (connection.repl-thread connection)
1294     (connection.reader-thread connection)
1295 heller 1.613 (connection.control-thread connection)
1296     (connection.auto-flush-thread connection))))
1297 heller 1.266 (dolist (thread threads)
1298 heller 1.357 (when (and thread
1299     (thread-alive-p thread)
1300     (not (equal (current-thread) thread)))
1301 heller 1.266 (kill-thread thread)))))
1302 lgorrie 1.236
1303 lgorrie 1.173 (defun repl-loop (connection)
1304 heller 1.562 (handle-requests connection))
1305 heller 1.396
1306 heller 1.123 ;;;;;; Signal driven IO
1307    
1308 heller 1.112 (defun install-sigio-handler (connection)
1309 heller 1.566 (add-sigio-handler (connection.socket-io connection)
1310     (lambda () (process-io-interrupt connection)))
1311 heller 1.597 (handle-requests connection t))
1312 heller 1.566
1313 heller 1.579 (defvar *io-interupt-level* 0)
1314    
1315 heller 1.566 (defun process-io-interrupt (connection)
1316 heller 1.578 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1317     (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1318     (invoke-or-queue-interrupt
1319 heller 1.597 (lambda () (handle-requests connection t))))
1320 heller 1.578 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1321 heller 1.566
1322 heller 1.123 (defun deinstall-sigio-handler (connection)
1323 heller 1.566 (log-event "deinstall-sigio-handler...~%")
1324 heller 1.579 (remove-sigio-handlers (connection.socket-io connection))
1325 heller 1.566 (log-event "deinstall-sigio-handler...done~%"))
1326 heller 1.123
1327     ;;;;;; SERVE-EVENT based IO
1328    
1329     (defun install-fd-handler (connection)
1330 heller 1.566 (add-fd-handler (connection.socket-io connection)
1331 heller 1.597 (lambda () (handle-requests connection t)))
1332 heller 1.566 (setf (connection.saved-sigint-handler connection)
1333 heller 1.567 (install-sigint-handler
1334     (lambda ()
1335     (invoke-or-queue-interrupt
1336     (lambda ()
1337 heller 1.571 (with-connection (connection)
1338 heller 1.587 (dispatch-interrupt-event)))))))
1339 heller 1.597 (handle-requests connection t))
1340 heller 1.123
1341 heller 1.587 (defun dispatch-interrupt-event ()
1342     (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
1343    
1344 heller 1.123 (defun deinstall-fd-handler (connection)
1345 heller 1.577 (log-event "deinstall-fd-handler~%")
1346 heller 1.566 (remove-fd-handlers (connection.socket-io connection))
1347     (install-sigint-handler (connection.saved-sigint-handler connection)))
1348 heller 1.123
1349     ;;;;;; Simple sequential IO
1350 heller 1.112
1351     (defun simple-serve-requests (connection)
1352 heller 1.390 (unwind-protect
1353 heller 1.640 (with-connection (connection)
1354     (call-with-user-break-handler
1355     (lambda ()
1356     (invoke-or-queue-interrupt #'dispatch-interrupt-event))
1357     (lambda ()
1358     (with-simple-restart (close-connection "Close SLIME connection")
1359     ;;(handle-requests connection)
1360     (let* ((stdin (real-input-stream *standard-input*))
1361     (*standard-input* (make-repl-input-stream connection
1362     stdin)))
1363 trittweiler 1.674 (with-swank-protocol-error-handler (connection)
1364 heller 1.640 (simple-repl)))))))
1365 heller 1.556 (close-connection connection nil (safe-backtrace))))
1366 heller 1.112
1367 heller 1.614 (defun simple-repl ()
1368     (loop
1369     (with-simple-restart (abort "Abort")
1370     (format t "~&~a> " (package-string-for-prompt *package*))
1371     (force-output)
1372     (let ((form (read)))
1373     (fresh-line)
1374     (let ((- form)
1375     (values (multiple-value-list (eval form))))
1376     (setq *** ** ** * * (car values)
1377     /// // // / / values
1378     +++ ++ ++ + + form)
1379     (cond ((null values) (format t "~&; No values"))
1380     (t (mapc (lambda (v) (format t "~&~s" v)) values))))))))
1381    
1382     (defun make-repl-input-stream (connection stdin)
1383     (make-input-stream
1384     (lambda ()
1385 heller 1.640 (log-event "pull-input: ~a ~a ~a~%"
1386     (connection.socket-io connection)
1387     (if (open-stream-p (connection.socket-io connection))
1388     :socket-open :socket-closed)
1389     (if (open-stream-p stdin)
1390     :stdin-open :stdin-closed))
1391 heller 1.614 (loop
1392 heller 1.640 (let* ((socket (connection.socket-io connection))
1393     (inputs (list socket stdin))
1394     (ready (wait-for-input inputs)))
1395     (cond ((eq ready :interrupt)
1396     (check-slime-interrupts))
1397     ((member socket ready)
1398 trittweiler 1.655 ;; A Slime request from Emacs is pending; make sure to
1399     ;; redirect IO to the REPL buffer.
1400     (with-io-redirection (connection)
1401     (handle-requests connection t)))
1402 heller 1.640 ((member stdin ready)
1403 trittweiler 1.655 ;; User typed something into the *inferior-lisp* buffer,
1404     ;; so do not redirect.
1405 heller 1.640 (return (read-non-blocking stdin)))
1406     (t (assert (null ready)))))))))
1407 heller 1.614
1408     (defun read-non-blocking (stream)
1409     (with-output-to-string (str)
1410     (loop (let ((c (read-char-no-hang stream)))
1411     (unless c (return))
1412     (write-char c str)))))
1413    
1414 heller 1.418 (defun create-connection (socket-io style)
1415 dcrosher 1.368 (let ((success nil))
1416     (unwind-protect
1417     (let ((c (ecase style
1418     (:spawn
1419     (make-connection :socket-io socket-io
1420     :serve-requests #'spawn-threads-for-connection
1421     :cleanup #'cleanup-connection-threads))
1422     (:sigio
1423     (make-connection :socket-io socket-io
1424     :serve-requests #'install-sigio-handler
1425     :cleanup #'deinstall-sigio-handler))
1426     (:fd-handler
1427     (make-connection :socket-io socket-io
1428     :serve-requests #'install-fd-handler
1429     :cleanup #'deinstall-fd-handler))
1430     ((nil)
1431     (make-connection :socket-io socket-io
1432 heller 1.549 :serve-requests #'simple-serve-requests))
1433     )))
1434 dcrosher 1.368 (setf (connection.communication-style c) style)
1435     (setf success t)
1436     c)
1437     (unless success
1438     (close socket-io :abort t)))))
1439 heller 1.180
1440 lgorrie 1.80
1441 lgorrie 1.62 ;;;; IO to Emacs
1442     ;;;
1443 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
1444     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1445     ;;; contains the appropriate streams, so all we have to do is make the
1446     ;;; right bindings.
1447    
1448     ;;;;; Global I/O redirection framework
1449     ;;;
1450     ;;; Optionally, the top-level global bindings of the standard streams
1451     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1452     ;;; redirect the streams into the connection, and they keep going into
1453     ;;; that connection even if more are established. If the connection
1454     ;;; handling the streams closes then another is chosen, or if there
1455     ;;; are no connections then we revert to the original (real) streams.
1456     ;;;
1457     ;;; It is slightly tricky to assign the global values of standard
1458     ;;; streams because they are often shadowed by dynamic bindings. We
1459     ;;; solve this problem by introducing an extra indirection via synonym
1460     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1461     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1462     ;;; variables, so they can always be assigned to affect a global
1463     ;;; change.
1464    
1465 heller 1.405 (defvar *globally-redirect-io* nil
1466 lgorrie 1.197 "When non-nil globally redirect all standard streams to Emacs.")
1467    
1468 heller 1.405 ;;;;; Global redirection setup
1469    
1470     (defvar *saved-global-streams* '()
1471     "A plist to save and restore redirected stream objects.
1472     E.g. the value for '*standard-output* holds the stream object
1473     for *standard-output* before we install our redirection.")
1474    
1475     (defun setup-stream-indirection (stream-var &optional stream)
1476 lgorrie 1.197 "Setup redirection scaffolding for a global stream variable.
1477     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1478    
1479 heller 1.405 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1480 lgorrie 1.197
1481     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1482     *STANDARD-INPUT*.
1483    
1484     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1485     *CURRENT-STANDARD-INPUT*.
1486    
1487     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1488 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
1489     the effective global value even when *STANDARD-INPUT* is shadowed by a
1490     dynamic binding."
1491 heller 1.405 (let ((current-stream-var (prefixed-var '#:current stream-var))
1492     (stream (or stream (symbol-value stream-var))))
1493     ;; Save the real stream value for the future.
1494     (setf (getf *saved-global-streams* stream-var) stream)
1495     ;; Define a new variable for the effective stream.
1496     ;; This can be reassigned.
1497     (proclaim `(special ,current-stream-var))
1498     (set current-stream-var stream)
1499     ;; Assign the real binding as a synonym for the current one.
1500 heller 1.630 (let ((stream (make-synonym-stream current-stream-var)))
1501     (set stream-var stream)
1502     (set-default-initial-binding stream-var `(quote ,stream)))))
1503 heller 1.405
1504     (defun prefixed-var (prefix variable-symbol)
1505     "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1506     (let ((basename (subseq (symbol-name variable-symbol) 1)))
1507     (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1508 lgorrie 1.199
1509 heller 1.405 (defvar *standard-output-streams*
1510 lgorrie 1.197 '(*standard-output* *error-output* *trace-output*)
1511     "The symbols naming standard output streams.")
1512    
1513 heller 1.405 (defvar *standard-input-streams*
1514 lgorrie 1.197 '(*standard-input*)
1515     "The symbols naming standard input streams.")
1516    
1517 heller 1.405 (defvar *standard-io-streams*
1518 lgorrie 1.197 '(*debug-io* *query-io* *terminal-io*)
1519     "The symbols naming standard io streams.")
1520    
1521 heller 1.405 (defun init-global-stream-redirection ()
1522     (when *globally-redirect-io*
1523 heller 1.658 (cond (*saved-global-streams*
1524     (warn "Streams already redirected."))
1525     (t
1526     (mapc #'setup-stream-indirection
1527     (append *standard-output-streams*
1528     *standard-input-streams*
1529     *standard-io-streams*))))))
1530 heller 1.405
1531     (add-hook *after-init-hook* 'init-global-stream-redirection)
1532    
1533 lgorrie 1.197 (defun globally-redirect-io-to-connection (connection)
1534     "Set the standard I/O streams to redirect to CONNECTION.
1535     Assigns *CURRENT-<STREAM>* for all standard streams."
1536     (dolist (o *standard-output-streams*)
1537 dcrosher 1.363 (set (prefixed-var '#:current o)
1538 lgorrie 1.197 (connection.user-output connection)))
1539     ;; FIXME: If we redirect standard input to Emacs then we get the
1540     ;; regular Lisp top-level trying to read from our REPL.
1541     ;;
1542     ;; Perhaps the ideal would be for the real top-level to run in a
1543     ;; thread with local bindings for all the standard streams. Failing
1544     ;; that we probably would like to inhibit it from reading while
1545     ;; Emacs is connected.
1546     ;;
1547     ;; Meanwhile we just leave *standard-input* alone.
1548     #+NIL
1549     (dolist (i *standard-input-streams*)
1550 dcrosher 1.363 (set (prefixed-var '#:current i)
1551 lgorrie 1.197 (connection.user-input connection)))
1552     (dolist (io *standard-io-streams*)
1553 dcrosher 1.363 (set (prefixed-var '#:current io)
1554 lgorrie 1.197 (connection.user-io connection))))
1555    
1556     (defun revert-global-io-redirection ()
1557     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1558     (dolist (stream-var (append *standard-output-streams*
1559     *standard-input-streams*
1560     *standard-io-streams*))
1561 dcrosher 1.363 (set (prefixed-var '#:current stream-var)
1562 heller 1.405 (getf *saved-global-streams* stream-var))))
1563 lgorrie 1.197
1564     ;;;;; Global redirection hooks
1565    
1566     (defvar *global-stdio-connection* nil
1567     "The connection to which standard I/O streams are globally redirected.
1568     NIL if streams are not globally redirected.")
1569    
1570     (defun maybe-redirect-global-io (connection)
1571 heller 1.620 "Consider globally redirecting to CONNECTION."
1572     (when (and *globally-redirect-io* (null *global-stdio-connection*)
1573     (connection.user-io connection))
1574 lgorrie 1.197 (setq *global-stdio-connection* connection)
1575     (globally-redirect-io-to-connection connection)))
1576    
1577     (defun update-redirection-after-close (closed-connection)
1578     "Update redirection after a connection closes."
1579 heller 1.511 (check-type closed-connection connection)
1580 lgorrie 1.197 (when (eq *global-stdio-connection* closed-connection)
1581     (if (and (default-connection) *globally-redirect-io*)
1582     ;; Redirect to another connection.
1583     (globally-redirect-io-to-connection (default-connection))
1584     ;; No more connections, revert to the real streams.
1585     (progn (revert-global-io-redirection)
1586     (setq *global-stdio-connection* nil)))))
1587    
1588     (add-hook *connection-closed-hook* 'update-redirection-after-close)
1589    
1590     ;;;;; Redirection during requests
1591     ;;;
1592     ;;; We always redirect the standard streams to Emacs while evaluating
1593     ;;; an RPC. This is done with simple dynamic bindings.
1594 dbarlow 1.28
1595 heller 1.615 (defslimefun create-repl (target)
1596     (assert (eq target nil))
1597     (let ((conn *emacs-connection*))
1598     (initialize-streams-for-connection conn)
1599     (with-struct* (connection. @ conn)
1600     (setf (@ env)
1601     `((*standard-output* . ,(@ user-output))
1602 heller 1.616 (*standard-input* . ,(@ user-input))
1603     (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1604     (*error-output* . ,(@ user-output))
1605     (*debug-io* . ,(@ user-io))
1606     (*query-io* . ,(@ user-io))
1607     (*terminal-io* . ,(@ user-io))))
1608 heller 1.620 (maybe-redirect-global-io conn)
1609 heller 1.617 (when (use-threads-p)
1610 heller 1.615 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1611 heller 1.617 (list (package-name *package*)
1612     (package-string-for-prompt *package*)))))
1613 heller 1.615
1614     (defun initialize-streams-for-connection (connection)
1615     (multiple-value-bind (dedicated in out io repl-results)
1616     (open-streams connection)
1617     (setf (connection.dedicated-output connection) dedicated
1618     (connection.user-io connection) io
1619     (connection.user-output connection) out
1620     (connection.user-input connection) in
1621     (connection.repl-results connection) repl-results)
1622     connection))
1623 lgorrie 1.90
1624 heller 1.623
1625     ;;; Channels
1626    
1627     (defvar *channels* '())
1628     (defvar *channel-counter* 0)
1629    
1630     (defclass channel ()
1631     ((id :reader channel-id)
1632     (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1633     (name :initarg :name :initform nil)))
1634    
1635     (defmethod initialize-instance ((ch channel) &rest initargs)
1636     (declare (ignore initargs))
1637     (call-next-method)
1638     (with-slots (id) ch
1639     (setf id (incf *channel-counter*))
1640     (push (cons id ch) *channels*)))
1641    
1642     (defmethod print-object ((c channel) stream)
1643     (print-unreadable-object (c stream :type t)
1644     (with-slots (id name) c
1645     (format stream "~d ~a" id name))))
1646    
1647     (defun find-channel (id)
1648     (cdr (assoc id *channels*)))
1649    
1650     (defgeneric channel-send (channel selector args))
1651    
1652     (defmacro define-channel-method (selector (channel &rest args) &body body)
1653     `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1654     (destructuring-bind ,args args
1655     . ,body)))
1656    
1657     (defun send-to-remote-channel (channel-id msg)
1658     (send-to-emacs `(:channel-send ,channel-id ,msg)))
1659    
1660     (defclass listener-channel (channel)
1661     ((remote :initarg :remote)
1662     (env :initarg :env)))
1663    
1664     (defslimefun create-listener (remote)
1665     (let* ((pkg *package*)
1666     (conn *emacs-connection*)
1667     (ch (make-instance 'listener-channel
1668     :remote remote
1669     :env (initial-listener-bindings remote))))
1670    
1671     (with-slots (thread id) ch
1672     (when (use-threads-p)
1673     (setf thread (spawn-listener-thread ch conn)))
1674     (list id
1675     (thread-id thread)
1676     (package-name pkg)
1677     (package-string-for-prompt pkg)))))
1678    
1679     (defun initial-listener-bindings (remote)
1680     `((*package* . ,*package*)
1681     (*standard-output*
1682     . ,(make-listener-output-stream remote))
1683     (*standard-input*
1684     . ,(make-listener-input-stream remote))))
1685    
1686     (defun spawn-listener-thread (channel connection)
1687     (spawn (lambda ()
1688     (with-connection (connection)
1689     (loop
1690     (destructure-case (wait-for-event `(:emacs-channel-send . _))
1691     ((:emacs-channel-send c (selector &rest args))
1692     (assert (eq c channel))
1693     (channel-send channel selector args))))))
1694     :name "swank-listener-thread"))
1695    
1696     (define-channel-method :eval ((c listener-channel) string)
1697     (with-slots (remote env) c
1698     (let ((aborted t))
1699     (with-bindings env
1700     (unwind-protect
1701     (let* ((form (read-from-string string))
1702     (value (eval form)))
1703     (send-to-remote-channel remote
1704     `(:write-result
1705     ,(prin1-to-string value)))
1706     (setq aborted nil))
1707     (force-output)
1708     (setf env (loop for (sym) in env
1709     collect (cons sym (symbol-value sym))))
1710     (let ((pkg (package-name *package*))
1711     (prompt (package-string-for-prompt *package*)))
1712     (send-to-remote-channel remote
1713     (if aborted
1714     `(:evaluation-aborted ,pkg ,prompt)
1715     `(:prompt ,pkg ,prompt)))))))))
1716    
1717     (defun make-listener-output-stream (remote)
1718     (make-output-stream (lambda (string)
1719     (send-to-remote-channel remote
1720     `(:write-string ,string)))))
1721    
1722     (defun make-listener-input-stream (remote)
1723     (make-input-stream
1724     (lambda ()
1725     (force-output)
1726     (let ((tag (make-tag)))
1727     (send-to-remote-channel remote
1728     `(:read-string ,(current-thread-id) ,tag))
1729     (let ((ok nil))
1730     (unwind-protect
1731     (prog1 (caddr (wait-for-event
1732     `(:emacs-return-string ,tag value)))
1733     (setq ok t))
1734     (unless ok
1735     (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1736    
1737 sboukarev 1.665
1738 trittweiler 1.545
1739 heller 1.587 (defun decode-message (stream)
1740 heller 1.390 "Read an S-expression from STREAM using the SLIME protocol."
1741 heller 1.566 ;;(log-event "decode-message~%")
1742 heller 1.112 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1743 trittweiler 1.674 (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
1744 heller 1.587 (let ((packet (read-packet stream)))
1745     (handler-case (values (read-form packet) nil)
1746     (reader-error (c)
1747     `(:reader-error ,packet ,c)))))))
1748 heller 1.566
1749 heller 1.589 ;; use peek-char to detect EOF, read-sequence may return 0 instead of
1750     ;; signaling a condition.
1751 heller 1.566 (defun read-packet (stream)
1752 heller 1.589 (peek-char nil stream)
1753 heller 1.566 (let* ((header (read-chunk stream 6))
1754     (length (parse-integer header :radix #x10))
1755     (payload (read-chunk stream length)))
1756     (log-event "READ: ~S~%" payload)
1757     payload))
1758    
1759     (defun read-chunk (stream length)
1760     (let* ((buffer (make-string length))
1761     (count (read-sequence buffer stream)))
1762     (assert (= count length) () "Short read: length=~D count=~D" length count)
1763     buffer))
1764 dbarlow 1.28
1765     (defun read-form (string)
1766     (with-standard-io-syntax
1767     (let ((*package* *swank-io-package*))
1768     (read-from-string string))))
1769    
1770 heller 1.562 (defun input-available-p (stream)
1771     ;; return true iff we can read from STREAM without waiting or if we
1772     ;; hit EOF
1773     (let ((c (read-char-no-hang stream nil :eof)))
1774     (cond ((not c) nil)
1775     ((eq c :eof) t)
1776     (t
1777     (unread-char c stream)
1778     t))))
1779    
1780 lgorrie 1.50 (defvar *slime-features* nil
1781     "The feature list that has been sent to Emacs.")
1782    
1783 lgorrie 1.104 (defun send-oob-to-emacs (object)
1784 heller 1.112 (send-to-emacs object))
1785    
1786     (defun encode-message (message stream)
1787 trittweiler 1.674 (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
1788 heller 1.640 (let* ((string (prin1-to-string-for-emacs message))
1789     (length (length string)))
1790     (log-event "WRITE: ~A~%" string)
1791     (let ((*print-pretty* nil))
1792     (format stream "~6,'0x" length))
1793     (write-string string stream)
1794     (finish-output stream))))
1795    
1796 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
1797 heller 1.31 (with-standard-io-syntax
1798     (let ((*print-case* :downcase)
1799 heller 1.185 (*print-readably* nil)
1800 heller 1.31 (*print-pretty* nil)
1801     (*package* *swank-io-package*))
1802     (prin1-to-string object))))
1803 dbarlow 1.28
1804 heller 1.112 (defun force-user-output ()
1805 heller 1.551 (force-output (connection.user-io *emacs-connection*)))
1806 heller 1.112
1807 heller 1.592 (add-hook *pre-reply-hook* 'force-user-output)
1808    
1809 heller 1.112 (defun clear-user-input ()
1810     (clear-input (connection.user-input *emacs-connection*)))
1811 lgorrie 1.62
1812 heller 1.557 (defvar *tag-counter* 0)
1813 lgorrie 1.91
1814 heller 1.557 (defun make-tag ()
1815     (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1816 heller 1.232
1817 heller 1.112 (defun read-user-input-from-emacs ()
1818 heller 1.557 (let ((tag (make-tag)))
1819 heller 1.117 (force-output)
1820 heller 1.557 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1821 lgorrie 1.90 (let ((ok nil))
1822 lgorrie 1.62 (unwind-protect
1823 heller 1.557 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1824 lgorrie 1.62 (setq ok t))
1825     (unless ok
1826 heller 1.557 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1827 mkoeppe 1.327
1828 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1829 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1830 heller 1.557 (let ((tag (make-tag))
1831 heller 1.330 (question (apply #'format nil format-string arguments)))
1832 mkoeppe 1.327 (force-output)
1833 heller 1.557 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1834 trittweiler 1.647 (third (wait-for-event `(:emacs-return ,tag result)))))
1835    
1836     (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1837     "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1838     entered nothing, returns NIL when user pressed C-g."
1839     (check-type prompt string) (check-type initial-value (or null string))
1840     (let ((tag (make-tag)))
1841     (force-output)
1842     (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1843     ,prompt ,initial-value))
1844     (third (wait-for-event `(:emacs-return ,tag result)))))
1845    
1846 mbaringer 1.279
1847 mbaringer 1.346 (defun process-form-for-emacs (form)
1848     "Returns a string which emacs will read as equivalent to
1849     FORM. FORM can contain lists, strings, characters, symbols and
1850     numbers.
1851    
1852     Characters are converted emacs' ?<char> notaion, strings are left
1853     as they are (except for espacing any nested \" chars, numbers are
1854 alendvai 1.447 printed in base 10 and symbols are printed as their symbol-name
1855 mbaringer 1.346 converted to lower case."
1856     (etypecase form
1857     (string (format nil "~S" form))
1858     (cons (format nil "(~A . ~A)"
1859     (process-form-for-emacs (car form))
1860     (process-form-for-emacs (cdr form))))
1861     (character (format nil "?~C" form))
1862 alendvai 1.447 (symbol (concatenate 'string (when (eq (symbol-package form)
1863     #.(find-package "KEYWORD"))
1864     ":")
1865     (string-downcase (symbol-name form))))
1866 mbaringer 1.346 (number (let ((*print-base* 10))
1867     (princ-to-string form)))))
1868    
1869 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1870     "Eval FORM in Emacs."
1871 mbaringer 1.346 (cond (nowait
1872     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1873     (t
1874     (force-output)
1875 heller 1.557 (let ((tag (make-tag)))
1876     (send-to-emacs `(:eval ,(current-thread-id) ,tag
1877     ,(process-form-for-emacs form)))
1878     (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1879     (destructure-case value
1880     ((:ok value) value)
1881     ((:abort) (abort))))))))
1882 heller 1.337
1883 mbaringer 1.414 (defvar *swank-wire-protocol-version* nil
1884 heller 1.418 "The version of the swank/slime communication protocol.")
1885 mbaringer 1.414
1886 heller 1.126 (defslimefun connection-info ()
1887 heller 1.343 "Return a key-value list of the form:
1888 heller 1.418 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1889 heller 1.343 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1890     STYLE: the communication style
1891 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1892 heller 1.343 FEATURES: a list of keywords
1893 mbaringer 1.413 PACKAGE: a list (&key NAME PROMPT)
1894 heller 1.418 VERSION: the protocol version"
1895 heller 1.260 (setq *slime-features* *features*)
1896 heller 1.343 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1897     :lisp-implementation (:type ,(lisp-implementation-type)
1898 heller 1.350 :name ,(lisp-implementation-type-name)
1899 heller 1.343 :version ,(lisp-implementation-version))
1900     :machine (:instance ,(machine-instance)
1901     :type ,(machine-type)
1902     :version ,(machine-version))
1903     :features ,(features-for-emacs)
1904 heller 1.518 :modules ,*modules*
1905 heller 1.343 :package (:name ,(package-name *package*)
1906 mbaringer 1.413 :prompt ,(package-string-for-prompt *package*))
1907 heller 1.418 :version ,*swank-wire-protocol-version*))
1908 lgorrie 1.62
1909 heller 1.551 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1910 heller 1.339 (let* ((s *standard-output*)
1911     (*trace-output* (make-broadcast-stream s *log-output*)))
1912 heller 1.337 (time (progn
1913     (dotimes (i n)
1914     (format s "~D abcdefghijklm~%" i)
1915     (when (zerop (mod n m))
1916 heller 1.551 (finish-output s)))
1917 heller 1.337 (finish-output s)
1918 heller 1.339 (when *emacs-connection*
1919     (eval-in-emacs '(message "done.")))))
1920     (terpri *trace-output*)
1921     (finish-output *trace-output*)
1922 heller 1.337 nil))
1923    
1924 trittweiler 1.674 (defun debug-on-swank-error ()
1925     (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1926     *debug-on-swank-protocol-error*)
1927    
1928     (defun (setf debug-on-swank-error) (new-value)
1929     (setf *debug-on-swank-protocol-error* new-value)
1930     (setf *debug-swank-backend* new-value))
1931    
1932     (defslimefun toggle-debug-on-swank-error ()
1933     (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1934    
1935 lgorrie 1.62
1936     ;;;; Reading and printing
1937 dbarlow 1.28
1938 heller 1.207 (define-special *buffer-package*
1939     "Package corresponding to slime-buffer-package.
1940 dbarlow 1.28
1941 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1942 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1943    
1944 heller 1.207 (define-special *buffer-readtable*
1945     "Readtable associated with the current buffer")
1946 heller 1.189
1947 heller 1.568 (defmacro with-buffer-syntax ((&optional package) &body body)
1948 heller 1.189 "Execute BODY with appropriate *package* and *readtable* bindings.
1949    
1950     This should be used for code that is conceptionally executed in an
1951     Emacs buffer."
1952 heller 1.568 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1953 heller 1.293
1954 heller 1.568 (defun call-with-buffer-syntax (package fun)
1955     (let ((*package* (if package
1956     (guess-buffer-package package)
1957     *buffer-package*)))
1958 heller 1.293 ;; Don't shadow *readtable* unnecessarily because that prevents
1959     ;; the user from assigning to it.
1960     (if (eq *readtable* *buffer-readtable*)
1961     (call-with-syntax-hooks fun)
1962     (let ((*readtable* *buffer-readtable*))
1963     (call-with-syntax-hooks fun)))))
1964 heller 1.189
1965 trittweiler 1.664 (defmacro without-printing-errors ((&key object stream
1966     (msg "<<error printing object>>"))
1967     &body body)
1968     "Catches errors during evaluation of BODY and prints MSG instead."
1969     `(handler-case (progn ,@body)
1970     (serious-condition ()
1971     ,(cond ((and stream object)
1972     (let ((gstream (gensym "STREAM+")))
1973     `(let ((,gstream ,stream))
1974     (print-unreadable-object (,object ,gstream :type t :identity t)
1975     (write-string ,msg ,gstream)))))
1976     (stream
1977     `(write-string ,msg ,stream))
1978     (object
1979     `(with-output-to-string (s)
1980     (print-unreadable-object (,object s :type t :identity t)
1981     (write-string ,msg s))))
1982     (t msg)))))
1983    
1984 heller 1.330 (defun to-string (object)
1985     "Write OBJECT in the *BUFFER-PACKAGE*.
1986 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1987     gracefully."
1988 heller 1.330 (with-buffer-syntax ()
1989     (let ((*print-readably* nil))
1990 trittweiler 1.664 (without-printing-errors (:object object :stream nil)
1991     (prin1-to-string object)))))
1992    
1993     (defun to-line (object &optional (width 75))
1994     "Print OBJECT to a single line. Return the string."
1995     (without-printing-errors (:object object :stream nil)
1996     (call/truncated-output-to-string
1997     width
1998     (lambda (*standard-output*)
1999     (write object :right-margin width :lines 1))
2000     "..")))
2001 heller 1.330
2002 dbarlow 1.28 (defun from-string (string)
2003     "Read string in the *BUFFER-PACKAGE*"
2004 heller 1.189 (with-buffer-syntax ()
2005     (let ((*read-suppress* nil))
2006 trittweiler 1.666 (values (read-from-string string)))))
2007 lgorrie 1.60
2008 heller 1.568 (defun parse-string (string package)
2009     "Read STRING in PACKAGE."
2010     (with-buffer-syntax (package)
2011     (let ((*read-suppress* nil))
2012     (read-from-string string))))
2013    
2014 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
2015     (defun tokenize-symbol (string)
2016 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
2017     and is tokenized accordingly. The result is returned in three
2018     values: The package identifier part, the actual symbol identifier
2019     part, and a flag if the STRING represents a symbol that is
2020     internal to the package identifier part. (Notice that the flag is
2021     also true with an empty package identifier part, as the STRING is
2022     considered to represent a symbol internal to some current package.)"
2023 heller 1.245 (let ((package (let ((pos (position #\: string)))
2024     (if pos (subseq string 0 pos) nil)))
2025     (symbol (let ((pos (position #\: string :from-end t)))
2026     (if pos (subseq string (1+ pos)) string)))
2027 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
2028 heller 1.245 (values symbol package internp)))
2029    
2030 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
2031 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
2032 mkoeppe 1.370 (let ((package nil)
2033     (token (make-array (length string) :element-type 'character
2034     :fill-pointer 0))
2035     (backslash nil)
2036     (vertical nil)
2037     (internp nil))
2038 trittweiler 1.648 (loop for char across string do
2039     (cond
2040 mkoeppe 1.370 (backslash
2041     (vector-push-extend char token)
2042     (setq backslash nil))
2043     ((char= char #\\) ; Quotes next character, even within |...|
2044     (setq backslash t))
2045     ((char= char #\|)
2046 trittweiler 1.648 (setq vertical (not vertical)))
2047 mkoeppe 1.370 (vertical
2048     (vector-push-extend char token))
2049     ((char= char #\:)
2050 trittweiler 1.648 (cond ((and package internp)
2051 sboukarev 1.670 (return-from tokenize-symbol-thoroughly))
2052 trittweiler 1.648 (package
2053     (setq internp t))
2054     (t
2055     (setq package token
2056     token (make-array (length string)
2057     :element-type 'character
2058     :fill-pointer 0)))))
2059 mkoeppe 1.370 (t
2060     (vector-push-extend (casify-char char) token))))
2061 sboukarev 1.670 (unless vertical
2062     (values token package (or (not package) internp)))))
2063 mkoeppe 1.370
2064 trittweiler 1.488 (defun untokenize-symbol (package-name internal-p symbol-name)
2065     "The inverse of TOKENIZE-SYMBOL.
2066    
2067     (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
2068     (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
2069     (untokenize-symbol nil nil \"foo\") ==> \"foo\"
2070     "
2071 heller 1.507 (cond ((not package-name) symbol-name)
2072     (internal-p (cat package-name "::" symbol-name))
2073     (t (cat package-name ":" symbol-name))))
2074 trittweiler 1.488
2075 mkoeppe 1.370 (defun casify-char (char)
2076     "Convert CHAR accoring to readtable-case."
2077 heller 1.245 (ecase (readtable-case *readtable*)
2078 mkoeppe 1.370 (:preserve char)
2079     (:upcase (char-upcase char))
2080     (:downcase (char-downcase char))
2081     (:invert (if (upper-case-p char)
2082     (char-downcase char)
2083     (char-upcase char)))))
2084 heller 1.245
2085 trittweiler 1.668
2086     (defun find-symbol-with-status (symbol-name status &optional (package *package*))
2087     (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
2088     (if (and flag (eq flag status))
2089     (values symbol flag)
2090     (values nil nil))))
2091    
2092 heller 1.207 (defun parse-symbol (string &optional (package *package*))
2093 heller 1.189 "Find the symbol named STRING.
2094 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
2095 trittweiler 1.668 (multiple-value-bind (sname pname internalp)
2096     (tokenize-symbol-thoroughly string)
2097 sboukarev 1.670 (when sname
2098     (let ((package (cond ((string= pname "") keyword-package)
2099     (pname (find-package pname))
2100     (t package))))
2101     (if package
2102     (multiple-value-bind (symbol flag)
2103     (if internalp
2104     (find-symbol sname package)
2105     (find-symbol-with-status sname ':external package))
2106     (values symbol flag sname package))
2107