scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added ignore-port-locks? flag to output-port-forcers and use it in 

flush-all-ports-no-threads.
This commit is contained in:
mainzelm 2002-06-26 11:25:33 +00:00
parent 4e295e26d1
commit 4e5b87209d
3 changed files with 54 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
scheme/rts/port.scm
View File

@ -549,32 +549,43 @@
; all non-empty buffers, because the system has nothing to do and is going
; to pause while waiting for external events.
(define (output-port-forcers use-flushed?-flags?)
(let loop ((next (cdr *flush-these-ports*))
(last *flush-these-ports*)
(thunks '()))
(if (null? next)
thunks
(let ((port (weak-pointer-ref (car next))))
(cond ((or (not port) ; GCed or closed
(not (open-output-port? port))) ; so drop it from the list
(set-cdr! last (cdr next))
(loop (cdr next) last thunks))
((not (maybe-obtain-port-lock port)) ; locked
(loop (cdr next) next thunks))
((and use-flushed?-flags? ; flushed recently
(port-flushed? port))
(set-port-flushed?! port #f)
(release-port-lock port)
(loop (cdr next) next thunks))
((< 0 (port-index port)) ; non-empty
(release-port-lock port)
(loop (cdr next) next
(cons (make-forcing-thunk port)
thunks)))
(else ; empty
(release-port-lock port)
(loop (cdr next) next thunks)))))))
(define (output-port-forcers use-flushed?-flags? . maybe-ignore-port-locks?)
(let ((ignore-port-locks? (if (null? maybe-ignore-port-locks?) #f #t)))
(let loop ((next (cdr *flush-these-ports*))
(last *flush-these-ports*)
(thunks '()))
(if (null? next)
thunks
(let ((port (weak-pointer-ref (car next))))
(cond ((or (not port) ; GCed or closed
(not (open-output-port? port))) ; so drop it from the list
(set-cdr! last (cdr next))
(loop (cdr next) last thunks))
(ignore-port-locks?
(cond ((and use-flushed?-flags? ; flushed recently
(port-flushed? port))
(set-port-flushed?! port #f)
(loop (cdr next) next thunks))
((< 0 (port-index port)) ; non-empty
(loop (cdr next) next
(cons (make-forcing-thunk port ignore-port-locks?)
thunks)))
(else (loop (cdr next) next thunks))))
((not (maybe-obtain-port-lock port)) ; locked
(loop (cdr next) next thunks))
((and use-flushed?-flags? ; flushed recently
(port-flushed? port))
(set-port-flushed?! port #f)
(release-port-lock port)
(loop (cdr next) next thunks))
((< 0 (port-index port)) ; non-empty
(release-port-lock port)
(loop (cdr next) next
(cons (make-forcing-thunk port ignore-port-locks?)
thunks)))
(else ; empty
(release-port-lock port)
(loop (cdr next) next thunks))))))))
; Returns a list of the current ports that are flushed whenever.
; This is used to flush channel ports before forking.
@ -601,18 +612,20 @@
; Write out PORT's buffer. If a problem occurs it is reported and PORT
; is closed.
(define (make-forcing-thunk port)
(define (make-forcing-thunk port ignore-port-lock?)
(lambda ()
(if (and (report-errors-as-warnings
(lambda ()
(if (maybe-obtain-port-lock port)
(with-handler
(lambda (condition punt)
(release-port-lock port)
(punt))
(lambda ()
(really-force-output port)
(release-port-lock port)))))
(cond ((maybe-obtain-port-lock port)
(with-handler
(lambda (condition punt)
(release-port-lock port)
(punt))
(lambda ()
(really-force-output port)
(release-port-lock port))))
(ignore-port-lock?
(really-force-output port))))
"error when flushing buffer; closing port"
port)
(open-output-port? port))

6
scsh/newports.scm
View File

@ -546,7 +546,7 @@
(force-output fdport))
(define (flush-all-ports)
(let ((thunks (output-port-forcers #f)))
(let ((thunks (output-port-forcers #f #f)))
(cond ((null? thunks)
#f)
(else
@ -574,6 +574,10 @@
(thunk)))
(placeholder-value placeholder)))
(define (flush-all-ports-no-threads)
(let ((thunks (output-port-forcers #f #t)))
(for-each (lambda (thunk) (thunk)) thunks)))
;;; Extend R4RS i/o ops to handle file descriptors.
;;; -----------------------------------------------

1
scsh/scsh-interfaces.scm
View File

@ -144,6 +144,7 @@
; select!
flush-all-ports
flush-all-ports-no-threads
y-or-n?
*y-or-n-eof-count*
;; R4RS I/O procedures that scsh provides.