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

flush-all-ports-no-threads.

scheme/rts/port.scm

@@ -549,7 +549,8 @@
 ; 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?)
+(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 '()))
@@ -560,6 +561,16 @@
 		       (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
@@ -570,11 +581,11 @@
 		  ((< 0 (port-index port)) ; non-empty
 		   (release-port-lock port)
 		   (loop (cdr next) next
-		       (cons (make-forcing-thunk port)
+			 (cons (make-forcing-thunk port ignore-port-locks?)
 			       thunks)))
 		  (else			; empty
 		   (release-port-lock port)
-                 (loop (cdr next) next thunks)))))))
+		   (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)
+		(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)))))
+			  (release-port-lock port))))
+		      (ignore-port-lock?
+		       (really-force-output port))))
 	      "error when flushing buffer; closing port"
 	      port)
 	     (open-output-port? port))

scsh/newports.scm

@@ -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.
 ;;; -----------------------------------------------
 

scsh/scsh-interfaces.scm

@@ -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.