Implementing truncate-stream.

* configure: Test for ftruncate and chsize.

* stream.c (unimpl_truncate): New static function.
(fill_stream_ops): Default the truncate operation to unimpl_truncate.
(null_ops): Initialize truncate to unimpl_truncate.
(stdio_truncate): New static function.
(stdio_ops, tail_ops): Initialize truncate to stdio_truncate.
(pipe_ops, dir_ops, string_ops, byte_in_ops, string_out_ops,
strlist_out_ops, cat_stream_ops): Initialize truncate to null,
so it gets defaulted by fill_stream_ops.
(truncate_stream): New function.
(stream_init): Register truncate-stream intrinsic.

* stream.h (struct strm_ops): New member, truncate.
(strm_ops_init): New truncate argument added to macro.
(truncate_stream): Declared.

*syslog.c (syslog_strm_ops): Initialize truncate to null.

* txr.1: Documented.

5 files changed, 104 insertions, 10 deletions

diff --git a/configure b/configure
index 09054bdf..0760afe7 100755
--- a/configure
+++ b/configure
@@ -1953,6 +1953,22 @@ else
   printf "no\n"
 fi
 
+printf "Checking for ftruncate ... "
+cat > conftest.c <<!
+#include <unistd.h>
+
+int main(void)
+{
+  int e = ftruncate(0, 42);
+  return 0;
+}
+!
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_FTRUNCATE 1\n" >> $config_h
+else
+  printf "no\n"
+fi
 
 printf "Checking for _wspawnlp ... "
 
@@ -1975,6 +1991,24 @@ else
   printf "no\n"
 fi
 
+printf "Checking for chsize ... "
+cat > conftest.c <<!
+#include <unistd.h>
+
+int main(void)
+{
+  int e = chsize(0, 42);
+  return 0;
+}
+!
+if conftest ; then
+  printf "yes\n"
+  printf "#define HAVE_CHSIZE 1\n" >> $config_h
+else
+  printf "no\n"
+fi
+
+
 printf "Checking for log2 ... "
 
 cat > conftest.c <<!
diff --git a/stream.c b/stream.c
index 8b2999c6..024591e4 100644
--- a/stream.c
+++ b/stream.c
@@ -156,6 +156,11 @@ static noreturn val unimpl_seek(val stream, cnum off, enum strm_whence whence)
   unimpl(stream, lit("seek-stream"));
 }
 
+static noreturn val unimpl_truncate(val stream, val len)
+{
+  unimpl(stream, lit("truncate-stream"));
+}
+
 static val null_put_string(val stream, val str)
 {
   return nil;
@@ -255,6 +260,8 @@ void fill_stream_ops(struct strm_ops *ops)
     ops->flush = null_flush;
   if (!ops->seek)
     ops->seek = unimpl_seek;
+  if (!ops->truncate)
+    ops->truncate = unimpl_truncate;
   if (!ops->get_prop)
     ops->get_prop = null_get_prop;
   if (!ops->set_prop)
@@ -277,9 +284,9 @@ static struct strm_ops null_ops =
                 null_put_string, null_put_char, null_put_byte, null_get_line,
                 null_get_char, null_get_byte,
                 unimpl_unget_char, unimpl_unget_byte,
-                null_close, null_flush, null_seek, null_get_prop,
-                null_set_prop, null_get_error, null_get_error_str,
-                null_clear_error);
+                null_close, null_flush, null_seek, unimpl_truncate,
+                null_get_prop, null_set_prop,
+                null_get_error, null_get_error_str, null_clear_error);
 
 val make_null_stream(void)
 {
@@ -655,6 +662,30 @@ static val stdio_close(val stream, val throw_on_error)
   return nil;
 }
 
+#if HAVE_FTRUNCATE || HAVE_CHSIZE
+static val stdio_truncate(val stream, val len)
+{
+  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
+  cnum l = c_num(len);
+#if HAVE_FTRUNCATE
+  typedef off_t trunc_off_t;
+  int (*truncfun)(int, off_t) = ftruncate;
+#else
+  typedef long trunc_off_t;
+  int (*truncfun)(int, long) = chsize;
+#endif
+
+  if ((cnum) (trunc_off_t) l != l)
+    uw_throwf(error_s, lit("truncate-stream: ~s is too large"), len, nao);
+
+  return (h->f != 0 && truncfun(fileno(h->f), l) == 0)
+         ? t
+         : stdio_maybe_error(stream, lit("truncating"));
+}
+#else
+#define stdio_truncate unimpl_truncate
+#endif
+
 static struct strm_ops stdio_ops =
   strm_ops_init(cobj_ops_init(eq,
                               stdio_stream_print,
@@ -673,6 +704,7 @@ static struct strm_ops stdio_ops =
                 stdio_close,
                 stdio_flush,
                 stdio_seek,
+                stdio_truncate,
                 stdio_get_prop,
                 stdio_set_prop,
                 stdio_get_error,
@@ -855,6 +887,7 @@ static struct strm_ops tail_ops =
                 stdio_close,
                 stdio_flush,
                 stdio_seek,
+                stdio_truncate,
                 stdio_get_prop,
                 stdio_set_prop,
                 stdio_get_error,
@@ -948,6 +981,7 @@ static struct strm_ops pipe_ops =
                 pipe_close,
                 stdio_flush,
                 0, /* seek: not on pipes */
+                0, /* truncate: not on pipes */
                 stdio_get_prop,
                 stdio_set_prop,
                 stdio_get_error,
@@ -1203,7 +1237,7 @@ static struct strm_ops dir_ops =
                 dir_get_line,
                 0, 0, 0, 0,
                 dir_close,
-                0, 0, 0, 0,
+                0, 0, 0, 0, 0,
                 dir_get_error,
                 dir_get_error_str,
                 dir_clear_error);
@@ -1323,6 +1357,7 @@ static struct strm_ops string_in_ops =
                 string_in_unget_char,
                 0, 0, 0,
                 0, /* TODO: seek */
+                0, /* TODO: truncate */
                 string_in_get_prop,
                 0,
                 string_in_get_error,
@@ -1398,7 +1433,7 @@ static struct strm_ops byte_in_ops =
                 byte_in_get_byte,
                 0,
                 byte_in_unget_byte,
-                0, 0, 0, 0, 0,
+                0, 0, 0, 0, 0, 0,
                 byte_in_get_error,
                 byte_in_get_error_str,
                 0);
@@ -1540,6 +1575,7 @@ static struct strm_ops string_out_ops =
                 string_out_put_byte,
                 0, 0, 0, 0, 0, 0, 0,
                 0, /* TODO: seek; fill-with-spaces semantics if past end. */
+                0,
                 0, 0, 0, 0, 0);
 
 val make_string_output_stream(void)
@@ -1657,7 +1693,7 @@ static struct strm_ops strlist_out_ops =
                 wli("strlist-output-stream"),
                 strlist_out_put_string,
                 strlist_out_put_char,
-                0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+                0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 
 val make_strlist_output_stream(void)
 {
@@ -1839,7 +1875,7 @@ static struct strm_ops cat_stream_ops =
                 cat_get_byte,
                 cat_unget_char,
                 cat_unget_byte,
-                0, 0, 0,
+                0, 0, 0, 0,
                 cat_get_prop,
                 0,
                 cat_get_error,
@@ -2697,6 +2733,12 @@ val seek_stream(val stream, val offset, val whence)
   return ops->seek(stream, off, w);
 }
 
+val truncate_stream(val stream, val len)
+{
+  struct strm_ops *ops = coerce(struct strm_ops *, cobj_ops(stream, stream_s));
+  return ops->truncate(stream, len);
+}
+
 val get_indent_mode(val stream)
 {
   struct strm_base *s = coerce(struct strm_base *,
@@ -3259,6 +3301,7 @@ void stream_init(void)
   reg_fun(intern(lit("unget-byte"), user_package), func_n2o(unget_byte, 1));
   reg_fun(intern(lit("flush-stream"), user_package), func_n1(flush_stream));
   reg_fun(intern(lit("seek-stream"), user_package), func_n3(seek_stream));
+  reg_fun(intern(lit("truncate-stream"), user_package), func_n2(truncate_stream));
   reg_fun(intern(lit("streamp"), user_package), func_n1(streamp));
   reg_fun(intern(lit("real-time-stream-p"), user_package), func_n1(real_time_stream_p));
   reg_fun(intern(lit("stream-set-prop"), user_package), func_n3(stream_set_prop));
diff --git a/stream.h b/stream.h
index e5d58d26..d3ec649a 100644
--- a/stream.h
+++ b/stream.h
@@ -58,6 +58,7 @@ struct strm_ops {
   val (*close)(val, val);
   val (*flush)(val);
   val (*seek)(val, cnum, enum strm_whence);
+  val (*truncate)(val, val);
   val (*get_prop)(val, val ind);
   val (*set_prop)(val, val ind, val);
   val (*get_error)(val);
@@ -67,12 +68,12 @@ struct strm_ops {
 
 #define strm_ops_init(cobj_init_macro, name, put_string, put_char, put_byte, \
                       get_line, get_char, get_byte, unget_char, unget_byte,  \
-                      close, flush, seek, get_prop, set_prop,                \
+                      close, flush, seek, truncate, get_prop, set_prop,      \
                       get_error, get_error_str, clear_error)                 \
 {                                                                            \
     cobj_init_macro, name, put_string, put_char, put_byte, get_line,         \
     get_char, get_byte, unget_char, unget_byte,                              \
-    close, flush, seek, get_prop, set_prop,                                  \
+    close, flush, seek, truncate, get_prop, set_prop,                        \
     get_error, get_error_str, clear_error                                    \
 }
 
@@ -132,6 +133,7 @@ val put_strings(val strings, val stream);
 val put_lines(val lines, val stream);
 val flush_stream(val stream);
 val seek_stream(val stream, val offset, val whence);
+val truncate_stream(val stream, val len);
 val get_indent_mode(val stream);
 val test_set_indent_mode(val stream, val compare, val mode);
 val set_indent_mode(val stream, val mode);
diff --git a/syslog.c b/syslog.c
index 8c7b81ef..aa3539c3 100644
--- a/syslog.c
+++ b/syslog.c
@@ -231,7 +231,7 @@ static_def(struct strm_ops syslog_strm_ops =
                 syslog_put_string,
                 syslog_put_char,
                 syslog_put_byte,
-                0, 0, 0, 0, 0, 0, 0, 0,
+                0, 0, 0, 0, 0, 0, 0, 0, 0,
                 syslog_get_prop,
                 syslog_set_prop,
                 0, 0, 0))
diff --git a/txr.1 b/txr.1
index 32577e58..899b3c69 100644
--- a/txr.1
+++ b/txr.1
@@ -31010,6 +31010,21 @@ and the previous position wasn't zero, then the position is decremented by one.
 On failure, it throws an exception of type
 .codn stream-error .
 
+.coNP Function @ truncate-stream
+.synb
+.mets (truncate-stream < stream << length )
+.syne
+.desc
+The
+.code truncate-stream
+causes the length of the underlying file associated with
+.meta stream
+to be set to
+.meta length
+bytes.
+
+The stream must be a file stream, and must be open for writing.
+
 .coNP Functions @ stream-get-prop and @ stream-set-prop
 .synb
 .mets (stream-get-prop < stream << indicator )