Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 588 lines (490 sloc) 18.844 kB
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
13 (defvar *tmp*)
14
48bd841 ECL moved gray streams into GRAY package
Geo Carncross authored
15 (if (find-package :gray)
16 (import-from :gray *gray-stream-symbols* :swank-backend)
17 (import-from :ext *gray-stream-symbols* :swank-backend))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
18
19 (swank-backend::import-swank-mop-symbols :clos
20 '(:eql-specializer
21 :eql-specializer-object
22 :generic-function-declarations
23 :specializer-direct-methods
24 :compute-applicable-methods-using-classes))
25
26
27 ;;;; TCP Server
28
29 (require 'sockets)
30
31 (defun resolve-hostname (name)
32 (car (sb-bsd-sockets:host-ent-addresses
33 (sb-bsd-sockets:get-host-by-name name))))
34
35 (defimplementation create-socket (host port)
36 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
37 :type :stream
38 :protocol :tcp)))
39 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
40 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
41 (sb-bsd-sockets:socket-listen socket 5)
42 socket))
43
44 (defimplementation local-port (socket)
45 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
46
47 (defimplementation close-socket (socket)
48 (sb-bsd-sockets:socket-close socket))
49
50 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
51 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
52 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
53 (declare (ignore buffering timeout external-format))
54 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
55
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
56 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
57 (sb-bsd-sockets:socket-make-stream socket
58 :output t
59 :input t
60 :element-type 'base-char))
61
62 (defun accept (socket)
63 "Like socket-accept, but retry on EAGAIN."
64 (loop (handler-case
65 (return (sb-bsd-sockets:socket-accept socket))
66 (sb-bsd-sockets:interrupted-error ()))))
67
68 (defimplementation preferred-communication-style ()
69 (values nil))
70
71
72 ;;;; Unix signals
73
74 (defimplementation getpid ()
75 (si:getpid))
76
77 #+nil
78 (defimplementation set-default-directory (directory)
79 (ext::chdir (namestring directory))
80 ;; Setting *default-pathname-defaults* to an absolute directory
81 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
82 (setf *default-pathname-defaults* (ext::getcwd))
83 (default-directory))
84
85 #+nil
86 (defimplementation default-directory ()
87 (namestring (ext:getcwd)))
88
89 (defimplementation quit-lisp ()
90 (ext:quit))
91
92
93 ;;;; Compilation
94
95 (defvar *buffer-name* nil)
96 (defvar *buffer-start-position*)
97 (defvar *buffer-string*)
98 (defvar *compile-filename*)
99
100 (defun signal-compiler-condition (&rest args)
101 (signal (apply #'make-condition 'compiler-condition args)))
102
103 (defun handle-compiler-warning (condition)
104 (signal-compiler-condition
105 :original-condition condition
106 :message (format nil "~A" condition)
107 :severity :warning
108 :location
109 (if *buffer-name*
110 (make-location (list :buffer *buffer-name*)
111 (list :position *buffer-start-position*))
112 ;; ;; compiler::*current-form*
113 ;; (if compiler::*current-function*
114 ;; (make-location (list :file *compile-filename*)
115 ;; (list :function-name
116 ;; (symbol-name
117 ;; (slot-value compiler::*current-function*
118 ;; 'compiler::name))))
119 (list :error "No location found.")
120 ;; )
121 )))
122
123 (defimplementation call-with-compilation-hooks (function)
124 (handler-bind ((warning #'handle-compiler-warning))
125 (funcall function)))
126
127 (defimplementation swank-compile-file (*compile-filename* load-p
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
128 external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
129 (declare (ignore external-format))
130 (with-compilation-hooks ()
131 (let ((*buffer-name* nil))
132 (multiple-value-bind (fn warn fail)
133 (compile-file *compile-filename*)
134 (when load-p (unless fail (load fn)))))))
135
e04fa03 C-c C-c with prefix args now uses the maximal debug level. (By Zach …
Helmut Eller authored
136 (defimplementation swank-compile-string (string &key buffer position directory
137 debug)
138 (declare (ignore directory debug))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
139 (with-compilation-hooks ()
140 (let ((*buffer-name* buffer)
141 (*buffer-start-position* position)
142 (*buffer-string* string))
143 (with-input-from-string (s string)
144 (compile-from-stream s :load t)))))
145
146 (defun compile-from-stream (stream &rest args)
147 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
148 (with-open-file (s file :direction :output :if-exists :overwrite)
149 (do ((line (read-line stream nil) (read-line stream nil)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
150 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
151 (write-line line s)))
152 (unwind-protect
153 (apply #'compile-file file args)
154 (delete-file file))))
155
156
157 ;;;; Documentation
158
159 (defimplementation arglist (name)
160 (or (functionp name) (setf name (symbol-function name)))
161 (if (functionp name)
162 (typecase name
163 (generic-function
164 (clos::generic-function-lambda-list name))
d31550c try to parse the Args: line in most ecl functions to make modelines m…
Geo Carncross authored
165 (compiled-function
166 ; most of the compiled functions have an Args: line in their docs
167 (with-input-from-string (s (or
168 (si::get-documentation
169 (si:compiled-function-name name) 'function)
170 ""))
171 (do ((line (read-line s nil) (read-line s nil)))
172 ((not line) :not-available)
173 (ignore-errors
174 (if (string= (subseq line 0 6) "Args: ")
175 (return-from nil
176 (read-from-string (subseq line 6))))))))
177 ;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
178 (function
179 (let ((fle (function-lambda-expression name)))
180 (case (car fle)
181 (si:lambda-block (caddr fle))
182 (t :not-available)))))
183 :not-available))
184
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
185 (defimplementation function-name (f)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
186 (si:compiled-function-name f))
187
188 (defimplementation macroexpand-all (form)
189 ;;; FIXME! This is not the same as a recursive macroexpansion!
190 (macroexpand form))
191
192 (defimplementation describe-symbol-for-emacs (symbol)
193 (let ((result '()))
194 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
195 (let ((doc (describe-definition symbol type)))
196 (when doc
197 (setf result (list* type doc result)))))
198 result))
199
200 (defimplementation describe-definition (name type)
201 (case type
202 (:variable (documentation name 'variable))
203 (:function (documentation name 'function))
204 (:class (documentation name 'class))
205 (t nil)))
206
207 ;;; Debugging
208
209 (import
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
210 '(si::*break-env*
211 si::*ihs-top*
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
212 si::*ihs-current*
213 si::*ihs-base*
214 si::*frs-base*
215 si::*frs-top*
216 si::*tpl-commands*
217 si::*tpl-level*
218 si::frs-top
219 si::ihs-top
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
220 si::ihs-fun
221 si::ihs-env
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
222 si::sch-frs-base
223 si::set-break-env
224 si::set-current-ihs
225 si::tpl-commands))
226
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
227 (defvar *backtrace* '())
228
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
229 (defun in-swank-package-p (x)
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
230 (and
231 (symbolp x)
232 (member (symbol-package x)
233 (list #.(find-package :swank)
234 #.(find-package :swank-backend)
235 #.(ignore-errors (find-package :swank-mop))
236 #.(ignore-errors (find-package :swank-loader))))
237 t))
238
239 (defun is-swank-source-p (name)
240 (setf name (pathname name))
241 (pathname-match-p
242 name
243 (make-pathname :defaults swank-loader::*source-directory*
244 :name (pathname-name name)
245 :type (pathname-type name)
246 :version (pathname-version name))))
247
248 (defun is-ignorable-fun-p (x)
249 (or
250 (in-swank-package-p (frame-name x))
251 (multiple-value-bind (file position)
252 (ignore-errors (si::bc-file (car x)))
253 (declare (ignore position))
254 (if file (is-swank-source-p file)))))
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
255
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
256 (defimplementation call-with-debugging-environment (debugger-loop-fn)
257 (declare (type function debugger-loop-fn))
258 (let* ((*tpl-commands* si::tpl-commands)
259 (*ihs-top* (ihs-top 'call-with-debugging-environment))
260 (*ihs-current* *ihs-top*)
261 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
262 (*frs-top* (frs-top))
263 (*read-suppress* nil)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
264 (*tpl-level* (1+ *tpl-level*))
265 (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
36a6053 Remove frames from the backtrace that are in a swank package as those…
Geo Carncross authored
266 collect (list (si::ihs-fun ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
267 (si::ihs-env ihs)
268 nil))))
269 (loop for f from *frs-base* until *frs-top*
270 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
271 (when (plusp i)
272 (let* ((x (elt *backtrace* i))
273 (name (si::frs-tag f)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
274 (unless (si::fixnump name)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
275 (push name (third x)))))))
df8f365 Trim swank sources from the ECL backtrace.
Geo Carncross authored
276 (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
277 (Setf *tmp* *backtrace*)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
278 (set-break-env)
279 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
280 (let ((*ihs-base* *ihs-top*))
281 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
282
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
283 (defimplementation call-with-debugger-hook (hook fun)
284 (let ((*debugger-hook* hook)
285 (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
286 (funcall fun)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
287
288 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
289 (when (numberp end)
290 (setf end (min end (length *backtrace*))))
291 (subseq *backtrace* start end))
292
293 (defun frame-name (frame)
294 (let ((x (first frame)))
295 (if (symbolp x)
296 x
297 (function-name x))))
298
299 (defun function-position (fun)
300 (multiple-value-bind (file position)
301 (si::bc-file fun)
302 (and file (make-location `(:file ,file) `(:position ,position)))))
303
304 (defun frame-function (frame)
305 (let* ((x (first frame))
306 fun position)
307 (etypecase x
308 (symbol (and (fboundp x)
309 (setf fun (fdefinition x)
310 position (function-position fun))))
311 (function (setf fun x position (function-position x))))
312 (values fun position)))
313
314 (defun frame-decode-env (frame)
315 (let ((functions '())
316 (blocks '())
317 (variables '()))
318 (dolist (record (second frame))
319 (let* ((record0 (car record))
320 (record1 (cdr record)))
321 (cond ((symbolp record0)
322 (setq variables (acons record0 record1 variables)))
ecef253 Bugfix: qualify fixnump
Geo Carncross authored
323 ((not (si::fixnump record0))
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
324 (push record1 functions))
325 ((symbolp record1)
326 (push record1 blocks))
327 (t
328 ))))
329 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
330
331 (defimplementation print-frame (frame stream)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
332 (format stream "~A" (first frame)))
333
334 (defimplementation frame-source-location-for-emacs (frame-number)
335 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
336
337 (defimplementation frame-catch-tags (frame-number)
338 (third (elt *backtrace* frame-number)))
339
340 (defimplementation frame-locals (frame-number)
341 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
342 with i = 0
343 collect (list :name name :id (prog1 i (incf i)) :value value)))
344
345 (defimplementation frame-var-value (frame-number var-id)
346 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
347 var-id))
348
349 (defimplementation disassemble-frame (frame-number)
350 (let ((fun (frame-fun (elt *backtrace* frame-number))))
351 (disassemble fun)))
352
353 (defimplementation eval-in-frame (form frame-number)
354 (let ((env (second (elt *backtrace* frame-number))))
355 (si:eval-with-env form env)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
356
357 ;;;; Inspector
358
0c75cea Inspector cleanups.
Helmut Eller authored
359 (defmethod emacs-inspect ((o t))
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
360 ; ecl clos support leaves some to be desired
361 (cond
362 ((streamp o)
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
363 (list*
364 (format nil "~S is an ordinary stream~%" o)
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
365 (append
366 (list
367 "Open for "
368 (cond
369 ((ignore-errors (interactive-stream-p o)) "Interactive")
370 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
371 ((input-stream-p o) "Input")
372 ((output-stream-p o) "Output"))
373 `(:newline) `(:newline))
374 (label-value-line*
375 ("Element type" (stream-element-type o))
376 ("External format" (stream-external-format o)))
377 (ignore-errors (label-value-line*
378 ("Broadcast streams" (broadcast-stream-streams o))))
379 (ignore-errors (label-value-line*
380 ("Concatenated streams" (concatenated-stream-streams o))))
381 (ignore-errors (label-value-line*
382 ("Echo input stream" (echo-stream-input-stream o))))
383 (ignore-errors (label-value-line*
384 ("Echo output stream" (echo-stream-output-stream o))))
385 (ignore-errors (label-value-line*
386 ("Output String" (get-output-stream-string o))))
387 (ignore-errors (label-value-line*
388 ("Synonym symbol" (synonym-stream-symbol o))))
389 (ignore-errors (label-value-line*
390 ("Input stream" (two-way-stream-input-stream o))))
391 (ignore-errors (label-value-line*
392 ("Output stream" (two-way-stream-output-stream o)))))))
393 (t
394 (let* ((cl (si:instance-class o))
395 (slots (clos:class-slots cl)))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
396 (list* (format nil "~S is an instance of class ~A~%"
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
397 o (clos::class-name cl))
398 (loop for x in slots append
399 (let* ((name (clos:slot-definition-name x))
400 (value (clos::slot-value o name)))
401 (list
402 (format nil "~S: " name)
403 `(:value ,value)
404 `(:newline)))))))))
405
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
406 ;;;; Definitions
407
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
408 (defimplementation find-definitions (name)
409 (if (fboundp name)
410 (let ((tmp (find-source-location (symbol-function name))))
411 `(((defun ,name) ,tmp)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
412
2791323 Initial support for find-source-location with functions
Geo Carncross authored
413 (defimplementation find-source-location (obj)
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
414 (setf *tmp* obj)
2791323 Initial support for find-source-location with functions
Geo Carncross authored
415 (or
416 (typecase obj
417 (function
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
418 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
419 (if (and file pos)
e8c6143 fixup flushing and location create
Geo Carncross authored
420 (make-location
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
421 `(:file ,(namestring file))
e8c6143 fixup flushing and location create
Geo Carncross authored
422 `(:position ,pos)
423 `(:snippet
424 ,(with-open-file (s file)
425 (skip-toplevel-forms pos s)
426 (skip-comments-and-whitespace s)
427 (read-snippet s))))))))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
428 `(:error (format nil "Source definition of ~S not found" obj))))
429
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
430 ;;;; Threads
431
432 #+threads
433 (progn
434 (defvar *thread-id-counter* 0)
435
436 (defvar *thread-id-counter-lock*
437 (mp:make-lock :name "thread id counter lock"))
438
439 (defun next-thread-id ()
440 (mp:with-lock (*thread-id-counter-lock*)
441 (incf *thread-id-counter*)))
442
443 (defparameter *thread-id-map* (make-hash-table))
444
445 (defvar *thread-id-map-lock*
446 (mp:make-lock :name "thread id map lock"))
447
448 ; ecl doesn't have weak pointers
449 (defimplementation spawn (fn &key name)
450 (let ((thread (mp:make-process :name name))
451 (id (next-thread-id)))
452 (mp:process-preset
453 thread
454 #'(lambda ()
455 (unwind-protect
456 (mp:with-lock (*thread-id-map-lock*)
457 (setf (gethash id *thread-id-map*) thread))
458 (funcall fn)
459 (mp:with-lock (*thread-id-map-lock*)
460 (remhash id *thread-id-map*)))))
461 (mp:process-enable thread)))
462
463 (defimplementation thread-id (thread)
464 (block thread-id
465 (mp:with-lock (*thread-id-map-lock*)
466 (loop for id being the hash-key in *thread-id-map*
467 using (hash-value thread-pointer)
468 do (if (eq thread thread-pointer)
469 (return-from thread-id id))))))
470
471 (defimplementation find-thread (id)
472 (mp:with-lock (*thread-id-map-lock*)
473 (gethash id *thread-id-map*)))
474
475 (defimplementation thread-name (thread)
476 (mp:process-name thread))
477
478 (defimplementation thread-status (thread)
479 (if (mp:process-active-p thread)
480 "RUNNING"
481 "STOPPED"))
482
483 (defimplementation make-lock (&key name)
484 (mp:make-lock :name name))
485
486 (defimplementation call-with-lock-held (lock function)
487 (declare (type function function))
488 (mp:with-lock (lock) (funcall function)))
489
490 (defimplementation make-recursive-lock (&key name)
491 (mp:make-lock :name name))
492
493 (defimplementation call-with-recursive-lock-held (lock function)
494 (declare (type function function))
495 (mp:with-lock (lock) (funcall function)))
496
497 (defimplementation current-thread ()
498 mp:*current-process*)
499
500 (defimplementation all-threads ()
501 (mp:all-processes))
502
503 (defimplementation interrupt-thread (thread fn)
504 (mp:interrupt-process thread fn))
505
506 (defimplementation kill-thread (thread)
507 (mp:process-kill thread))
508
509 (defimplementation thread-alive-p (thread)
510 (mp:process-active-p thread))
511
512 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
513
514 (defstruct (mailbox (:conc-name mailbox.))
515 (mutex (mp:make-lock :name "process mailbox"))
516 (queue '() :type list))
517
518 (defun mailbox (thread)
519 "Return THREAD's mailbox."
520 (mp:with-lock (*mailbox-lock*)
521 (or (find thread *mailboxes* :key #'mailbox.thread)
522 (let ((mb (make-mailbox :thread thread)))
523 (push mb *mailboxes*)
524 mb))))
525
526 (defimplementation send (thread message)
527 (let* ((mbox (mailbox thread))
528 (mutex (mailbox.mutex mbox)))
529 (mp:interrupt-process
530 thread
531 (lambda ()
532 (mp:with-lock (mutex)
533 (setf (mailbox.queue mbox)
534 (nconc (mailbox.queue mbox) (list message))))))))
535
536 (defimplementation receive ()
537 (block got-mail
538 (let* ((mbox (mailbox mp:*current-process*))
539 (mutex (mailbox.mutex mbox)))
540 (loop
541 (mp:with-lock (mutex)
542 (if (mailbox.queue mbox)
543 (return-from got-mail (pop (mailbox.queue mbox)))))
544 ;interrupt-process will halt this if it takes longer than 1sec
545 (sleep 1)))))
546
547 ;; Auto-flush streams
548 (defvar *auto-flush-interval* 0.15
549 "How often to flush interactive streams. This valu is passed
550 directly to cl:sleep.")
551
552 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
553
554 (defvar *auto-flush-thread* nil)
555
556 (defvar *auto-flush-streams* '())
557
558 (defimplementation make-stream-interactive (stream)
559 (call-with-recursive-lock-held
560 *auto-flush-lock*
561 (lambda ()
562 (pushnew stream *auto-flush-streams*)
563 (unless *auto-flush-thread*
564 (setq *auto-flush-thread*
565 (spawn #'flush-streams
566 :name "auto-flush-thread"))))))
567
568 (defmethod stream-finish-output ((stream stream))
569 (finish-output stream))
570
571 (defun flush-streams ()
572 (loop
573 (call-with-recursive-lock-held
574 *auto-flush-lock*
575 (lambda ()
576 (setq *auto-flush-streams*
577 (remove-if (lambda (x)
578 (not (and (open-stream-p x)
579 (output-stream-p x))))
580 *auto-flush-streams*))
e8c6143 fixup flushing and location create
Geo Carncross authored
581 (dolist (i *auto-flush-streams*)
582 (ignore-errors (stream-finish-output i))
583 (ignore-errors (finish-output i)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
584 (sleep *auto-flush-interval*)))
585
586 )
587
Something went wrong with that request. Please try again.