diff --git a/scsh/flock.scm b/scsh/flock.scm index f368a48..869d0c3 100644 --- a/scsh/flock.scm +++ b/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) - (and (not (= type lock/release)) - (make-%lock-region (= type lock/write) start len whence pid))))) + (cond ((not err) + (and (not (= type lock/release)) + (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 diff --git a/scsh/time.scm b/scsh/time.scm index 5398d5f..e6579b2 100644 --- a/scsh/time.scm +++ b/scsh/time.scm @@ -118,22 +118,24 @@ fixnum) ; lo secs (define (time . args) ; optional arg [date] - (receive (err hi-secs lo-secs) - (if (null? args) - (%time/errno) ; Fast path for (time). - (let ((date (check-arg date? (car args) time))) - (%date->time/errno (date:seconds date) - (date:minute date) - (date:hour date) - (date:month-day date) - (date:month date) - (date:year date) - (date:tz-name date) ; #f or string - (date:tz-secs date) ; #f or int - (date:summer? date)))) + (let lp () + (receive (err hi-secs lo-secs) + (if (null? args) + (%time/errno) ; Fast path for (time). + (let ((date (check-arg date? (car args) time))) + (%date->time/errno (date:seconds date) + (date:minute date) + (date:hour date) + (date:month-day date) + (date:month date) + (date:year date) + (date:tz-name date) ; #f or string + (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))) - (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) - (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))))) + (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) + (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)) + ((= 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) diff --git a/scsh/tty.scm b/scsh/tty.scm index 8d1d4cf..6b153af 100644 --- a/scsh/tty.scm +++ b/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) - (if errno - (errno-error errno open-control-tty ttyname flags) - - (let* ((access (bitwise-and flags open/access-mask)) - (port ((if (or (= access open/read) (= access open/read+write)) - make-input-fdport - make-output-fdport) - fd))) - (%install-port fd port) - port))))) + (let lp () + (receive (errno fd) (open-control-tty/errno ttyname flags) + (cond ((not errno) + (let* ((access (bitwise-and flags open/access-mask)) + (port ((if (or (= access open/read) + (= access open/read+write)) + make-input-fdport + make-output-fdport) + fd))) + (%install-port fd 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))