~ chicken-core (chicken-5) 7a74155c58c830dbb61b22897de4d70c1cf2a6ac

commit 7a74155c58c830dbb61b22897de4d70c1cf2a6ac
Author:     Jörg F. Wittenberger <Joerg.Wittenberger@softeyes.net>
AuthorDate: Wed Feb 1 19:46:38 2017 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Fri Mar 10 10:33:38 2017 +1300

    Handle possible EINTR in file-lock, file-lock/blocking and file-unlock.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 20e157a8..32f51860 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,10 @@
+4.12.1
+
+- Core Libraries
+  - Unit "posix": If file-lock, file-lock/blocking or file-unlock are
+    interrupted by a signal, we now retry (thanks to Joerg Wittenberger).
+
+
 4.12.0
 
 - Security fixes
diff --git a/posixunix.scm b/posixunix.scm
index df9a89bd..9304b395 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1335,16 +1335,22 @@ EOF
     (posix-error #:file-error loc msg (##sys#slot lock 1) (##sys#slot lock 2) (##sys#slot lock 3)) )
   (set! file-lock
     (lambda (port . args)
-      (let ([lock (setup port args 'file-lock)])
-        (if (fx< (##core#inline "C_flock_lock" port) 0)
-            (err "cannot lock file" lock 'file-lock)
-            lock) ) ) )
+      (let loop ()
+	(let ((lock (setup port args 'file-lock)))
+	  (if (fx< (##core#inline "C_flock_lock" port) 0)
+	      (select _errno
+		((_eintr) (##sys#dispatch-interrupt loop))
+		(else (err "cannot lock file" lock 'file-lock)))
+	      lock)))))
   (set! file-lock/blocking
     (lambda (port . args)
-      (let ([lock (setup port args 'file-lock/blocking)])
-        (if (fx< (##core#inline "C_flock_lockw" port) 0)
-            (err "cannot lock file" lock 'file-lock/blocking)
-            lock) ) ) )
+      (let loop ()
+	(let ((lock (setup port args 'file-lock/blocking)))
+	  (if (fx< (##core#inline "C_flock_lockw" port) 0)
+	      (select _errno
+		((_eintr) (##sys#dispatch-interrupt loop))
+		(else (err "cannot lock file" lock 'file-lock/blocking)))
+	      lock)))))
   (set! file-test-lock
     (lambda (port . args)
       (let ([lock (setup port args 'file-test-lock)])
@@ -1356,7 +1362,9 @@ EOF
     (##sys#check-structure lock 'lock 'file-unlock)
     (##core#inline "C_flock_setup" _f_unlck (##sys#slot lock 2) (##sys#slot lock 3))
     (when (fx< (##core#inline "C_flock_lock" (##sys#slot lock 1)) 0)
-      (posix-error #:file-error 'file-unlock "cannot unlock file" lock) ) ) )
+      (select _errno
+	((_eintr) (##sys#dispatch-interrupt (lambda () (file-unlock lock))))
+	(else (posix-error #:file-error 'file-unlock "cannot unlock file" lock))))))
 
 
 ;;; FIFOs: