From 4e5b87209db6a4ffbae279fbd150b884f71ab932 Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 26 Jun 2002 11:25:33 +0000
Subject: [PATCH] Added ignore-port-locks? flag to output-port-forcers and use
 it in flush-all-ports-no-threads.

---
 scheme/rts/port.scm      | 83 +++++++++++++++++++++++-----------------
 scsh/newports.scm        |  6 ++-
 scsh/scsh-interfaces.scm |  1 +
 3 files changed, 54 insertions(+), 36 deletions(-)

diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm
index b4f1215..1e69825 100644
--- a/scheme/rts/port.scm
+++ b/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?)
-  (let loop ((next (cdr *flush-these-ports*))
-             (last *flush-these-ports*)
-             (thunks '()))
-    (if (null? next)
-        thunks
-        (let ((port (weak-pointer-ref (car next))))
-          (cond ((or (not port)                      ; GCed or closed
-                     (not (open-output-port? port))) ;  so drop it from the list
-                 (set-cdr! last (cdr next))
-                 (loop (cdr next) last thunks))
-                ((not (maybe-obtain-port-lock port)) ; locked
-                 (loop (cdr next) next thunks))
-                ((and use-flushed?-flags?            ; flushed recently
-                      (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)
-			     thunks)))
-                (else                                 ; empty
-                 (release-port-lock port)
-                 (loop (cdr next) next thunks)))))))
+(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 '()))
+      (if (null? next)
+	  thunks
+	  (let ((port (weak-pointer-ref (car next))))
+	    (cond ((or (not port)	; GCed or closed
+		       (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
+			(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)
-		    (with-handler
-		     (lambda (condition punt)
-		       (release-port-lock port)
-		       (punt))
-		     (lambda ()
-		       (really-force-output port)
-		       (release-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))))
+		      (ignore-port-lock?
+		       (really-force-output port))))
 	      "error when flushing buffer; closing port"
 	      port)
 	     (open-output-port? port))
diff --git a/scsh/newports.scm b/scsh/newports.scm
index b6bee55..ae8ff18 100644
--- a/scsh/newports.scm
+++ b/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.
 ;;; -----------------------------------------------
 
diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm
index fbfb476..fbeded0 100644
--- a/scsh/scsh-interfaces.scm
+++ b/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.