209 lines
6.5 KiB
Scheme
209 lines
6.5 KiB
Scheme
;;; Basic read and write
|
|
;;; Copyright (c) 1993 by Olin Shivers.
|
|
|
|
;;; Note: read ops should check to see if their string args are mutable.
|
|
|
|
(define (bogus-substring-spec? s start end)
|
|
(or (< start 0)
|
|
(< (string-length s) end)
|
|
(< end start)))
|
|
|
|
|
|
;;; Best-effort/forward-progress reading
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (generic-read-string!/partial s start end reader source)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices" reader source s start end))
|
|
|
|
(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))))))
|
|
|
|
(define (read-string!/partial s . maybe-args)
|
|
(receive (fd/port start end)
|
|
(parse-optionals maybe-args
|
|
(current-input-port) 0 (string-length s))
|
|
(cond ((integer? fd/port)
|
|
(generic-read-string!/partial s start end
|
|
read-fdes-substring!/errno fd/port))
|
|
((fdport? fd/port)
|
|
(generic-read-string!/partial s start end
|
|
read-fdport*-substring!/errno
|
|
(extensible-port-local-data fd/port)))
|
|
|
|
(else ; Hack it for base S48 ports
|
|
;; This case is a little gross in order to get
|
|
;; the forward-progress guarantee and handle non-blocking i/o.
|
|
;; Unix sux. So do low-level Scheme looping constructs.
|
|
(if (>= start end) 0
|
|
(let lp ((i start))
|
|
(let ((c (with-errno-handler
|
|
((err data) ((errno/wouldblock errno/again) #f))
|
|
(read-char fd/port))))
|
|
(cond ((not c) (- i start)) ; non-blocking i/o bailout
|
|
((eof-object? c)
|
|
(let ((nread (- i start)))
|
|
(and (not (zero? nread)) nread)))
|
|
(else
|
|
(string-set! s i c)
|
|
(let ((i (+ i 1)))
|
|
(if (or (= i end) (not (char-ready? fd/port)))
|
|
(- i start)
|
|
(lp i))))))))))))
|
|
|
|
(define (read-string/partial len . maybe-fd/port)
|
|
(let* ((s (make-string len))
|
|
(fd/port (optional-arg maybe-fd/port (current-input-port)))
|
|
(nread (read-string!/partial s fd/port 0 len)))
|
|
(cond ((not nread) #f) ; EOF
|
|
((= nread len) s)
|
|
(else (substring s 0 nread)))))
|
|
|
|
|
|
;;; Persistent reading
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (generic-read-string! s start end reader source)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices" reader source s start end))
|
|
|
|
(let loop ((i start))
|
|
(if (>= i end) (- i start)
|
|
(receive (err nread) (reader s i end source)
|
|
(cond (err (if (= err errno/intr) (loop i)
|
|
;; Give info on partially-read data in error packet.
|
|
(errno-error err reader
|
|
s start i end source)))
|
|
|
|
((zero? nread) ; EOF
|
|
(let ((result (- i start)))
|
|
(and (not (zero? result)) result)))
|
|
|
|
(else (loop (+ i nread))))))))
|
|
|
|
(define (read-string! s . maybe-args)
|
|
(receive (fd/port start end)
|
|
(parse-optionals maybe-args
|
|
(current-input-port) 0 (string-length s))
|
|
(cond ((integer? fd/port)
|
|
(generic-read-string! s start end
|
|
read-fdes-substring!/errno fd/port))
|
|
|
|
((fdport? fd/port)
|
|
(generic-read-string! s start end
|
|
read-fdport*-substring!/errno
|
|
(extensible-port-local-data fd/port)))
|
|
|
|
(else ; Hack it
|
|
(let lp ((i start (+ i 1)))
|
|
(if (= i end) (- end start)
|
|
(let ((c (read-char fd/port)))
|
|
(if (eof-object? c)
|
|
(let ((nread (- i start)))
|
|
(and (not (zero? nread)) nread))
|
|
(begin (string-set! s i c)
|
|
(lp (+ i 1)))))))))))
|
|
|
|
(define (read-string len . maybe-fd/port)
|
|
(let* ((s (make-string len))
|
|
(fd/port (optional-arg maybe-fd/port (current-input-port)))
|
|
(nread (read-string! s fd/port 0 len)))
|
|
(cond ((not nread) #f) ; EOF
|
|
((= nread len) s)
|
|
(else (substring s 0 nread)))))
|
|
|
|
|
|
;;; Best-effort/forward-progress writing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Non-blocking output to a buffered port is not defined.
|
|
|
|
(define (generic-write-string/partial s start end writer target)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices" writer s start end target))
|
|
|
|
(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)
|
|
(else (errno-error err writer
|
|
s start start end target)))
|
|
nwritten)))))
|
|
|
|
(define (write-string/partial s . maybe-args)
|
|
(receive (fd/port start end)
|
|
(parse-optionals maybe-args
|
|
(current-output-port) 0 (string-length s))
|
|
(cond ((integer? fd/port)
|
|
(generic-write-string/partial s start end
|
|
write-fdes-substring/errno fd/port))
|
|
((fdport? fd/port)
|
|
(generic-write-string/partial s start end
|
|
write-fdport*-substring/errno
|
|
(extensible-port-local-data fd/port)))
|
|
(else (display (substring s start end) fd/port))))) ; hack
|
|
|
|
|
|
;;; Persistent writing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (generic-write-string s start end writer target)
|
|
(if (bogus-substring-spec? s start end)
|
|
(error "Bad substring indices" writer s start end target))
|
|
|
|
(let loop ((i start))
|
|
(if (< i end)
|
|
(receive (err nwritten) (writer s i end target)
|
|
(if err
|
|
(case err
|
|
((errno/intr) (loop i))
|
|
(else (errno-error err writer
|
|
s start i end target)))
|
|
(loop (+ i nwritten)))))))
|
|
|
|
(define (write-string s . maybe-args)
|
|
(receive (fd/port start end)
|
|
(parse-optionals maybe-args
|
|
(current-output-port) 0 (string-length s))
|
|
(cond ((integer? fd/port)
|
|
(generic-write-string s start end
|
|
write-fdes-substring/errno fd/port))
|
|
((fdport? fd/port)
|
|
(generic-write-string s start end
|
|
write-fdport*-substring/errno
|
|
(extensible-port-local-data fd/port)))
|
|
|
|
(else (display (substring s start end) fd/port))))) ; hack
|
|
|
|
(define (y-or-n? question . maybe-eof-value)
|
|
(let loop ((count *y-or-n-eof-count*))
|
|
(display question)
|
|
(display " (y/n)? ")
|
|
(let ((line (read-line)))
|
|
(cond ((eof-object? line)
|
|
(newline)
|
|
(if (= count 0)
|
|
(optional-arg* maybe-eof-value
|
|
(lambda () (error "EOF in y-or-n?")))
|
|
(begin (display "I'll only ask another ")
|
|
(write count)
|
|
(display " times.")
|
|
(newline)
|
|
(loop (- count 1)))))
|
|
((< (string-length line) 1) (loop count))
|
|
((char=? (string-ref line 0) #\y) #t)
|
|
((char=? (string-ref line 0) #\n) #f)
|
|
(else (loop count))))))
|
|
|
|
(define *y-or-n-eof-count* 100)
|