~ chicken-core (chicken-5) 0f4a0a3d1f2f3a98fb5c9e03255345f8b1d7aace

commit 0f4a0a3d1f2f3a98fb5c9e03255345f8b1d7aace
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Wed Oct 3 22:22:55 2012 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Oct 4 23:37:57 2012 +0200

    Fix handling of EINTR in process-wait by retrying. Add combined test for this and the getc() EINTR handling bug
    
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/NEWS b/NEWS
index efe430e4..226d2447 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,8 @@
+4.8.1
+
+- Core libraries
+  - Fixed EINTR handling in process-wait and when reading from file ports.
+
 4.8.0
 
 - Security fixes
diff --git a/posixunix.scm b/posixunix.scm
index c851319f..77d8bca4 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1808,14 +1808,17 @@ EOF
 
 (define (##sys#process-wait pid nohang)
   (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))]
-         [norm (##core#inline "C_WIFEXITED" _wait-status)] )
-    (values
-      res
-      norm
-      (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
-            [(##core#inline "C_WIFSIGNALED" _wait-status)
-              (##core#inline "C_WTERMSIG" _wait-status)]
-            [else (##core#inline "C_WSTOPSIG" _wait-status)] ) ) ) )
+	 [norm (##core#inline "C_WIFEXITED" _wait-status)] )
+    (if (and (fx= res -1) (fx= _errno _eintr))
+	(##sys#dispatch-interrupt
+         (lambda () (##sys#process-wait pid nohang)))
+	(values
+	 res
+	 norm
+	 (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
+	       [(##core#inline "C_WIFSIGNALED" _wait-status)
+		(##core#inline "C_WTERMSIG" _wait-status)]
+	       [else (##core#inline "C_WSTOPSIG" _wait-status)] ) )) ) )
 
 (define parent-process-id (foreign-lambda int "C_getppid"))
 
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 72d6861f..81db14c4 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -139,6 +139,27 @@ EOF
      (check (tcp-port-numbers in))
      (check (tcp-abandon-port in)))	; Not sure about abandon-port
 
+   
+   ;; This tests for two bugs which occurred on NetBSD and possibly
+   ;; other platforms, possibly due to multiprocessing:
+   ;; read-line with EINTR would loop endlessly and process-wait would
+   ;; signal a condition when interrupted rather than retrying.
+   (set-signal-handler! signal/chld void) ; Should be a noop but triggers EINTR
+   (receive (in out)
+     (create-pipe)
+     (receive (pid ok? status)
+       (process-wait
+        (process-fork
+         (lambda ()
+           (file-close in)              ; close receiving end
+           (with-output-to-port (open-output-file* out)
+             (lambda ()
+               (display "hello, world\n")
+               ;; exit prevents buffers from being discarded by implicit _exit
+               (exit 0))))))
+       (file-close out)                 ; close sending end
+       (assert (equal? '(#t 0 ("hello, world"))
+                       (list ok? status (read-lines (open-input-file* in)))))))
    )
   (else))