Support max length and depth for object printing.

* hash.c (hash_print_op): Implement max length.

* lib.c (lazy_str_put, out_lazy_str): Take struct strm_base *
parameter and implement max length.
(out_quasi_str_sym): Don't use obj_print_impl for symbol's
name string; just put_string. The use of obj_print_impl causes
symbols appearing as variables in quasiliterals to be
truncated when max length is imposed.
(out_quasi_str): Implement max length.
(obj_print_impl): Implement max length and depth. Note that
there is now always a non-null ctx pointer.
(obj_print): Always set up context pointer for obj_print_impl.
Context now has pointer to low-level stream structure, where
we can access max_length and max_depth. It also carries the
recursion depth.

* lib.h (lazy_str_put): Declaration updated.

* stream.c (strm_base_init): Add initializers for max_length
and max_depth.
(put_string): Pass stream structure to lazy_str_put.
(set_max_length, set_max_depth): New functions.
(stream_init): set-max-length and set-max-depth intrinsics
registered.

* stream.h (struct strm_ctx): New members depth and strm.
(struct strm_base): New members max_length and max_depth.
(set_max_length, set_max_depth): Declared.

* txr.1: Documented.

6 files changed, 356 insertions, 36 deletions

diff --git a/hash.c b/hash.c
index 2bf527b9..1aaaa375 100644
--- a/hash.c
+++ b/hash.c
@@ -494,12 +494,20 @@ static void hash_print_op(val hash, val out, val pretty, struct strm_ctx *ctx)
   put_string(lit(")"), out);
   {
     val iter = hash_begin(hash), cell;
+    cnum max_len = ctx->strm->max_length;
+    cnum max_count = max_len;
+
     while ((cell = hash_next(iter))) {
       val key = us_car(cell);
       val value = us_cdr(cell);
       if (width_check(out, chr(' ')))
         force_br = 1;
 
+      if (max_len && --max_count < 0) {
+        put_string(lit("..."), out);
+        break;
+      }
+
       put_string(lit("("), out);
       obj_print_impl(key, out, pretty, ctx);
 
diff --git a/lib.c b/lib.c
index 6108f0ff..14b4348d 100644
--- a/lib.c
+++ b/lib.c
@@ -7492,11 +7492,13 @@ val lazy_str_force(val lstr)
   return lstr->ls.prefix;
 }
 
-val lazy_str_put(val lstr, val stream)
+val lazy_str_put(val lstr, val stream, struct strm_base *s)
 {
-  val lim, term, iter;
-  lim = lstr->ls.props->limit;
-  term = lstr->ls.props->term;
+  val lim = lstr->ls.props->limit;
+  val term = lstr->ls.props->term;
+  val iter;
+  cnum max_len = s->max_length;
+  cnum max_chr = if3(max_len, max(max_len, 15), 0);
 
   put_string(lstr->ls.prefix, stream);
 
@@ -7506,6 +7508,15 @@ val lazy_str_put(val lstr, val stream)
     val str = car(iter);
     if (!str)
       break;
+    if (max_len) {
+      if (length_str_gt(str, num(max_chr))) {
+        put_string(sub_str(str, zero, num(max_chr)), stream);
+        goto max_reached;
+      }
+      if (--max_len == 0)
+        goto max_reached;
+      max_chr -= c_num(length_str(str));
+    }
     if (lim)
       lim = pred(lim);
     put_string(str, stream);
@@ -7513,6 +7524,11 @@ val lazy_str_put(val lstr, val stream)
   }
 
   return t;
+
+max_reached:
+  put_string(lit("..."), stream);
+  put_string(term, stream);
+  return t;
 }
 
 val lazy_str_force_upto(val lstr, val index)
@@ -10901,14 +10917,16 @@ static void out_str_readable(const wchar_t *ptr, val out, int *semi_flag)
     out_str_char(*ptr, out, semi_flag, 0);
 }
 
-static void out_lazy_str(val lstr, val out)
+static void out_lazy_str(val lstr, val out, struct strm_base *strm)
 {
   int semi_flag = 0;
-  val lim, term, iter;
+  val lim = lstr->ls.props->limit;
+  val term = lstr->ls.props->term;
+  val iter;
   const wchar_t *wcterm;
+  cnum max_len = strm->max_length;
+  cnum max_chr = if3(max_len, max(max_len, 15), 0);
 
-  lim = lstr->ls.props->limit;
-  term = lstr->ls.props->term;
   wcterm = c_str(term);
 
   put_char(chr('"'), out);
@@ -10921,12 +10939,25 @@ static void out_lazy_str(val lstr, val out)
     val str = car(iter);
     if (!str)
       break;
+    if (max_len) {
+      if (length_str_gt(str, num(max_chr))) {
+        out_str_readable(c_str(sub_str(str, zero, num(max_chr))), out, &semi_flag);
+        goto max_reached;
+      }
+      if (--max_len == 0)
+        goto max_reached;
+      max_chr -= c_num(length_str(str));
+    }
     out_str_readable(c_str(str), out, &semi_flag);
     out_str_readable(wcterm, out, &semi_flag);
     if (lim)
       lim = pred(lim);
   }
 
+  if (0) {
+max_reached:
+    put_string(lit("\\..."), out);
+  }
   put_char(chr('"'), out);
 }
 
@@ -10951,7 +10982,7 @@ static void out_quasi_str_sym(val name, val mods, val rem_args,
   put_char(chr('@'), out);
   if (need_brace)
     put_char(chr('{'), out);
-  obj_print_impl(namestr, out, t, ctx);
+  put_string(namestr, out);
   while (mods) {
     put_char(chr(' '), out);
     obj_print_impl(car(mods), out, nil, ctx);
@@ -10964,6 +10995,10 @@ static void out_quasi_str_sym(val name, val mods, val rem_args,
 static void out_quasi_str(val args, val out, struct strm_ctx *ctx)
 {
   val iter, next;
+  cnum max_len = ctx->strm->max_length, max_count = max_len;
+
+  if (max_len)
+    max_len = max(15, max_len);
 
   for (iter = cdr(args); iter; iter = next) {
     val elem = car(iter);
@@ -10971,7 +11006,18 @@ static void out_quasi_str(val args, val out, struct strm_ctx *ctx)
 
     if (stringp(elem)) {
       int semi_flag = 0;
-      out_str_readable(c_str(elem), out, &semi_flag);
+      if (max_len && length_str_gt(elem, num(max_len))) {
+        out_str_readable(c_str(sub_str(elem, zero, num(max_len))), out, &semi_flag);
+        goto max_exceeded;
+      } else {
+        out_str_readable(c_str(elem), out, &semi_flag);
+        if (max_len) {
+          max_len -= c_num(length(elem));
+          if (max_len == 0) {
+            goto max_reached;
+          }
+        }
+      }
     } else if (consp(elem)) {
       val sym = car(elem);
       if (sym == var_s)
@@ -10987,7 +11033,17 @@ static void out_quasi_str(val args, val out, struct strm_ctx *ctx)
     } else {
       obj_print_impl(elem, out, nil, ctx);
     }
+
+    if (--max_count == 0)
+      goto max_reached;
   }
+
+  return;
+
+max_reached:
+  if (next)
+max_exceeded:
+    put_string(lit("\\..."), out);
 }
 
 INLINE int circle_print_eligible(val obj)
@@ -11008,8 +11064,9 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
 {
   val self = lit("print");
   val ret = obj;
+  cnum save_depth = ctx->depth;
 
-  if (ctx && circle_print_eligible(obj)) {
+  if (ctx->obj_hash && circle_print_eligible(obj)) {
     loc pcdr = gethash_l(self, ctx->obj_hash, obj, nulloc);
     val label = deref(pcdr);
 
@@ -11026,6 +11083,37 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
     }
   }
 
+  if (ctx->strm->max_depth) {
+    if (ctx->depth > ctx->strm->max_depth) {
+      put_string(lit("..."), out);
+      return obj;
+    }
+
+    if (ctx->depth == ctx->strm->max_depth) {
+      switch (type(obj)) {
+      case CONS:
+      case LCONS:
+        put_string(lit("(...)"), out);
+        return obj;
+      case VEC:
+        put_string(lit("#(...)"), out);
+        return obj;
+      case COBJ:
+        if (hashp(obj)) {
+          put_string(lit("#H(...)"), out);
+          return obj;
+        } else if (structp(obj)) {
+          put_string(lit("#S(...)"), out);
+          return obj;
+        }
+      default:
+        break;
+      }
+    }
+
+    ctx->depth++;
+  }
+
   switch (type(obj)) {
   case NIL:
     put_string(if3(get_indent_mode(out) == num_fast(indent_code),
@@ -11095,6 +11183,7 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
         out_quasi_str(obj, out, ctx);
         put_char(chr('`'), out);
       } else if (sym == quasilist_s && consp(cdr(obj))) {
+        cnum max_length = ctx->strm->max_length;
         val args = cdr(obj);
         put_string(lit("#`"), out);
         if (args) {
@@ -11103,6 +11192,10 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
         }
         while (args) {
           put_char(chr(' '), out);
+          if (max_length && --max_length == 0) {
+            put_string(lit("..."), out);
+            break;
+          }
           out_quasi_str(car(args), out, ctx);
           args = cdr(args);
         }
@@ -11112,6 +11205,8 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
         val closepar = chr(')');
         val indent = zero;
         int force_br = 0;
+        cnum max_len = ctx->strm->max_length;
+        cnum max_count = max_len;
 
         if (sym == dwim_s && consp(cdr(obj))) {
           put_char(chr('['), out);
@@ -11174,13 +11269,18 @@ val obj_print_impl(val obj, val out, val pretty, struct strm_ctx *ctx)
               }
             }
 
-            obj_print_impl(a, out, pretty, ctx);
+            if (max_len && --max_count < 0) {
+              put_string(lit("..."), out);
+              iter = nil;
+            } else {
+              obj_print_impl(a, out, pretty, ctx);
+            }
           }
 finish:
           d = cdr(iter);
           if (nilp(d)) {
             put_char(closepar, out);
-          } else if (ctx && gethash(ctx->obj_hash, d)) {
+          } else if (ctx->obj_hash && gethash(ctx->obj_hash, d)) {
             iter = nil;
             goto dot;
           } else if (consp(d)) {
@@ -11205,15 +11305,31 @@ dot:
     }
   case LIT:
   case STR:
-    if (pretty) {
-      put_string(obj, out);
-    } else {
-      int semi_flag = 0;
-      put_char(chr('"'), out);
+    {
+      cnum max_length = ctx->strm->max_length;
+      cnum eff_max_length = max(15, max_length);
 
-      out_str_readable(c_str(obj), out, &semi_flag);
+      if (pretty) {
+        if (!max_length || le(length_str(obj), num(eff_max_length))) {
+          put_string(obj, out);
+        } else {
+          put_string(sub_str(obj, zero, num(eff_max_length)), out);
+          put_string(lit("..."), out);
+        }
+      } else {
+        int semi_flag = 0;
+        put_char(chr('"'), out);
 
-      put_char(chr('"'), out);
+        if (!max_length || le(length_str(obj), num(eff_max_length))) {
+          out_str_readable(c_str(obj), out, &semi_flag);
+        } else {
+          out_str_readable(c_str(sub_str(obj, zero, num(eff_max_length))),
+                           out, &semi_flag);
+          put_string(lit("\\..."), out);
+        }
+
+        put_char(chr('"'), out);
+      }
     }
     break;
   case CHR:
@@ -11305,6 +11421,7 @@ dot:
   case VEC:
     {
       cnum i, length = c_num(obj->v.vec[vec_length]);
+      cnum max_length = ctx->strm->max_length;
       val save_mode = test_set_indent_mode(out, num_fast(indent_off),
                                            num_fast(indent_data));
       val save_indent;
@@ -11316,6 +11433,10 @@ dot:
 
       for (i = 0; i < length; i++) {
         val elem = obj->v.vec[i];
+        if (max_length && i >= max_length) {
+          put_string(lit("..."), out);
+          break;
+        }
         obj_print_impl(elem, out, pretty, ctx);
         if (i < length - 1)
           if (width_check(out, chr(' ')))
@@ -11333,9 +11454,9 @@ dot:
     break;
   case LSTR:
     if (pretty) {
-      lazy_str_put(obj, out);
+      lazy_str_put(obj, out, ctx->strm);
     } else {
-      out_lazy_str(obj, out);
+      out_lazy_str(obj, out, ctx->strm);
     }
     break;
   case COBJ:
@@ -11360,6 +11481,9 @@ dot:
     break;
   }
 
+  if (ctx->depth != save_depth)
+    ctx->depth = save_depth;
+
   return ret;
 }
 
@@ -11466,6 +11590,7 @@ static void obj_hash_merge(val parent_hash, val child_hash)
 
 val obj_print(val obj, val out, val pretty)
 {
+  val self = lit("print");
   val ret = nil;
   val save_mode = get_indent_mode(out);
   val save_indent = get_indent(out);
@@ -11486,18 +11611,21 @@ val obj_print(val obj, val out, val pretty)
       obj_hash_merge(ctx->obj_hash_prev, ctx->obj_hash);
       ctx->obj_hash = ctx->obj_hash_prev;
       ctx->obj_hash_prev = nil;
-    } else {
-      ctx = 0;
     }
   } else {
-    if (print_circle_s && cdr(lookup_var(nil, print_circle_s))) {
-      ctx = &ctx_struct;
-      ctx->obj_hash = make_hash(nil, nil, nil);
-      ctx->obj_hash_prev = nil;
-      ctx->counter = zero;
-      get_set_ctx(out, ctx);
+    struct strm_base *s = coerce(struct strm_base *,
+                                 cobj_handle(self, out, stream_s));
+    ctx = &ctx_struct;
+    ctx->strm = s;
+    ctx->counter = zero;
+    ctx->obj_hash_prev = nil;
+    ctx->obj_hash = if2(print_circle_s &&
+                        cdr(lookup_var(nil, print_circle_s)),
+                        make_hash(nil, nil, nil));
+    ctx->depth = 0;
+    get_set_ctx(out, ctx);
+    if (ctx->obj_hash)
       populate_obj_hash(obj, ctx);
-    }
   }
 
   ret = obj_print_impl(obj, out, pretty, ctx);
diff --git a/lib.h b/lib.h
index 8ff88b76..624c24fa 100644
--- a/lib.h
+++ b/lib.h
@@ -1006,7 +1006,8 @@ val lazy_stream_cons(val stream);
 val lazy_str(val list, val term, val limit);
 val lazy_str_force_upto(val lstr, val index);
 val lazy_str_force(val lstr);
-val lazy_str_put(val lstr, val stream);
+struct strm_base;
+val lazy_str_put(val lstr, val stream, struct strm_base *);
 val lazy_str_get_trailing_list(val lstr, val index);
 val length_str_gt(val str, val len);
 val length_str_ge(val str, val len);
diff --git a/stream.c b/stream.c
index 3faa57c4..1289af9a 100644
--- a/stream.c
+++ b/stream.c
@@ -102,7 +102,7 @@ val shell, shell_arg;
 
 void strm_base_init(struct strm_base *s)
 {
-  static struct strm_base init = { indent_off, 60, 10, 0, 0, 0, 0 };
+  static struct strm_base init = { indent_off, 60, 10, 0, 0, 0, 0, 0, 0 };
   *s = init;
 }
 
@@ -3547,13 +3547,14 @@ static val put_indent(val stream, struct strm_ops *ops, cnum chars)
 val put_string(val string, val stream_in)
 {
   val self = lit("put-string");
+  val stream = default_arg(stream_in, std_output);
+  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
+
   if (lazy_stringp(string)) {
-    return lazy_str_put(string, stream_in);
+    return lazy_str_put(string, stream_in, s);
   } else {
-    val stream = default_arg(stream_in, std_output);
     struct strm_ops *ops = coerce(struct strm_ops *,
                                   cobj_ops(self, stream, stream_s));
-    struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
     cnum col = s->column;
 
     const wchar_t *str = c_str(string), *p = str;
@@ -3810,6 +3811,26 @@ val force_break(val stream)
   return stream;
 }
 
+val set_max_length(val stream, val length)
+{
+  val self = lit("set-max-length");
+  struct strm_base *s = coerce(struct strm_base *,
+                               cobj_handle(self, stream, stream_s));
+  cnum old_max = s->max_length;
+  s->max_length = c_num(length);
+  return num(old_max);
+}
+
+val set_max_depth(val stream, val depth)
+{
+  val self = lit("set-max-depth");
+  struct strm_base *s = coerce(struct strm_base *,
+                               cobj_handle(self, stream, stream_s));
+  cnum old_max = s->max_depth;
+  s->max_depth = c_num(depth);
+  return num(old_max);
+}
+
 struct strm_ctx *get_set_ctx(val stream, struct strm_ctx *ctx)
 {
   struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
@@ -4702,6 +4723,8 @@ void stream_init(void)
   reg_fun(intern(lit("inc-indent"), user_package), func_n2(inc_indent));
   reg_fun(intern(lit("width-check"), user_package), func_n2(width_check));
   reg_fun(intern(lit("force-break"), user_package), func_n1(force_break));
+  reg_fun(intern(lit("set-max-length"), user_package), func_n2(set_max_length));
+  reg_fun(intern(lit("set-max-depth"), user_package), func_n2(set_max_depth));
   reg_varl(intern(lit("indent-off"), user_package), num_fast(indent_off));
   reg_varl(intern(lit("indent-data"), user_package), num_fast(indent_data));
   reg_varl(intern(lit("indent-code"), user_package), num_fast(indent_code));
diff --git a/stream.h b/stream.h
index a7895064..cba0330a 100644
--- a/stream.h
+++ b/stream.h
@@ -42,6 +42,8 @@ struct strm_ctx {
   val obj_hash;
   val obj_hash_prev;
   val counter;
+  cnum depth;
+  struct strm_base *strm;
 };
 
 struct strm_base {
@@ -51,6 +53,8 @@ struct strm_base {
   cnum indent_chars;
   cnum column;
   unsigned force_break;
+  cnum max_length;
+  cnum max_depth;
   struct strm_ctx *ctx;
 };
 
@@ -213,6 +217,8 @@ val set_indent(val stream, val indent);
 val inc_indent(val stream, val delta);
 val width_check(val stream, val alt);
 val force_break(val stream);
+val set_max_length(val stream, val length);
+val set_max_depth(val stream, val depth);
 struct strm_ctx *get_set_ctx(val stream, struct strm_ctx *);
 struct strm_ctx *get_ctx(val stream);
 val get_string(val stream, val nchars, val close_after_p);
diff --git a/txr.1 b/txr.1
index 51ded597..031837c2 100644
--- a/txr.1
+++ b/txr.1
@@ -47207,6 +47207,160 @@ and
 in the same way so that application-defined output integrates
 with the formatting algorithm.
 
+.SS* Stream Output Limitation
+
+Streams have two properties which are used by the The \*(TL object printer to
+optionally truncate the output generated by aggregate objects.
+
+A stream can specify a maximum length for aggregate objects via the
+.code set-max-length
+function. Using the
+.code set-max-depth
+function, the maximum depth can also be specified.
+
+This feature is
+useful when diagnostic output is being produced, and the objects involved are
+so large that the diagnostic output overwhelms the output device or the user,
+so as to become uninformative. Output limiting also prevents the printer's
+non-termination on infinite, lazy structures.
+
+It is recommended that functions which operate on streams passed in as
+parameters save and restore these parameters, if they need to manipulate them,
+for instance using
+.codn with-resources :
+
+.verb
+  (defun output-function (arg stream)
+    ;; temporarily impose maximum width and depth
+    (with-resources ((ml (set-max-length stream 42)
+                         (set-max-length stream ml))
+                     (mw (set-max-depth stream 12)
+                         (set-max-depth stream mw)))
+      (prinl arg stream)
+      ...))
+.brev
+
+.coNP Function @ set-max-length
+.synb
+.mets (set-max-length < stream << value )
+.syne
+.desc
+The
+.code set-max-length
+function establishes the maximum length for aggregate object printing.
+It affects the printing of lists, vectors, hash tables, strings
+as well as quasiliterals and quasiword list literals (QLLs).
+
+The default value is 0 and this value means that no limit is imposed.
+Otherwise, the value must be a positive integer.
+
+When the list, vector or hash table object being printed has more
+elements than the maximum length, then elements are printed only up to
+the maximum count, and then the remaining elements are summarized by
+printing the
+.code ...
+(three dots) character sequence as if it were an additional element.
+This sequence is an invalid token; it cannot be read as input.
+
+When a character string is printed, any positive value of
+the maximum length which is less than 15 is considered to be 15.
+The maximum length specifies the number of characters of the
+a string which are output.
+
+If a string which exceeds the maximum length is being printed
+with read-print consistency, as by the
+.code print
+function, then only a prefix of the string is printed, limited
+to the maximum number of characters.  Then, the literal syntax is
+closed using the character sequence
+.code \e...\(dq
+(backslash, dot, dot, dot, double quote)
+whose leading invalid escape sequence
+.code \e.
+(backslash, dot) ensures that the truncated object is not readable.
+
+If a string which exceeds the maximum length is being printed
+without read-print consistency, as by the
+.code pprint
+function, then only a prefix of the string is printed, limited
+to the maximum number of characters. Then the
+character sequence
+.code ...
+is emitted.
+
+Quasiliterals are treated using a combination of behaviors.  Elements of a
+quasiliteral are literal sequence of text, and embedded variables and
+expressions.  The maximum length specifies both the maximum number of elements
+in the quasiliteral, and the maximum number of characters in any element which
+is a sequence of text. When either limit is exceeded, the quasiliteral
+is immediately terminated with the sequence
+.code \e...`
+(escaped dot, dot, dot, backtick). The maximum limit is applied to
+the units of text cumulatively, rather than individually. As in the case of
+string literals, smaller limit values than 15 are treated as 15,
+but only for the cumulative text length limit. For limiting the number of
+elements, the count is used as-is.
+
+When a QLL is printed, the space-separated elements
+of the literal are individually subject to the maximum length limit as if
+they were independent quasiliterals. Furthermore, the sequence of these
+elements is subject to the maximum length. If there are more elements in the
+QLL, then the sequence
+.code \e...`
+(escaped dot, dot, dot, backtick) is emitted and thus the QLL ends.
+
+The
+.code set-max-length
+function returns the previous value.
+
+.coNP Function @ set-max-depth
+.synb
+.mets (set-max-depth < stream << value )
+.syne
+.desc
+The
+.code set-max-length
+function establishes the maximum depth for the printing of nested
+objects. It affects the printing of lists, vectors, hash tables
+and structures.  The default value is 0 and this value means that no limit is
+imposed.  Otherwise, the value must be a positive integer.
+
+The depth of an object not enclosed in any object is zero. The depth of the
+element of an aggregate is one greater than the depth of the aggregate itself.
+For instance, given the list
+.code "(1 (2 3))"
+the list itself has depth 0, the atom
+.code 1
+has depth 1, as does the sublist
+.codn "(2 3)" ,
+and the
+.code 2
+and
+.code 3
+atoms have depth 2.
+
+When an object is printed whose depth exceeds the maximum depth, then three dot
+character sequence
+.code ...
+is printed instead of that object. This notation is an invalid token; it cannot be
+read as input.
+
+Additionally, when a vector, list, hash table or structure is printed which itself
+doesn't exceed the maximum depth, but whose elements do exceed, then that object
+is summarized, respectively, as
+.codn "(...)" ,
+.codn "#(...)" ,
+.code "H#(...)"
+and
+.codn "S#(...)" ,
+rather than repeating the
+.code ...
+sequence for each of its elements.
+
+The
+.code set-max-depth
+function returns the previous value.
+
 .SS* Coprocesses
 .coNP Functions @ open-command and @ open-process
 .synb