diff --git a/lib/chibi/base64.scm b/lib/chibi/base64.scm index 3d95ad71..f80b6d9c 100644 --- a/lib/chibi/base64.scm +++ b/lib/chibi/base64.scm @@ -223,12 +223,12 @@ (eqv? #\= (string-ref src src-offset))) ;; done (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) - (write-string dst dst-len out))) + (write-string dst out 0 dst-len))) ((eqv? b1 *outside-char*) - (write-string dst dst-len out) + (write-string dst out 0 dst-len) (lp 0)) (else - (write-string dst dst-len out) + (write-string dst out 0 dst-len) ;; one to three chars left in buffer (string-set! src 0 (enc b1)) (cond @@ -248,7 +248,7 @@ src 0 src-len dst (lambda (src-offset dst-len b1 b2 b3) (let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3))) - (write-string dst dst-len out))))))))))) + (write-string dst out 0 dst-len))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; encoding @@ -318,7 +318,7 @@ (let lp () (let ((n (read-string! 2048 src in))) (base64-encode-string! src 0 n dst) - (write-string dst (* 3 (quotient (+ n 3) 4)) out) + (write-string dst out 0 (* 3 (quotient (+ n 3) 4))) (if (= n 2048) (lp))))))) diff --git a/lib/chibi/io.sld b/lib/chibi/io.sld index b15b4cfe..ba6e5a9a 100644 --- a/lib/chibi/io.sld +++ b/lib/chibi/io.sld @@ -11,7 +11,7 @@ make-filtered-input-port string-count open-input-bytevector open-output-bytevector get-output-bytevector string->utf8 utf8->string - write-u8 read-u8 peek-u8) + write-string write-u8 read-u8 peek-u8) (import (chibi) (chibi ast)) (include-shared "io/io") (include "io/io.scm")) diff --git a/lib/chibi/io/io.scm b/lib/chibi/io/io.scm index 36ec8511..f7a4b747 100644 --- a/lib/chibi/io/io.scm +++ b/lib/chibi/io/io.scm @@ -28,16 +28,28 @@ (display str out) (newline out))) -;;> @subsubsubsection{(write-string str n [out])} +;;> @subsubsubsection{(write-string str [out [start [end]]])} -;;> Writes the first @var{n} bytes of @var{str} to output port -;;> @var{out}. +;;> Writes the characters from @var{start} to @var{end} of string +;;> @var{str} to output port @var{out}, where @var{start} defaults +;;> to 0 and @var{end} defaults to @scheme{(string-length @var{str})}. -(cond-expand - ((not string-streams) - (define (write-string str n . o) - (let ((out (if (pair? o) (car o) (current-output-port)))) - (display (substring str 0 n) out))))) +(define (write-string str . o) + (let ((out (if (pair? o) (car o) (current-output-port))) + (o (if (pair? o) (cdr o) o))) + (if (pair? o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-length str)))) + (cond-expand + (string-streams + (if (zero? start) + (%write-string str end out) + (display (substring str start end) out))) + (else + (display (substring str start end) out)))) + (display str out)))) ;;> @subsubsubsection{(read-line [in [n]])} @@ -200,7 +212,7 @@ (lambda (str start end) (let ((str (if (zero? start) str (substring str start))) (n (- end start))) - (for-each (lambda (p) (write-string str n p)) ports) + (for-each (lambda (p) (%write-string str n p)) ports) n)))) (define (make-filtered-output-port filter out) @@ -210,7 +222,7 @@ (s1 (if (and (zero? start) (= end len)) str (substring str start end))) (s2 (filter s1))) (if (string? s2) - (write-string s2 (string-length s2) out)))))) + (%write-string s2 (string-length s2) out)))))) (define (make-concatenated-port . ports) (make-custom-input-port diff --git a/lib/init-7.scm b/lib/init-7.scm index 4277aa78..45eb2dcf 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -483,7 +483,7 @@ (define (display x . o) (let ((out (if (pair? o) (car o) (current-output-port)))) (cond ((char? x) (write-char x out)) - ((string? x) (write-string x #t out)) + ((string? x) (%write-string x #t out)) (else (write x out))))) (define (newline . o) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index ef65755c..f84fc7f2 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -51,7 +51,7 @@ vector->list vector->string vector-copy vector-copy! vector-fill! vector-for-each vector-length vector-map vector-ref vector-set! vector? when with-exception-handler - write-bytevector write-char write-u8 zero?) + write-bytevector write-char write-string write-u8 zero?) (include "define-values.scm" "extras.scm" "misc-macros.scm")) diff --git a/opcodes.c b/opcodes.c index 08cd0a30..971e8903 100644 --- a/opcodes.c +++ b/opcodes.c @@ -138,7 +138,7 @@ _FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "peek-char", (sexp)"current-input-port", sex _FN5(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "five", 0, sexp_five), #else _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL), -_OP(SEXP_OPC_IO, SEXP_OP_WRITE_STRING, 2, 3, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_OPORT), 0, "write-string", (sexp)"current-output-port", NULL), +_OP(SEXP_OPC_IO, SEXP_OP_WRITE_STRING, 2, 3, SEXP_VOID, _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_OPORT), 0, "%write-string", (sexp)"current-output-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL), #endif diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index f7a3ec2f..bd9992f5 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -1348,6 +1348,7 @@ (output-port-open? out))) (test #t (eof-object? (read (open-input-string "")))) +(test #t (char-ready? (open-input-string "42"))) (test 42 (read (open-input-string " 42 "))) (test #t (eof-object? (read-char (open-input-string "")))) @@ -1366,10 +1367,48 @@ (write 'abc out) (get-output-string out))) +(test "abc def" + (let ((out (open-output-string))) + (display "abc def" out) + (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (display #\a out) + (display "b" out) + (display #\c out) + (get-output-string out))) + +(test "\n" + (let ((out (open-output-string))) + (newline out) + (get-output-string out))) + +(test "abc def" + (let ((out (open-output-string))) + (write-string "abc def" out) + (get-output-string out))) + +(test "def" + (let ((out (open-output-string))) + (write-string "abc def" out 4) + (get-output-string out))) + +(test "c d" + (let ((out (open-output-string))) + (write-string "abc def" out 2 5) + (get-output-string out))) + +(test "" + (let ((out (open-output-bytevector))) + (flush-output-port out) + (get-output-string out))) + (test #t (eof-object? (read-u8 (open-input-bytevector #u8())))) (test 1 (read-u8 (open-input-bytevector #u8(1 2 3)))) (test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8())))) +(test #t (u8-ready? (open-input-bytevector #u8(1)))) (test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1)))) (test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2)))) (test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3)))) @@ -1397,6 +1436,26 @@ (write-u8 3 out) (get-output-bytevector out))) +(test #u8(1 2 3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out) + (get-output-bytevector out))) + +(test #u8(3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2) + (get-output-bytevector out))) + +(test #u8(3 4) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2 4) + (get-output-bytevector out))) + +(test #u8() + (let ((out (open-output-bytevector))) + (flush-output-port out) + (get-output-bytevector out))) + (test "#0=(1 . #0#)" ;; not guaranteed to be 0 indexed, spacing may differ (let ((out (open-output-string)) (x (list 1)))