Be even more thorough about releasing port locks after exceptions.

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
+	(protect-port-op port (lambda () (proc port)))
-	  (obtain-port-lock port)
-	  (let ((value (proc port)))
-	    (release-port-lock port)
-	    value))
 	(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
+	(protect-port-op port (lambda () (proc arg port)))
-	  (obtain-port-lock port)
-	  (let ((value (proc arg port)))
-	    (release-port-lock port)
-	    value))
 	(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
+      (protect-port-op
-	(obtain-port-lock port)
+       port
+       (lambda ()
 	 (if (open-input-port? port)
 	     (begin
 	       (make-input-port-closed! port)
-	      ((port-handler-close (port-handler port)) (port-data port))))
+	       ((port-handler-close (port-handler port)) (port-data port))))))
-	(release-port-lock port))
       (call-error "invalid argument" close-input-port port)))
 	
 (define (close-output-port port)
   (if (output-port? port)
-      (begin
+      (protect-port-op
-	(obtain-port-lock port)
+	 port
+	 (lambda ()
 	   (if (open-output-port? port)
 	       (begin
-	      (really-force-output port)
 		 (make-output-port-closed! port)
-	      ((port-handler-close (port-handler port)) (port-data port))))
+		 (really-force-output port)
-	(release-port-lock port))
+		 ((port-handler-close (port-handler port)) (port-data port))))))
       (call-error "invalid argument" close-output-port port)))
 
 ;----------------
@@ -203,21 +206,11 @@
     ((define-port-op (?id ?args ...) ?port ?predicate ?body)
      (define (?id ?args ...)
        (if ?predicate                         ; if args are okay
-	   (begin
+	   (protect-port-op
-	     (obtain-port-lock ?port)         ; lock the port
+	    ?port
-	     (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))))
+	     (if (open-port? ?port)           ; check that it's open
-		   (release-port-lock ?port)  ; release the lock
+		 ?body
-		   value)                     ; return
-		 (begin
-		   (release-port-lock ?port)
 		 (call-error "invalid argument" ?id ?args ...))))
 	   (call-error "invalid argument" ?id ?args ...))))
 
@@ -344,10 +337,15 @@
 	 (release-port-lock port)
 	 (call-error "invalid argument" output-port-ready? port))
 	(else
+	 (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))))
+	      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
+      (protect-port-op
-	(obtain-port-lock port)
+       port
+       (lambda ()
 	 (if (open-output-port? port)
-	    (really-force-output port))
+	     (really-force-output port))))
-	(release-port-lock port))
       (call-error "invalid argument" force-output-if-open port)))
 
 ;----------------
@@ -608,9 +606,13 @@
     (if (and (report-errors-as-warnings
 	      (lambda ()
 		(if (maybe-obtain-port-lock port)
-		    (begin
+		    (with-handler
+		     (lambda (condition punt)
+		       (release-port-lock port)
+		       (punt))
+		     (lambda ()
 		       (really-force-output port)
-		      (release-port-lock port))))
+		       (release-port-lock port)))))
 	      "error when flushing buffer; closing port"
 	      port)
 	     (open-output-port? port))
@@ -621,6 +623,18 @@
 	 "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)
+			(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)))
-			(set-port-buffer! port buffer)
+			     (cleanup)
-			(set-port-index! port index)
+			     (or status (apply values results)))))))
-			(set-port-limit! port limit)
-			(set-port-pending-eof?! port eof?)
-			(set-port-lock! port lock)
-			(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))))