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

flush-all-ports-no-threads.

scheme/rts/port.scm

@@ -549,32 +549,43 @@
 ; 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 loop ((next (cdr *flush-these-ports*))
+  (let ((ignore-port-locks? (if (null? maybe-ignore-port-locks?) #f #t)))
-             (last *flush-these-ports*)
+    (let loop ((next (cdr *flush-these-ports*))
-             (thunks '()))
+	       (last *flush-these-ports*)
-    (if (null? next)
+	       (thunks '()))
-        thunks
+      (if (null? next)
-        (let ((port (weak-pointer-ref (car next))))
+	  thunks
-          (cond ((or (not port)                      ; GCed or closed
+	  (let ((port (weak-pointer-ref (car next))))
-                     (not (open-output-port? port))) ;  so drop it from the list
+	    (cond ((or (not port)	; GCed or closed
-                 (set-cdr! last (cdr next))
+		       (not (open-output-port? port))) ;  so drop it from the list
-                 (loop (cdr next) last thunks))
+		   (set-cdr! last (cdr next))
-                ((not (maybe-obtain-port-lock port)) ; locked
+		   (loop (cdr next) last thunks))
-                 (loop (cdr next) next thunks))
+		  (ignore-port-locks?
-                ((and use-flushed?-flags?            ; flushed recently
+		   (cond ((and use-flushed?-flags? ; flushed recently
-                      (port-flushed? port))
+			       (port-flushed? port))
-                 (set-port-flushed?! port #f)
+			  (set-port-flushed?! port #f)
-                 (release-port-lock port)
+			  (loop (cdr next) next thunks))
-                 (loop (cdr next) next thunks))
+			 ((< 0 (port-index port)) ; non-empty
-                ((< 0 (port-index port))              ; non-empty
+			  (loop (cdr next) next
-                 (release-port-lock port)
+				(cons (make-forcing-thunk port ignore-port-locks?)
-                 (loop (cdr next) next
+				      thunks)))
-		       (cons (make-forcing-thunk port)
+			 (else (loop (cdr next) next thunks))))
-			     thunks)))
+		  ((not (maybe-obtain-port-lock port)) ; locked
-                (else                                 ; empty
+		   (loop (cdr next) next thunks))
-                 (release-port-lock port)
+		  ((and use-flushed?-flags? ; flushed recently
-                 (loop (cdr next) next thunks)))))))
+			(port-flushed? port))
+		   (set-port-flushed?! port #f)
+		   (release-port-lock port)
+		   (loop (cdr next) next thunks))
+		  ((< 0 (port-index port)) ; non-empty
+		   (release-port-lock port)
+		   (loop (cdr next) next
+			 (cons (make-forcing-thunk port ignore-port-locks?)
+			       thunks)))
+		  (else			; empty
+		   (release-port-lock port)
+		   (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
+		       (with-handler
-		     (lambda (condition punt)
+			(lambda (condition punt)
-		       (release-port-lock port)
+			  (release-port-lock port)
-		       (punt))
+			  (punt))
-		     (lambda ()
+			(lambda ()
-		       (really-force-output port)
+			  (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.