We need a length-< special method.

Structure objects can be used to implement lazy structures
such as sequences. It is undesirable to take the length of
a lazy sequence because it forces all of its elements to
exist. Moreover, if the sequence is infinite, it is
impossible. There are situations in which it is only necessary
to know whether the length is less than a certain bound,
and for that we have the length-< function. That works on
infinite sequence such as lazy lists, requiring them to be
forced only so far as to determine the truth value of the
test. We need objects that implement lazy sequences to work
with this function.

* struct.h (enum special_slot): New member length_lt_m.

* lib.h (length_lt_s): Symbol variable declared.

* struct.c (special_sym): New entry in this table, associating
the length_lt_m enum with the length_lt_s symbol variable.

* lib.c (length_lt_s): Symbol variable defined.
(length_lt): Handle COBJ objects that are structures.
we test whether they have a length-< method, or else length
method. If they don't have either, we throw. We don't
fall back on the default case for objects that don't have
a length-< method, because the diagnostic won't be good
if they don't have a length method either; the programmer
will be informed that the length function couldn't find
a length method, without mentioning that it was actually
length-< that is being used.

* eval.c (eval_init): Register length-< using the length_lt_s
symbol variable rather than using intern.

* txr.1: Documented.

* tests/012/oop-seq.tl: New tests.

7 files changed, 67 insertions, 5 deletions

diff --git a/eval.c b/eval.c
index 68659eb8..0406dd78 100644
--- a/eval.c
+++ b/eval.c
@@ -7741,7 +7741,7 @@ void eval_init(void)
   reg_fun(intern(lit("str-seq"), user_package), func_n1(str_seq));
   reg_fun(intern(lit("length"), user_package), length_f);
   reg_fun(intern(lit("len"), user_package), length_f);
-  reg_fun(intern(lit("length-<"), user_package), func_n2(length_lt));
+  reg_fun(length_lt_s, func_n2(length_lt));
   reg_fun(intern(lit("empty"), user_package), func_n1(empty));
   reg_fun(intern(lit("copy"), user_package), func_n1(copy));
   reg_fun(intern(lit("sub"), user_package), func_n3o(sub, 1));
diff --git a/lib.c b/lib.c
index c0fc6a8c..c5722241 100644
--- a/lib.c
+++ b/lib.c
@@ -121,7 +121,7 @@ val query_error_s, file_error_s, process_error_s, syntax_error_s;
 val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
 val path_not_found_s, path_exists_s, path_permission_s;
 val warning_s, defr_warning_s, restart_s, continue_s;
-val gensym_counter_s, length_s;
+val gensym_counter_s, length_s, length_lt_s;
 val rplaca_s, rplacd_s, seq_iter_s;
 val lazy_streams_s;
 
@@ -13183,6 +13183,23 @@ val length_lt(val seq, val len)
     return length_list_lt(seq, len);
   case LSTR:
     return length_str_lt(seq, len);
+  case COBJ:
+    if (obj_struct_p(seq)) {
+      val length_lt_meth = get_special_slot(seq, length_lt_m);
+
+      if (length_lt_meth) {
+        return funcall2(length_lt_meth, seq, len);
+      } else {
+        val length_meth = get_special_slot(seq, length_m);
+
+        if (length_meth)
+          return lt(funcall1(length_meth, seq), len);
+      }
+
+      type_mismatch(lit("~a: ~s has no ~a or ~a method"), length_lt_s,
+                    seq, length_lt_s, length_s, nao);
+    }
+    /* fallthrough */
   default:
     return lt(length(seq), len);
   }
@@ -14167,6 +14184,7 @@ static void obj_init(void)
   continue_s = intern(lit("continue"), user_package);
   name_s = intern(lit("name"), user_package);
   length_s = intern(lit("length"), user_package);
+  length_lt_s = intern(lit("length-<"), user_package);
   rplaca_s = intern(lit("rplaca"), user_package);
   rplacd_s = intern(lit("rplacd"), user_package);
   seq_iter_s = intern(lit("seq-iter"), user_package);
diff --git a/lib.h b/lib.h
index 4fd070a4..0fc4e91a 100644
--- a/lib.h
+++ b/lib.h
@@ -692,7 +692,7 @@ extern val query_error_s, file_error_s, process_error_s, syntax_error_s;
 extern val timeout_error_s, system_error_s, alloc_error_s, stack_overflow_s;
 extern val path_not_found_s, path_exists_s, path_permission_s;
 extern val warning_s, defr_warning_s, restart_s, continue_s;
-extern val gensym_counter_s, length_s;
+extern val gensym_counter_s, length_s, length_lt_s;
 extern val rplaca_s, rplacd_s, seq_iter_s;
 extern val lazy_streams_s;
 extern val plus_s;
diff --git a/struct.c b/struct.c
index d897f0be..a2b1e79a 100644
--- a/struct.c
+++ b/struct.c
@@ -113,7 +113,7 @@ val iter_begin_s, iter_more_s, iter_item_s, iter_step_s, iter_reset_s;
 
 static val *special_sym[num_special_slots] = {
   &equal_s, &nullify_s, &from_list_s, &lambda_s, &lambda_set_s,
-  &length_s, &car_s, &cdr_s, &rplaca_s, &rplacd_s,
+  &length_s, &length_lt_s, &car_s, &cdr_s, &rplaca_s, &rplacd_s,
   &iter_begin_s, &iter_more_s, &iter_item_s, &iter_step_s, &iter_reset_s,
   &plus_s
 };
diff --git a/struct.h b/struct.h
index 836d60e7..7360e772 100644
--- a/struct.h
+++ b/struct.h
@@ -37,7 +37,7 @@ extern struct cobj_class *struct_cls;
 
 enum special_slot {
   equal_m, nullify_m, from_list_m, lambda_m, lambda_set_m,
-  length_m, car_m, cdr_m, rplaca_m, rplacd_m,
+  length_m, length_lt_m, car_m, cdr_m, rplaca_m, rplacd_m,
   iter_begin_m, iter_more_m, iter_item_m, iter_step_m, iter_reset_m,
   plus_m,
   num_special_slots
diff --git a/tests/012/oop-seq.tl b/tests/012/oop-seq.tl
index e91564fc..17463e96 100644
--- a/tests/012/oop-seq.tl
+++ b/tests/012/oop-seq.tl
@@ -55,6 +55,23 @@
 (test (list-seq (new counter-fast init 0 step 1 limit 0))
       nil)
 
+(defstruct integers ()
+  item to next
+  (:method length-< (me len)
+    (cond
+      ((<= len 1) nil)
+      (me.next me.next.(length-< (pred len)))
+      (t)))
+  (:postinit (me)
+    (if (< me.item me.to)
+      (set me.next (lnew integers to me.to item (succ me.item))))))
+
+(let ((ints (new integers item 1 to 10)))
+  (mtest
+    (length-< ints 11) t)
+    (length-< ints 10) nil
+    (length-< ints 9) nil)
+
 ;; The following reproduced a segfault when the change was made to allow del to
 ;; work with structs that have lambda and lambda-set.
 
diff --git a/txr.1 b/txr.1
index f0ab585e..f598381f 100644
--- a/txr.1
+++ b/txr.1
@@ -33549,6 +33549,33 @@ preference is given to
 .codn length ,
 which is likely to be much more efficient.
 
+.coNP Method @ length-<
+.synb
+.mets << object .(length-< << len )
+.syne
+.desc
+If a structure has
+.code length-<
+method, then it can be used as the left argument to the
+.code length-<
+function. The
+.meta len
+argument receives the right argument.
+
+If an object doesn't implement the
+.code length-<
+method, but does implement the
+.code length
+it can also be used as an argument to the
+.code length-<
+function. In that situation, the
+.code length-<
+function will call the
+.code length
+method instead, and then compare the returned value against the
+.meta len
+parameter.
+
 .coNP Methods @, car @ cdr and @ nullify
 .synb
 .mets << object .(car)