1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00

get-bytevector-n in Scheme.

* module/ice-9/sports.scm (fill-input): Add io-mode optional arg.
  (get-bytevector-n): New implementation.
  (port-bindings): Add get-bytevector-n.
* test-suite/tests/sports.test: Add r6rs-ports tests.
This commit is contained in:
Andy Wingo 2016-05-22 23:02:41 +02:00
parent 4e288ec2ff
commit c95a19376b
2 changed files with 51 additions and 3 deletions

View file

@ -56,6 +56,7 @@
read-char)
#:export (lookahead-u8
get-u8
get-bytevector-n
%read-line
read-line
read-delimited
@ -148,8 +149,8 @@
(maybe-consume-bom utf32be-bom)
(specialize-port-encoding! port 'UTF-32BE)))))))
(define* (fill-input port #:optional (minimum-buffering 1))
(clear-stream-start-for-bom-read port 'text)
(define* (fill-input port #:optional (minimum-buffering 1) (io-mode 'text))
(clear-stream-start-for-bom-read port io-mode)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(buffered (- (port-buffer-end buf) cur)))
@ -226,6 +227,52 @@
(fast-path buf bv cur buffered)))
(peek-bytes port 1 fast-path slow-path))
(define* (get-bytevector-n port count)
(let ((ret (make-bytevector count)))
(define (port-buffer-take! pos buf cur to-copy)
(bytevector-copy! (port-buffer-bytevector buf) cur
ret pos to-copy)
(set-port-buffer-cur! buf (+ cur to-copy))
(+ pos to-copy))
(define (take-already-buffered)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(buffered (- (port-buffer-end buf) cur)))
(port-buffer-take! 0 buf cur (min count buffered))))
(define (trim-and-return len)
(if (zero? len)
the-eof-object
(let ((partial (make-bytevector len)))
(bytevector-copy! ret 0 partial 0 len)
partial)))
(define (buffer-and-fill pos)
(call-with-values (lambda () (fill-input port 1 'binary))
(lambda (buf buffered)
(if (zero? buffered)
(begin
(set-port-buffer-has-eof?! buf #f)
(trim-and-return pos))
(let ((pos (port-buffer-take! pos buf (port-buffer-cur buf)
(min (- count pos) buffered))))
(if (= pos count)
ret
(buffer-and-fill pos)))))))
(define (fill-directly pos)
(when (port-random-access? port)
(flush-output port))
(port-clear-stream-start-for-bom-read port)
(let lp ((pos pos))
(let ((read (read-bytes port ret pos (- count pos))))
(cond
((= read (- count pos)) ret)
((zero? read) (trim-and-return pos))
(else (lp (+ pos read)))))))
(let ((pos (take-already-buffered)))
(cond
((= pos count) (if (zero? pos) the-eof-object ret))
((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos))
(else (fill-directly pos))))))
(define (decoding-error subr port)
;; GNU definition; fixme?
(define EILSEQ 84)
@ -527,7 +574,7 @@
(define saved-port-bindings #f)
(define port-bindings
'(((guile) read-char peek-char)
((ice-9 binary-ports) get-u8 lookahead-u8)
((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n)
((ice-9 rdelim) %read-line read-line read-delimited)))
(define (install-sports!)
(unless saved-port-bindings

View file

@ -53,5 +53,6 @@
(include-tests "tests/ports.test")
(include-tests "tests/rdelim.test")
(include-tests "tests/r6rs-ports.test")
(uninstall-sports!)