suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: make flush-output error if port is closed

Browse Source 
Closes #3803
This commit is contained in:
Matthew Flatt 2021-04-27 09:23:32 -06:00
parent 9ae6d66449
commit a385788971
3 changed files with 44 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test-core/tests/racket/port.rktl
View File

@ -963,7 +963,8 @@
(check (lambda (p) (write-byte 10 p)))
(check (lambda (p) (write-bytes #"hello" p)))
(check (lambda (p) (write-char #\x p)))
(check (lambda (p) (write-string "hello" p))))
(check (lambda (p) (write-string "hello" p)))
(check flush-output))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; port-closed events

56
racket/src/cs/schemified/io.scm
View File

@ -11838,10 +11838,13 @@
loop
(lambda ()
(begin
(let ((r_0
(begin
(unsafe-start-atomic)
(begin0
(begin
(unsafe-start-atomic)
(begin
(check-not-closed
'flush-output
out_0)
(let ((r_0
(|#%app|
write-out_0
out_0
@ -11850,26 +11853,33 @@
0
#f
#f
#f)
(unsafe-end-atomic)))))
(letrec*
((r-loop_0
(|#%name|
r-loop
(lambda (r_1)
(begin
(if (eq? r_1 0)
(void)
(if (not r_1)
(loop_0)
(if (evt? r_1)
(r-loop_0 (sync r_1))
(error
'flush-output
"weird result")))))))))
(r-loop_0 r_0))))))))
#f)))
(begin
(unsafe-end-atomic)
(letrec*
((r-loop_0
(|#%name|
r-loop
(lambda (r_1)
(begin
(if (eq? r_1 0)
(void)
(if (not r_1)
(loop_0)
(if (evt? r_1)
(r-loop_0
(sync r_1))
(error
'flush-output
"weird result")))))))))
(r-loop_0 r_0)))))))))))
(loop_0))
(wo-loop_0 write-out_0)))))))))
(begin
(unsafe-start-atomic)
(begin0
(check-not-closed 'flush-output out_0)
(unsafe-end-atomic))
(wo-loop_0 write-out_0))))))))))
(wo-loop_0 p_0)))))))))
(|#%name|
flush-output

13
racket/src/io/port/flush-output.rkt
View File

@ -5,7 +5,8 @@
"parameter.rkt"
"port.rkt"
"output-port.rkt"
"pipe.rkt")
"pipe.rkt"
"check.rkt")
(provide flush-output
maybe-flush-stdout)
@ -18,15 +19,19 @@
(cond
[(procedure? write-out)
(let loop ()
(define r (atomically
(write-out out #"" 0 0 #f #f #f)))
(start-atomic)
(check-not-closed who out)
(define r (write-out out #"" 0 0 #f #f #f))
(end-atomic)
(let r-loop ([r r])
(cond
[(eq? r 0) (void)]
[(not r) (loop)]
[(evt? r) (r-loop (sync r))]
[else (error 'flush-output "weird result")])))]
[else (wo-loop write-out)])))
[else
(atomically (check-not-closed who out))
(wo-loop write-out)])))
;; ----------------------------------------