Be even more thorough about releasing port locks after exceptions.
This commit is contained in:
sperber
parent
f5d853712b
commit
b4312d028c
|
|
@ -80,11 +80,7 @@
|
|||
(define (one-arg-proc->handler proc signal-exception)
|
||||
(lambda (opcode reason port)
|
||||
(if (= reason (enum exception buffer-full/empty))
|
||||
(begin
|
||||
(obtain-port-lock port)
|
||||
(let ((value (proc port)))
|
||||
(release-port-lock port)
|
||||
value))
|
||||
(protect-port-op port (lambda () (proc port)))
|
||||
(signal-exception opcode reason port))))
|
||||
|
||||
; This could combined with on-arg-... if the port were the first argument.
|
||||
|
|
@ -92,11 +88,7 @@
|
|||
(define (two-arg-proc->handler proc signal-exception)
|
||||
(lambda (opcode reason arg port)
|
||||
(if (= reason (enum exception buffer-full/empty))
|
||||
(begin
|
||||
(obtain-port-lock port)
|
||||
(let ((value (proc arg port)))
|
||||
(release-port-lock port)
|
||||
value))
|
||||
(protect-port-op port (lambda () (proc arg port)))
|
||||
(signal-exception opcode reason arg port))))
|
||||
|
||||
; If a character is available, use it; if there is an EOF waiting, use that;
|
||||
|
|
@ -163,31 +155,42 @@
|
|||
(define port-flushed? port-pending-eof?)
|
||||
(define set-port-flushed?! set-port-pending-eof?!)
|
||||
|
||||
(define (protect-port-op port thunk)
|
||||
(obtain-port-lock port)
|
||||
(let ((result
|
||||
(with-handler
|
||||
(lambda (condition punt)
|
||||
(release-port-lock port)
|
||||
(punt))
|
||||
thunk)))
|
||||
(release-port-lock port)
|
||||
result))
|
||||
|
||||
;----------------
|
||||
; Closing is done with the appropriate handler.
|
||||
; R4RS says that CLOSE-... is idempotent.
|
||||
|
||||
(define (close-input-port port)
|
||||
(if (input-port? port)
|
||||
(begin
|
||||
(obtain-port-lock port)
|
||||
(if (open-input-port? port)
|
||||
(begin
|
||||
(make-input-port-closed! port)
|
||||
((port-handler-close (port-handler port)) (port-data port))))
|
||||
(release-port-lock port))
|
||||
(protect-port-op
|
||||
port
|
||||
(lambda ()
|
||||
(if (open-input-port? port)
|
||||
(begin
|
||||
(make-input-port-closed! port)
|
||||
((port-handler-close (port-handler port)) (port-data port))))))
|
||||
(call-error "invalid argument" close-input-port port)))
|
||||
|
||||
(define (close-output-port port)
|
||||
(if (output-port? port)
|
||||
(begin
|
||||
(obtain-port-lock port)
|
||||
(if (open-output-port? port)
|
||||
(begin
|
||||
(really-force-output port)
|
||||
(make-output-port-closed! port)
|
||||
((port-handler-close (port-handler port)) (port-data port))))
|
||||
(release-port-lock port))
|
||||
(protect-port-op
|
||||
port
|
||||
(lambda ()
|
||||
(if (open-output-port? port)
|
||||
(begin
|
||||
(make-output-port-closed! port)
|
||||
(really-force-output port)
|
||||
((port-handler-close (port-handler port)) (port-data port))))))
|
||||
(call-error "invalid argument" close-output-port port)))
|
||||
|
||||
;----------------
|
||||
|
|
@ -203,22 +206,12 @@
|
|||
((define-port-op (?id ?args ...) ?port ?predicate ?body)
|
||||
(define (?id ?args ...)
|
||||
(if ?predicate ; if args are okay
|
||||
(begin
|
||||
(obtain-port-lock ?port) ; lock the port
|
||||
(protect-port-op
|
||||
?port
|
||||
(lambda ()
|
||||
(if (open-port? ?port) ; check that it's open
|
||||
(let ((value ; do the work
|
||||
(with-handler
|
||||
(lambda (condition punt)
|
||||
|
||||
(release-port-lock ?port)
|
||||
(punt))
|
||||
(lambda ()
|
||||
?body))))
|
||||
(release-port-lock ?port) ; release the lock
|
||||
value) ; return
|
||||
(begin
|
||||
(release-port-lock ?port)
|
||||
(call-error "invalid argument" ?id ?args ...))))
|
||||
?body
|
||||
(call-error "invalid argument" ?id ?args ...))))
|
||||
(call-error "invalid argument" ?id ?args ...))))
|
||||
|
||||
; ?port defaults to the first argument
|
||||
|
|
@ -340,14 +333,19 @@
|
|||
(call-error "invalid argument" output-port-ready? port))
|
||||
((not (maybe-obtain-port-lock port))
|
||||
#f)
|
||||
((not (open-port? port)) ; have to check again after the lock call
|
||||
((not (open-port? port)) ; have to check again after the lock call
|
||||
(release-port-lock port)
|
||||
(call-error "invalid argument" output-port-ready? port))
|
||||
(else
|
||||
(let ((val ((port-handler-ready? (port-handler port))
|
||||
port)))
|
||||
(release-port-lock port)
|
||||
val))))
|
||||
(with-handler
|
||||
(lambda (condition punt)
|
||||
(release-port-lock port)
|
||||
(punt))
|
||||
(lambda ()
|
||||
(let ((val ((port-handler-ready? (port-handler port))
|
||||
port)))
|
||||
(release-port-lock port)
|
||||
val))))))
|
||||
|
||||
; Copy the bytes into the buffer if there is room, otherwise write out anything
|
||||
; in the buffer and then write BUFFER.
|
||||
|
|
@ -390,11 +388,11 @@
|
|||
|
||||
(define (force-output-if-open port)
|
||||
(if (output-port? port)
|
||||
(begin
|
||||
(obtain-port-lock port)
|
||||
(if (open-output-port? port)
|
||||
(really-force-output port))
|
||||
(release-port-lock port))
|
||||
(protect-port-op
|
||||
port
|
||||
(lambda ()
|
||||
(if (open-output-port? port)
|
||||
(really-force-output port))))
|
||||
(call-error "invalid argument" force-output-if-open port)))
|
||||
|
||||
;----------------
|
||||
|
|
@ -608,19 +606,35 @@
|
|||
(if (and (report-errors-as-warnings
|
||||
(lambda ()
|
||||
(if (maybe-obtain-port-lock port)
|
||||
(begin
|
||||
(really-force-output port)
|
||||
(release-port-lock port))))
|
||||
(with-handler
|
||||
(lambda (condition punt)
|
||||
(release-port-lock port)
|
||||
(punt))
|
||||
(lambda ()
|
||||
(really-force-output port)
|
||||
(release-port-lock port)))))
|
||||
"error when flushing buffer; closing port"
|
||||
port)
|
||||
(open-output-port? port))
|
||||
(report-errors-as-warnings
|
||||
(lambda ()
|
||||
(make-output-port-closed! port)
|
||||
((port-handler-close (port-handler port)) (port-data port)))
|
||||
"error when closing port"
|
||||
port))))
|
||||
(lambda ()
|
||||
(make-output-port-closed! port)
|
||||
((port-handler-close (port-handler port)) (port-data port)))
|
||||
"error when closing port"
|
||||
port))))
|
||||
|
||||
;----------------
|
||||
; The following is used to make the REPL's input, output, and error ports
|
||||
; available after a keyboard interrupt. If PORT is a locked channel port
|
||||
; we save the its state and then reinitialize it. The OS is told to
|
||||
; abort any pending operation on the port's channel. Finally, the owning
|
||||
; thread's continuation is munged to restore the port when the thread
|
||||
; resumes. Any buffered input is thrown away at that point (it could
|
||||
; be saved away with the channel).
|
||||
;
|
||||
; If the port is locked by us or one of our ancestors there is no point in
|
||||
; trying to grab it.
|
||||
|
||||
(define (steal-port! port)
|
||||
(begin
|
||||
(disable-interrupts!)
|
||||
|
|
@ -652,17 +666,25 @@
|
|||
(interrupt-thread owner
|
||||
(lambda results
|
||||
(obtain-port-lock port)
|
||||
(cond ((output-port? port)
|
||||
(really-force-output port))
|
||||
((< (port-index port)
|
||||
(port-limit port))
|
||||
(warn "dropping input from port" port)))
|
||||
(set-port-buffer! port buffer)
|
||||
(set-port-index! port index)
|
||||
(set-port-limit! port limit)
|
||||
(set-port-pending-eof?! port eof?)
|
||||
(set-port-lock! port lock)
|
||||
(or status (apply values results))))
|
||||
(let ((cleanup
|
||||
(lambda ()
|
||||
(set-port-buffer! port buffer)
|
||||
(set-port-index! port index)
|
||||
(set-port-limit! port limit)
|
||||
(set-port-pending-eof?! port eof?)
|
||||
(set-port-lock! port lock))))
|
||||
(with-handler
|
||||
(lambda (condition punt)
|
||||
(cleanup)
|
||||
(punt))
|
||||
(lambda ()
|
||||
(cond ((output-port? port)
|
||||
(really-force-output port))
|
||||
((< (port-index port)
|
||||
(port-limit port))
|
||||
(warn "dropping input from port" port)))
|
||||
(cleanup)
|
||||
(or status (apply values results)))))))
|
||||
; if we took OWNER off a channel-wait queue we need to make it ready to run
|
||||
(if status (make-ready owner))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue