1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Conflicts:
	test-suite/tests/r6rs-ports.test
This commit is contained in:
Andy Wingo 2015-01-22 14:53:06 +01:00
commit 0a5b437ef9
3 changed files with 49 additions and 14 deletions

View file

@ -1,4 +1,4 @@
/* Copyright (C) 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. /* Copyright (C) 2009, 2010, 2011, 2013-2015 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -299,9 +299,10 @@ cbip_setvbuf (SCM port, long read_size, long write_size)
switch (read_size) switch (read_size)
{ {
case 0: case 0:
/* Unbuffered: keep PORT's bytevector as is (it will be used in /* Unbuffered: keep using PORT's bytevector as the underlying
future 'scm_c_read' calls), but point to the one-byte buffer. */ buffer (it will also be used by future 'scm_c_read' calls.) */
pt->read_buf = &pt->shortbuf; assert (SCM_BYTEVECTOR_LENGTH (bv) >= 1);
pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
pt->read_buf_size = 1; pt->read_buf_size = 1;
break; break;
@ -385,9 +386,11 @@ cbip_fill_input (SCM port)
if (buffered) if (buffered)
{ {
/* Make sure the buffer isn't corrupt. BV can be passed directly /* Make sure the buffer isn't corrupt. Its size can be 1 when
to READ_PROC. */ someone called 'setvbuf' with _IONBF. BV can be passed
assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv)); directly to READ_PROC. */
assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv)
|| c_port->read_buf_size == 1);
c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
} }
else else

View file

@ -1,6 +1,6 @@
;;; Parsing Guile's command-line ;;; Parsing Guile's command-line
;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -147,8 +147,9 @@ If FILE begins with `-' the -s switch is mandatory.
(let ((port (if fatal? (let ((port (if fatal?
(current-error-port) (current-error-port)
(current-output-port)))) (current-output-port))))
(if fmt (when fmt
(apply format port fmt args)) (apply format port fmt args)
(newline port))
(format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name) (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
(display *usage* port) (display *usage* port)
@ -203,7 +204,8 @@ If FILE begins with `-' the -s switch is mandatory.
(turn-off-debugging? #f)) (turn-off-debugging? #f))
(define (error fmt . args) (define (error fmt . args)
(apply shell-usage usage-name #t fmt args)) (apply shell-usage usage-name #t
(string-append "error: " fmt "~%") args))
(define (parse args out) (define (parse args out)
(cond (cond
@ -405,7 +407,7 @@ If FILE begins with `-' the -s switch is mandatory.
(exit 0)) (exit 0))
(else (else
(error "Unrecognized switch ~a" arg))))))) (error "unrecognized switch ~a" arg)))))))
(define (finish args out) (define (finish args out)
;; Check to make sure the -ds got a -s. ;; Check to make sure the -ds got a -s.

View file

@ -1,7 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*- ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;; ;;;;
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, ;;;; Copyright (C) 2009-2012, 2013-2015 Free Software Foundation, Inc.
;;;; 2014 Free Software Foundation, Inc.
;;;; Ludovic Courtès ;;;; Ludovic Courtès
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -557,6 +556,37 @@ not `set-port-position!'"
obj)) obj))
ret))))) ret)))))
(pass-if-equal "custom binary input port unbuffered & 'get-string-all'"
(make-string 1000 #\a)
;; In Guile 2.0.11 this test would lead to a buffer overrun followed
;; by an assertion failure. See <http://bugs.gnu.org/19621>.
(let* ((input (with-fluids ((%default-port-encoding #f))
(open-input-string (make-string 1000 #\a))))
(read! (lambda (bv index count)
(let ((n (get-bytevector-n! input bv index
count)))
(if (eof-object? n) 0 n))))
(port (make-custom-binary-input-port "foo" read!
#f #f #f)))
(setvbuf port _IONBF)
(get-string-all port)))
(pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'"
(make-string 1000 #\λ)
;; In Guile 2.0.11 this test would lead to a buffer overrun followed
;; by an assertion failure. See <http://bugs.gnu.org/19621>.
(let* ((input (with-fluids ((%default-port-encoding "UTF-8"))
(open-input-string (make-string 1000 #\λ))))
(read! (lambda (bv index count)
(let ((n (get-bytevector-n! input bv index
count)))
(if (eof-object? n) 0 n))))
(port (make-custom-binary-input-port "foo" read!
#f #f #f)))
(setvbuf port _IONBF)
(set-port-encoding! port "UTF-8")
(get-string-all port)))
(pass-if-equal "custom binary input port, unbuffered then buffered" (pass-if-equal "custom binary input port, unbuffered then buffered"
`((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…") `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
(777 ,(eof-object))) (777 ,(eof-object)))