buf: new buffer stream.

* buf.c (struct buf_strm): New struct type.
(buf_strm_mark, int buf_strm_put_byte_callback,
buf_strm_put_string, buf_strm_put_char, buf_strm_put_byte,
buf_strm_get_byte_callback, buf_strm_get_char,
buf_strm_get_byte, buf_strm_unget_char, buf_strm_unget_byte,
buf_strm_seek, buf_strm_truncate, buf_strm_get_prop,
buf_strm_set_prop, buf_strm_get_error,
buf_strm_get_error_str): New static functions.
(buf_strm_ops): New static struct.
(buf_strm): New static function.
(make_buf_stream, get_buf_from_stream): New functions.
(buf_init): Register new intrinsic functiions make-buf-stream
and get-buf-from-stream.
Call fill_stream_ops on new buf_strm_ops to fill
default operations in place of function pointers
that have been left null.

* buf.h (make_buf_stream, get_buf_from_stream): Declared.

* lisplib.c (with_stream_set_entries): Add with-out-buf-stream
and with-in-buf-stream to auto-load symbols for with-stream.tl
module.

* share/txr/stdlib/with-stream.tl (with-out-buf-stream,
with-in-buf-stream): New macros.

* txr.1: New section about buffer streams.

5 files changed, 397 insertions, 0 deletions

diff --git a/buf.c b/buf.c
index 6ed1e2b9..6d3f1a04 100644
--- a/buf.c
+++ b/buf.c
@@ -44,6 +44,7 @@
 #include "eval.h"
 #include "stream.h"
 #include "arith.h"
+#include "utf8.h"
 #include "buf.h"
 
 static cnum buf_check_len(val len, val self)
@@ -646,6 +647,263 @@ val buf_pprint(val buf, val stream_in)
   return t;
 }
 
+struct buf_strm {
+  struct strm_base a;
+  utf8_decoder_t ud;
+  int is_byte_oriented;
+  val buf;
+  val pos;
+  val unget_c;
+};
+
+static void buf_strm_mark(val stream)
+{
+  struct buf_strm *b = coerce(struct buf_strm *, stream->co.handle);
+  strm_base_mark(&b->a);
+  gc_mark(b->buf);
+  gc_mark(b->pos);
+  gc_mark(b->unget_c);
+}
+
+static int buf_strm_put_byte_callback(int b, mem_t *ctx)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, ctx);
+  (void) buf_put_uchar(s->buf, s->pos, num_fast(b));
+  s->pos = succ(s->pos);
+  return 1;
+}
+
+static val buf_strm_put_string(val stream, val str)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  const wchar_t *p = c_str(str);
+
+  while (*p) {
+    (void) utf8_encode(*p++, buf_strm_put_byte_callback, coerce(mem_t *, s));
+  }
+
+  return t;
+}
+
+static val buf_strm_put_char(val stream, val ch)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  (void) utf8_encode(c_chr(ch), buf_strm_put_byte_callback, coerce(mem_t *, s));
+  return t;
+}
+
+static val buf_strm_put_byte(val stream, int b)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  (void) buf_strm_put_byte_callback(b, coerce(mem_t *, s));
+  return t;
+}
+
+
+static int buf_strm_get_byte_callback(mem_t *ctx)
+{
+  val self = lit("get-byte");
+  struct buf_strm *s = coerce(struct buf_strm *, ctx);
+  struct buf *b = buf_handle(s->buf, self);
+  cnum p = buf_check_index(s->pos, self);
+  s->pos = num(p + 1);
+  return (p >= c_num(b->len)) ? EOF : b->data[p];
+}
+
+static val buf_strm_get_char(val stream)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+
+  if (s->unget_c) {
+    return rcyc_pop(&s->unget_c);
+  } else {
+    wint_t ch;
+
+    if (s->is_byte_oriented) {
+      ch = buf_strm_get_byte_callback(coerce(mem_t *, s));
+      if (ch == 0)
+        ch = 0xDC00;
+    } else {
+      ch = utf8_decode(&s->ud, buf_strm_get_byte_callback,
+                       coerce(mem_t *, s));
+    }
+
+    return (ch != WEOF) ? chr(ch) : nil;
+  }
+}
+
+static val buf_strm_get_byte(val stream)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  int byte = buf_strm_get_byte_callback(coerce(mem_t *, s));
+  return byte == EOF ? nil : num_fast(byte);
+}
+
+static val buf_strm_unget_char(val stream, val ch)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  mpush(ch, mkloc(s->unget_c, stream));
+  return ch;
+}
+
+static val buf_strm_unget_byte(val stream, int byte)
+{
+  val self = lit("unget-byte");
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  struct buf *b = buf_handle(s->buf, self);
+  cnum p = c_num(s->pos);
+
+  if (p <= 0) {
+    uw_throwf(file_error_s,
+              lit("~a: cannot push back past start of stream ~s"),
+              self, stream, nao);
+  }
+
+  b->data[--p] = byte;
+  s->pos = num(p);
+  return num_fast(byte);
+}
+
+static val buf_strm_seek(val stream, val offset, enum strm_whence whence)
+{
+  val self = lit("seek-stream");
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  val npos;
+
+  switch (whence) {
+  case strm_start:
+    npos = offset;
+    break;
+  case strm_cur:
+    if (offset == zero)
+      return s->pos;
+    npos = plus(s->pos, offset);
+    break;
+  case strm_end:
+    {
+      struct buf *b = buf_handle(s->buf, self);
+      npos = minus(b->len, offset);
+    }
+    break;
+  default:
+    internal_error("invalid whence value");
+  }
+
+  (void) buf_check_index(npos, self);
+
+  s->pos = npos;
+  return t;
+}
+
+static val buf_strm_truncate(val stream, val len)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  buf_set_length(s->buf, len, zero);
+  return t;
+}
+
+static val buf_strm_get_prop(val stream, val ind)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+
+  if (ind == name_k) {
+    return lit("buf-stream");
+  } else if (ind == byte_oriented_k) {
+    return tnil(s->is_byte_oriented);
+  }
+
+  return nil;
+}
+
+static val buf_strm_set_prop(val stream, val ind, val prop)
+{
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+
+  if (ind == byte_oriented_k) {
+    s->is_byte_oriented = prop ? 1 : 0;
+    return t;
+  }
+
+  return nil;
+}
+
+
+static val buf_strm_get_error(val stream)
+{
+  val self = lit("get-error");
+  struct buf_strm *s = coerce(struct buf_strm *, stream->co.handle);
+  struct buf *b = buf_handle(s->buf, self);
+  return ge(s->pos, b->len);
+}
+
+static val buf_strm_get_error_str(val stream)
+{
+  return errno_to_string(buf_strm_get_error(stream));
+}
+
+static struct strm_ops buf_strm_ops =
+  strm_ops_init(cobj_ops_init(eq,
+                              stream_print_op,
+                              stream_destroy_op,
+                              buf_strm_mark,
+                              cobj_eq_hash_op),
+                wli("buf-stream"),
+                buf_strm_put_string,
+                buf_strm_put_char,
+                buf_strm_put_byte,
+                generic_get_line,
+                buf_strm_get_char,
+                buf_strm_get_byte,
+                buf_strm_unget_char,
+                buf_strm_unget_byte,
+                0,
+                0,
+                0,
+                0,
+                buf_strm_seek,
+                buf_strm_truncate,
+                buf_strm_get_prop,
+                buf_strm_set_prop,
+                buf_strm_get_error,
+                buf_strm_get_error_str,
+                0,
+                0);
+
+static struct buf_strm *buf_strm(val stream, val self)
+{
+  struct buf_strm *s = coerce(struct buf_strm *,
+                              cobj_handle(stream, stream_s));
+
+  type_assert (stream->co.ops == &buf_strm_ops.cobj_ops,
+               (lit("~a: ~a is not a buffer stream"), self, stream, nao));
+  return s;
+}
+
+val make_buf_stream(val buf_opt)
+{
+  val stream;
+  val buf = default_arg(buf_opt, make_buf(zero, zero, num_fast(64)));
+  struct buf_strm *s = coerce(struct buf_strm *, chk_malloc(sizeof *s));
+
+  strm_base_init(&s->a);
+  utf8_decoder_init(&s->ud);
+  s->buf = nil;
+  s->pos = zero;
+  s->is_byte_oriented = 0;
+  s->unget_c = nil;
+  stream = cobj(coerce(mem_t *, s), stream_s, &buf_strm_ops.cobj_ops);
+  s->buf = buf;
+
+  return stream;
+}
+
+val get_buf_from_stream(val stream)
+{
+  val self = lit("get-buf-from-stream");
+  struct buf_strm *s = buf_strm(stream, self);
+  return s->buf;
+}
+
 void buf_init(void)
 {
   reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -717,4 +975,9 @@ void buf_init(void)
   reg_fun(intern(lit("buf-get-float"), user_package), func_n2(buf_get_float));
   reg_fun(intern(lit("buf-get-double"), user_package), func_n2(buf_get_double));
   reg_fun(intern(lit("buf-get-cptr"), user_package), func_n2(buf_get_cptr));
+
+  reg_fun(intern(lit("make-buf-stream"), user_package), func_n1o(make_buf_stream, 0));
+  reg_fun(intern(lit("get-buf-from-stream"), user_package), func_n1(get_buf_from_stream));
+
+  fill_stream_ops(&buf_strm_ops);
 }
diff --git a/buf.h b/buf.h
index f3ab4a7b..28978472 100644
--- a/buf.h
+++ b/buf.h
@@ -102,4 +102,7 @@ val buf_get_cptr(val buf, val pos);
 val buf_print(val buf, val stream);
 val buf_pprint(val buf, val stream);
 
+val make_buf_stream(val buf_opt);
+val get_buf_from_stream(val stream);
+
 void buf_init(void);
diff --git a/lisplib.c b/lisplib.c
index 67946714..588384df 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -209,8 +209,10 @@ static val with_stream_set_entries(val dlt, val fun)
   val name[] = {
     lit("with-out-string-stream"),
     lit("with-out-strlist-stream"),
+    lit("with-out-buf-stream"),
     lit("with-in-string-stream"),
     lit("with-in-string-byte-stream"),
+    lit("with-in-buf-stream"),
     lit("with-stream"),
     nil
   };
diff --git a/share/txr/stdlib/with-stream.tl b/share/txr/stdlib/with-stream.tl
index 40043237..a422a07c 100644
--- a/share/txr/stdlib/with-stream.tl
+++ b/share/txr/stdlib/with-stream.tl
@@ -34,6 +34,11 @@
      ,*body
      (get-list-from-stream ,stream)))
 
+(defmacro with-out-buf-stream ((stream : buf) . body)
+  ^(let ((,stream (make-buf-stream ,*[[iff have list] buf])))
+     ,*body
+     (get-buf-from-stream ,stream)))
+
 (defmacro with-in-string-stream ((stream string) . body)
   ^(let ((,stream (make-string-input-stream ,string)))
      ,*body))
@@ -42,6 +47,10 @@
   ^(let ((,stream (make-string-byte-input-stream ,string)))
      ,*body))
 
+(defmacro with-in-buf-stream ((stream buf) . body)
+  ^(let ((,stream (make-buf-stream ,buf)))
+     ,*body))
+
 (defmacro with-stream ((var stream) . body)
   ^(let ((,var ,stream))
      (unwind-protect
diff --git a/txr.1 b/txr.1
index d3ea01b9..ee6072f6 100644
--- a/txr.1
+++ b/txr.1
@@ -54697,6 +54697,126 @@ any bytes are read, then an exception is thrown.
 If an end-of-file condition occurs before any bytes are read, then zero
 is returned.
 
+.SS* Buffer streams
+A stream type exists which allows
+.code buf
+objects to be manipulated through the stream interface.
+A buffer stream is created using the
+.code make-buf-stream
+function, which can either attach the stream to an existing buffer,
+or create a new buffer that can later be retrieved from the stream
+using
+.codn get-buf-from-stream .
+
+Operations on the buffer stream treat the underlying buffer much like if it
+were a memory-based file. Unless the underlying buffer is a "borrowed buffer"
+referencing the storage belonging to another object
+(such as the buffer object produced by the
+.code buf-d
+FFI type's get semantics) the stream operations can change the buffer's size.
+Seeking beyond the end of the buffer an then writing one or more bytes
+extends the buffer's length, filling the newly allocated area with zero bytes.
+The
+.code truncate-stream
+function is supported also.
+Buffer streams also support the
+.code :byte-oriented
+property.
+
+Macros
+.code with-out-buf-stream
+and
+.code with-in-buf-stream
+are provided to simplify the steps involved in using buffer streams
+in some common scenarios. Note that in spite of the naming of these
+macros there is only one buffer stream type, which supports bidirectional I/O.
+
+.coNP Function @ make-buf-stream
+.synb
+.mets (make-buf-stream <> [ buf ])
+.syne
+.desc
+The
+.code make-buf-stream
+function return a new buffer stream. If the
+.meta buf
+argument is supplied, it must be a
+.code buf
+object. The stream is then associated with this object.
+If the argument is omitted, a buffer of length zero is created and associated
+with the stream.
+
+.coNP Function @ get-buf-from-stream
+.synb
+.mets (get-buf-from-stream << buf-stream )
+.syne
+.desc
+The
+.code get-buf-from-stream
+returns the buffer object associated with
+.meta buf-stream
+which must be a buffer stream.
+
+.coNP Macros @ with-out-buf-stream and @ with-in-buf-stream
+.synb
+.mets (with-out-buf-stream >> ( var <> [ buf-expr ])
+.mets \ \  << body-form *)
+.mets (with-in-buf-stream >> ( var << buf-expr )
+.mets \ \  << body-form *)
+.syne
+.desc
+The
+.code with-out-buf-stream
+and
+.code with-in-buf-stream
+macros both bind variable
+.meta var
+to an implicitly created buffer stream, and evaluate zero or more
+.metn body-form -s
+in the environment where the variable is visible.
+
+The
+.meta buf-expr
+argument, which may be omitted in the use of the
+.code with-out-buf-stream
+macro, must be an expression which evaluates to a
+.code buf
+object.
+
+The
+.meta var
+argument must be a symbol suitable for naming a variable.
+
+The implicitly allocated buffer stream is connected
+to the buffer specified by
+.meta buf-expr
+or, when
+.meta buf-expr
+is omitted, to a newly allocated buffer.
+
+The code generated by the
+.code with-out-buf-stream
+macro, if it terminates normally, yields the buffer object
+as its result value.
+
+The
+.code with-in-buf-stream
+returns the value of the last
+.metn body-form ,
+or else
+.code nil
+if no forms are specified.
+
+.TP* Examples:
+.cblk
+  (with-out-buf-stream (*stdout* (make-buf 24))
+    (put-string "Hello, world!"))
+  -> #b'48656c6c6f2c2077 6f726c6421000000 0000000000000000'
+
+  (with-out-buf-stream (*stdout*) (put-string "Hello, world!"))
+  -> #b'48656c6c6f2c2077 6f726c6421'
+.cble
+
 .coSS The @ cptr type
 
 Objects of type