Making chibi's write-string agree with R7RS.

Adding additional write tests.

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)))))))
 

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"))

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})}.
 
+(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
- ((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)))))
+           (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

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)

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"))

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

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)))