scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Retry syscalls when interrupted.

This commit is contained in:
shivers 1996-08-24 08:52:34 +00:00
parent 75bad52dfe
commit d472115b34
3 changed files with 54 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
scsh/flock.scm
View File

@ -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

56
scsh/time.scm
View File

@ -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)

24
scsh/tty.scm
View File

@ -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))