157 lines
5.2 KiB
Scheme
157 lines
5.2 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)
|
|
(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))
|
|
(start 0)
|
|
(end (string-length s)))
|
|
(cond ((integer? fd/port)
|
|
(generic-read-string!/partial s start end
|
|
read-fdes-substring!/errno fd/port))
|
|
(else ; no differnce between fd/ports and s48 ports
|
|
(let* ((buffer (make-string (- end start)))
|
|
(needed (if (> (byte-vector-length (port-buffer fd/port)) 1)
|
|
'any 'immediate)) ;bufpol/none may return with 0
|
|
(len (read-block buffer 0 needed fd/port)))
|
|
(if (eof-object? len)
|
|
#f
|
|
(begin
|
|
(copy-bytes! buffer 0 s start len)
|
|
len)))))))
|
|
|
|
|
|
(define (read-string/partial len . maybe-fd/port)
|
|
(let* ((s (make-string len))
|
|
(fd/port (:optional 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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;
|
|
;;; Operation on ports is easy, since we can use read-block
|
|
|
|
(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 . args)
|
|
(let-optionals args ((fd/port (current-input-port))
|
|
(start 0)
|
|
(end (string-length s)))
|
|
(cond ((integer? fd/port)
|
|
(generic-read-string! s start end
|
|
read-fdes-substring!/errno fd/port))
|
|
|
|
(else ; no differnce between fd/port and s48 ports
|
|
(let ((nbytes/eof (read-block s start (- end start) fd/port)))
|
|
(if (eof-object? nbytes/eof)
|
|
#f
|
|
nbytes/eof))))))
|
|
|
|
(define (read-string len . maybe-fd/port)
|
|
(let* ((s (make-string len))
|
|
(fd/port (:optional 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)
|
|
(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)))))))
|
|
|
|
(define (write-string/partial s . args)
|
|
(let-optionals args ((fd/port (current-output-port))
|
|
(start 0)
|
|
(end (string-length s)))
|
|
(cond ((integer? fd/port)
|
|
(generic-write-string/partial s start end
|
|
write-fdes-substring/errno fd/port))
|
|
(else
|
|
;; the only way to implement this, would be to use
|
|
;; channel-maybe-write. But this is an VM-instruction which is not
|
|
;; exported. Since we now have threads this shouldn;t matter.
|
|
(error "write-string/parital is no longer supported on ports")))))
|
|
|
|
|
|
;;; 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)
|
|
(cond ((not err) (loop (+ i nwritten)))
|
|
((= err errno/intr) (loop i))
|
|
(else (errno-error err writer
|
|
s start i end target)))))))
|
|
|
|
(define (write-string s . args)
|
|
(let-optionals args ((fd/port (current-output-port))
|
|
(start 0)
|
|
(end (string-length s)))
|
|
(cond ((integer? fd/port)
|
|
(generic-write-string s start end
|
|
write-fdes-substring/errno fd/port))
|
|
(else (write-block s start (- end start) fd/port)))))
|