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
+	      (cond ((= errno errno/again) #f)
-		  (errno-error errno lock-region/no-block fdes lock))))
+		    ((= 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))
+	   (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-errno-syscall (unlock-region fdes lock)
-(define (unlock-region fdes lock)
+  (lambda (fdes lock) (call-lock-region %set-lock lock/release fdes lock)))
-  (cond ((call-lock-region %set-lock lock/release fdes lock) =>
-         (lambda (errno) (errno-error errno unlock-region fdes lock)))))
 
 
 ;;; Locks with dynamic extent -- with and without sugar

scsh/time.scm

@@ -118,22 +118,24 @@
   fixnum) ; lo secs
 
 (define (time . args) ; optional arg [date]
-  (receive (err hi-secs lo-secs)
+  (let lp ()
-	   (if (null? args)
+    (receive (err hi-secs lo-secs)
-	       (%time/errno) ; Fast path for (time).
+	(if (null? args)
-	       (let ((date (check-arg date? (car args) time)))
+	    (%time/errno)		; Fast path for (time).
-		 (%date->time/errno (date:seconds   date)
+	    (let ((date (check-arg date? (car args) time)))
-				    (date:minute    date)
+	      (%date->time/errno (date:seconds   date)
-				    (date:hour      date)
+				 (date:minute    date)
-				    (date:month-day date)
+				 (date:hour      date)
-				    (date:month     date)
+				 (date:month-day date)
-				    (date:year      date)
+				 (date:month     date)
-				    (date:tz-name   date)	; #f or string
+				 (date:year      date)
-				    (date:tz-secs   date)	; #f or int
+				 (date:tz-name   date) ; #f or string
-				    (date:summer?   date))))
+				 (date:tz-secs   date) ; #f or int
+				 (date:summer?   date))))
 
-    (if err (apply errno-error err time args)
+      (cond ((not err) (compose-8/24 hi-secs lo-secs))	; Win.
-	(compose-8/24 hi-secs lo-secs))))
+	    ((= 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)))
-    (receive (err seconds minute hour month-day month
+    (let lp ()
-		  year tz-name tz-secs summer? week-day year-day)
+      (receive (err seconds minute hour month-day month
-	     (%time->date (hi8 time) (lo24 time) zone)
+		    year tz-name tz-secs summer? week-day year-day)
-      (if err (errno-error err date time zone)
+	       (%time->date (hi8 time) (lo24 time) zone)
-	  (make-%date seconds minute hour month-day month
+	(cond ((not err)
-		      year
+	       (make-%date seconds minute hour month-day month
-		      (format-time-zone (or tz-name "UTC") tz-secs)
+			   year
-		      tz-secs summer? week-day year-day)))))
+			   (format-time-zone (or tz-name "UTC") tz-secs)
+			   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)
+    (cond ((not err) result)
-	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)))
-    (receive (errno fd) (open-control-tty/errno ttyname flags)
+    (let lp ()
-      (if errno
+      (receive (errno fd) (open-control-tty/errno ttyname flags)
-	  (errno-error errno open-control-tty ttyname flags)
+	(cond ((not errno)
-
+	       (let* ((access (bitwise-and flags open/access-mask))
-	  (let* ((access (bitwise-and flags open/access-mask))
+		      (port ((if (or (= access open/read)
-		 (port ((if (or (= access open/read) (= access open/read+write))
+				     (= access open/read+write))
-			    make-input-fdport
+				 make-input-fdport
-			    make-output-fdport)
+				 make-output-fdport)
-			fd)))
+			     fd)))
-	    (%install-port fd port)
+		 (%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))