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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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