From 380fee6612139f60fc80bffd230630a9b2cdb0d6 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Mon, 25 Feb 2002 20:29:15 +0000
Subject: [PATCH] Make FLUSH-ALL-PORTS blocking so FORK will do something more
 sensible.

Previously,

(begin
  (display "ha!") (newline)
  (fork (lambda ()
	  'foo)))

would print "ha!" twice because FLUSH-ALL-PORTS would not finish
before the actual FORK.
---
 scsh/newports.scm | 23 ++++++++++++++++++++++-
 1 file changed, 22 insertions(+), 1 deletion(-)

diff --git a/scsh/newports.scm b/scsh/newports.scm
index bddd926..50fd4bc 100644
--- a/scsh/newports.scm
+++ b/scsh/newports.scm
@@ -545,9 +545,30 @@
     (cond ((null? thunks)
 	   #f)
 	  (else
-	   (for-each (structure-ref threads spawn) thunks)
+	   (let loop ((threads
+		       (map spawn-thread thunks))
+		      (new-threads '()))
+	     (cond
+	      ((not (null? threads))
+	       (if ((structure-ref threads-internal thread-continuation)
+		    (car threads))
+		   (loop (cdr threads)
+			 (cons (car threads) new-threads))
+		   (loop (cdr threads) new-threads)))
+	      ((not (null? new-threads))
+	       (loop new-threads '()))))
 	   #t))))
 
+(define (spawn-thread thunk)
+  (let ((placeholder (make-placeholder)))
+    (spawn
+     (lambda ()
+       (placeholder-set!
+	placeholder
+	((structure-ref threads-internal current-thread)))
+       (thunk)))
+    (placeholder-value placeholder)))
+
 ;;; Extend R4RS i/o ops to handle file descriptors.
 ;;; -----------------------------------------------