Retry syscalls when interrupted.

scsh/flock.scm

@@ -95,8 +95,9 @@
 (define (lock-region/no-block fdes lock)
   (cond ((call-lock-region %set-lock fcntl/set-record-lock-noblock fdes lock) 
          => (lambda (errno)
-	      (if (= errno errno/again) #f
-		  (errno-error errno lock-region/no-block fdes lock))))
+	      (cond ((= errno errno/again) #f)
+		    ((= errno errno/intr) (lock-region/no-block fdes lock))
+		    (else (errno-error errno lock-region/no-block fdes lock)))))
 	(else #t)))
 
 
@@ -105,15 +106,15 @@
 (define (get-lock-region fdes lock)
   (receive (err type whence start len pid)
            (call-lock-region %get-lock fcntl/get-record-lock fdes lock)
-    (if err (errno-error err get-lock-region fdes lock)
+    (cond ((not err)
 	   (and (not (= type lock/release))
-	     (make-%lock-region (= type lock/write) start len whence pid)))))
+		(make-%lock-region (= type lock/write) start len whence pid)))
+	  ((= err errno/intr) (get-lock-region fdes lock))
+	  (else (errno-error err get-lock-region fdes lock)))))
 
 
-
-(define (unlock-region fdes lock)
-  (cond ((call-lock-region %set-lock lock/release fdes lock) =>
-         (lambda (errno) (errno-error errno unlock-region fdes lock)))))
+(define-errno-syscall (unlock-region fdes lock)
+  (lambda (fdes lock) (call-lock-region %set-lock lock/release fdes lock)))
 
 
 ;;; Locks with dynamic extent -- with and without sugar

scsh/time.scm

@@ -118,6 +118,7 @@
   fixnum) ; lo secs
 
 (define (time . args) ; optional arg [date]
+  (let lp ()
     (receive (err hi-secs lo-secs)
 	(if (null? args)
 	    (%time/errno)		; Fast path for (time).
@@ -132,8 +133,9 @@
 				 (date:tz-secs   date) ; #f or int
 				 (date:summer?   date))))
 
-    (if err (apply errno-error err time args)
-	(compose-8/24 hi-secs lo-secs))))
+      (cond ((not err) (compose-8/24 hi-secs lo-secs))	; Win.
+	    ((= errno/intr err) (lp))			; Retry.
+	    (else (apply errno-error err time args)))))); Lose.
 
 
 ;;; Date
@@ -162,14 +164,17 @@
 	(zone (check-arg time-zone?
 			 (and (pair? args) (:optional (cdr args) #f))
 			 date)))
+    (let lp ()
       (receive (err seconds minute hour month-day month
 		    year tz-name tz-secs summer? week-day year-day)
 	       (%time->date (hi8 time) (lo24 time) zone)
-      (if err (errno-error err date time zone)
+	(cond ((not err)
 	       (make-%date seconds minute hour month-day month
 			   year
 			   (format-time-zone (or tz-name "UTC") tz-secs)
-		      tz-secs summer? week-day year-day)))))
+			   tz-secs summer? week-day year-day))
+	      ((= errno/intr err) (lp))
+	      (errno-error err date time zone))))))
 
 
 ;;; Formatting date strings
@@ -194,8 +199,9 @@
 			       (date:summer?   date)
 			       (date:week-day  date)
 			       (date:year-day  date))
-    (if err (errno-error err format-date fmt date)
-	result)))
+    (cond ((not err) result)
+	  ((= errno/intr err) (format-date fmt date))
+	  (else (errno-error err format-date fmt date)))))
 
 (define-foreign %format-date/errno (format_date (string fmt)
 						(fixnum seconds)

scsh/tty.scm

@@ -345,17 +345,19 @@
 
 (define (open-control-tty ttyname . maybe-flags)
   (let ((flags (:optional maybe-flags open/read+write)))
+    (let lp ()
       (receive (errno fd) (open-control-tty/errno ttyname flags)
-      (if errno
-	  (errno-error errno open-control-tty ttyname flags)
-
+	(cond ((not errno)
 	       (let* ((access (bitwise-and flags open/access-mask))
-		 (port ((if (or (= access open/read) (= access open/read+write))
+		      (port ((if (or (= access open/read)
+				     (= access open/read+write))
 				 make-input-fdport
 				 make-output-fdport)
 			     fd)))
 		 (%install-port fd port)
-	    port)))))
+		 port))
+	      ((= errno/intr errno) (lp))
+	      (else (errno-error errno open-control-tty ttyname flags)))))))
 
 (define-foreign open-control-tty/errno (open_ctty (string ttyname)
 						  (fixnum flags))