Commit e6c0837e authored by Erick's avatar Erick

Added R7RS function write-string

parent 5a7d8182
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 5-Aug-2018 19:25 (eg)
;; Last file update: 22-Aug-2018 14:15 (eg)
;;
;; ======================================================================
......@@ -617,8 +617,9 @@ be accessed as a normal port with the standard Scheme primitives.])
(insertdoc 'write-with-shared-structure)
(insertdoc 'display)
(insertdoc 'newline)
(insertdoc 'write-string)
(insertdoc 'write-u8)
(insertdoc 'writ-bytevector)
(insertdoc 'write-bytevector)
(insertdoc 'write-char)
(insertdoc 'write-chars)
(insertdoc 'write-byte)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 22-Aug-2018 13:03 (eg)
;;;; Last file update: 22-Aug-2018 14:15 (eg)
;;;;
......@@ -800,6 +800,25 @@ doc>
(set! end (bytevector-length bv)))
(%read-bytevector! bv port start end)))
#|
<doc R7RS write-string
* (write-string string)
* (write-string string port)
* (write-string string port start)
* (write-string string port start end)
*
* Writes the characters of |string| from |start| to |end| in
* left-to-right order to the textual output |port|.
doc>
|#
(define (write-string str :optional (port (current-output-port))
(start 0)
(end -1 end?))
(%claim-error
'write-string
(%write-string str port start (if end? end (string-length str)))))
#|
<doc R7RS write-u8
* (write-u8 byte)
......@@ -826,7 +845,6 @@ doc>
* left-to-right order to the binary output |port|.
doc>
|#
(define (write-bytevector bv :optional (port (current-output-port))
(start 0)
(end -1 end?))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Jun-2000 15:07 (eg)
;;;; Last file update: 3-Jul-2018 19:03 (eg)
;;;; Last file update: 22-Aug-2018 13:51 (eg)
;;;;
;; This file defines the REPL module. This module does not export anything
......@@ -226,7 +226,7 @@ doc>
'clear)
out)))
(else
(for-each (lambda (x) (write* x out) (newline out))
(for-each (lambda (x) (write-shared x out) (newline out))
v)))
(flush-output-port out))))))))
;; Loop if we have not meet an EOF
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 22-Aug-2018 12:59 (eg)
* Last file update: 22-Aug-2018 16:14 (eg)
*
*/
......@@ -95,6 +95,10 @@ static void error_bad_textual_port(SCM port)
general_io_error(io_malformed, "bad textual port ~S", port);
}
static void error_bad_string(SCM obj)
{
general_io_error(io_bad_param, "bad string ~S", obj);
}
static SCM verify_port(SCM port, int mode)
......@@ -396,7 +400,7 @@ doc>
DEFINE_PRIMITIVE("read-bytes!", d_read_bytes, subr12, (SCM str, SCM port))
{
port = verify_port(port, PORT_READ);
if (!STRINGP(str)) STk_error("bad string ~S", str);
if (!STRINGP(str)) error_bad_string(str);
return MAKE_INT(STk_read_buffer(port, STRING_CHARS(str), STRING_LENGTH(str)));
}
......@@ -448,7 +452,7 @@ DEFINE_PRIMITIVE("%read-bytevector!", d_read_bytevector, subr4,
if (vstart < 0) STk_error("bad start value ~S", start);
if (vend == LONG_MIN || vend > UVECTOR_SIZE(bv))
STk_error("bad end value ~S", start);
STk_error("bad end value ~S", end);
if (vstart > vend) STk_error("start index is bigger than end index");
n = vend - vstart;
......@@ -728,6 +732,32 @@ DEFINE_PRIMITIVE("write-char", write_char, subr12, (SCM c, SCM port))
return STk_void;
}
DEFINE_PRIMITIVE("%write-string", write_string, subr4, (SCM str, SCM port,
SCM start, SCM end))
{
long vstart = STk_integer_value(start);
long vend = STk_integer_value(end);
if (!STRINGP(str)) error_bad_string(str);
verify_port(port, PORT_WRITE | PORT_TEXTUAL);
if (vstart < 0) STk_error("bad start value ~S", start);
if (vend == LONG_MIN || vend > STRING_LENGTH(str))
STk_error("bad end value ~S", end);
if (vstart > vend) STk_error("start index is bigger than end index");
if (STk_use_utf8 && !STRING_MONOBYTE(str)) {
char *adr_start = STk_utf8_index(STRING_CHARS(str), vstart, STRING_SIZE(str));
char *adr_end = STk_utf8_index(STRING_CHARS(str), vend, STRING_SIZE(str));
STk_write_buffer(port, adr_start, adr_end - adr_start);
}
else {
STk_write_buffer(port, STRING_CHARS(str)+vstart, vend -vstart);
}
return STk_void;
}
/*
<doc EXT write-chars
......@@ -747,7 +777,7 @@ doc>
*/
DEFINE_PRIMITIVE("write-chars", write_chars, subr12, (SCM str, SCM port))
{
if (!STRINGP(str)) STk_error_bad_io_param("bad string ~S", str);
if (!STRINGP(str)) error_bad_string(str);
port = verify_port(port, PORT_WRITE);
STk_write_buffer(port, STRING_CHARS(str), STRING_SIZE(str));
return STk_void;
......@@ -1672,6 +1702,7 @@ int STk_init_port(void)
ADD_PRIMITIVE(display);
ADD_PRIMITIVE(newline);
ADD_PRIMITIVE(write_char);
ADD_PRIMITIVE(write_string);
ADD_PRIMITIVE(write_chars);
ADD_PRIMITIVE(write_byte);
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 22-Aug-2018 13:20 (eg)
;;;; Last file update: 22-Aug-2018 16:23 (eg)
;;;;
(require "test")
......@@ -544,6 +544,24 @@
(write-shared y out)
(get-output-string out))))
;; --------------------------------------------------
(test "chibi write-string.1"
"abc def"
(let ((out (open-output-string)))
(write-string "abc def" out)
(get-output-string out)))
(test "chibi write-string.2"
"def"
(let ((out (open-output-string)))
(write-string "abc def" out 4)
(get-output-string out)))
(test "chibi write-string.3"
"c d"
(let ((out (open-output-string)))
(write-string "abc def" out 2 5)
(get-output-string out)))
;; --------------------------------------------------
(let ((p (open-output-bytevector)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment