diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm index e334541..b4f1215 100644 --- a/scheme/rts/port.scm +++ b/scheme/rts/port.scm @@ -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))))