diff --git a/scsh/flock.scm b/scsh/flock.scm index 973d464..f368a48 100644 --- a/scsh/flock.scm +++ b/scsh/flock.scm @@ -86,13 +86,9 @@ ;;; The main routines ;;;;;;;;;;;;;;;;;;;;; -(define (lock-region fdes lock) - (let lp () - (cond ((call-lock-region %set-lock fcntl/set-record-lock fdes lock) => - (lambda (errno) - (if (= errno errno/intr) (lp) ; Retry on interrupt. - (errno-error errno lock-region fdes lock))))))) - +(define-errno-syscall (lock-region fdes lock) + (lambda (fdes lock) + (call-lock-region %set-lock fcntl/set-record-lock fdes lock))) ;;; Return true/false indicating success/failure. diff --git a/scsh/newports.scm b/scsh/newports.scm index d7c6369..68ecaa2 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -62,12 +62,14 @@ (define (fdport*-write-char data char) (check-arg open-fdport-data? data fdport*-write-char) (if (not (fdport-data:closed? data)) - (%fdport*-write-char data char))) + (%fdport*-write-char data char)) + #f) ; Bogus fix -- otherwise %fdport*-...'s 0-value return blows up S48. (define (fdport*-write-string data string) (check-arg open-fdport-data? data fdport*-write-string) (generic-write-string string 0 (string-length string) ; from rw.scm - write-fdport*-substring/errno data)) + write-fdport*-substring/errno data) + #f) (define input-fdport-methods (make-input-port-methods close-fdport* @@ -82,12 +84,13 @@ (make-output-port-methods close-fdport* fdport*-write-char fdport*-write-string - flush-fdport* ; force-output + (lambda (d) ; force output + (flush-fdport* d) + #f) ; bogus workaround. fdport-null-method ; fresh-line fdport-null-method ; current-column fdport-null-method)) ; current-row - (define (fdport-data port) (let ((d ((cond ((extensible-input-port? port) extensible-input-port-local-data) diff --git a/scsh/procobj.scm b/scsh/procobj.scm index 972cd50..4e3ec69 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -218,11 +218,9 @@ (define (%wait-pid pid flags) (let lp () (receive (err pid status) (%wait-pid/errno pid flags) - (if err - (if (= err errno/intr) (lp) - (errno-error err %wait-pid pid flags)) - (and (not (zero? pid)) status))))) ; pid=0 => none ready. - + (cond ((not err) (and (not (zero? pid)) status)) ; pid=0 => none ready. + ((= err errno/intr) (lp)) + (else (errno-error err %wait-pid pid flags)))))) (define (%wait-any flags) (let lp () diff --git a/scsh/rw.scm b/scsh/rw.scm index 570a3f5..15251aa 100644 --- a/scsh/rw.scm +++ b/scsh/rw.scm @@ -19,13 +19,12 @@ (if (= start end) 0 ; Vacuous request. (let loop () (receive (err nread) (reader s start end source) - (if err - (case err - ((errno/intr) (loop)) - ((errno/wouldblock errno/again) 0) ; No forward-progess here. - (else (errno-error err reader - s start start end source))) - (and (not (zero? nread)) nread)))))) + (cond ((not err) (and (not (zero? nread)) nread)) + ((= err errno/intr) (loop)) + ((or (= err errno/wouldblock) ; No forward-progess here. + (= err errno/again)) + 0) + (else (errno-error err reader s start start end source))))))) (define (read-string!/partial s . args) (let-optionals args ((fd/port (current-input-port)) @@ -132,13 +131,11 @@ (if (= start end) 0 ; Vacuous request. (let loop () (receive (err nwritten) (writer s start end target) - (if err - (case err - ((errno/intr) (loop)) - ((errno/again errno/wouldblock) 0) + (cond ((not err) nwritten) + ((= err errno/intr) (loop)) + ((or (= err errno/again) (= err errno/wouldblock)) 0) (else (errno-error err writer - s start start end target))) - nwritten))))) + s start start end target))))))) (define (write-string/partial s . args) (let-optionals args ((fd/port (current-output-port)) @@ -164,12 +161,10 @@ (let loop ((i start)) (if (< i end) (receive (err nwritten) (writer s i end target) - (if err - (case err - ((errno/intr) (loop i)) + (cond ((not err) (loop (+ i nwritten))) + ((= err errno/intr) (loop i)) (else (errno-error err writer - s start i end target))) - (loop (+ i nwritten))))))) + s start i end target))))))) (define (write-string s . args) (let-optionals args ((fd/port (current-output-port)) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index 4360354..7331966 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -66,6 +66,15 @@ ((= err errno/intr) (apply syscall args)) ; Retry (else (apply errno-error err syscall args)))))))); Lose +;;; By the way, it would be better to insert a (LET LP () ...) for the +;;; the errno/intr retries, instead of calling the top-level definition +;;; (because in Scheme you have to allow for the fact that top-level +;;; defns can be re-defined, so the compiler can't just turn it into a +;;; jump), but the brain-dead S48 byte-compiler will cons a closure for +;;; the LP loop, which means that little syscalls like read-char can cons +;;; like crazy. So I'm doing it this way. Ech. + + ;;; Process ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -975,11 +984,20 @@ (define-errno-syscall (%fdport*-write-char desc c) %fdport*-write-char/errno) - (define-foreign flush-fdport*/errno (flush_fdport (desc data)) (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno -(define-errno-syscall (flush-fdport* data) flush-fdport*/errno) +;;; FLUSH-FDPORT* isn't defined with DEFINE-ERRNO-SYSCALL because that would +;;; return 0 values, which blows up S48's extended-port machinery. This +;;; version returns #f. +;;; ??? + +(define (flush-fdport* data) + (cond ((flush-fdport*/errno data) => + (lambda (err) (if (= err errno/intr) + (flush-fdport* data) + (errno-error err flush-fdport* data)))) + (else #f))) (define-foreign flush-all-ports/errno (flush_all_ports) (to-scheme integer errno_or_false))