adding equal?/bounded and an optimized equiv? which uses it

include/chibi/sexp.h

@@ -1047,6 +1047,7 @@ SEXP_API sexp sexp_alloc_tagged_aux(sexp ctx, size_t size, sexp_uint_t tag sexp_
 SEXP_API sexp sexp_make_context(sexp ctx, size_t size, size_t max_size);
 SEXP_API sexp sexp_cons_op(sexp ctx sexp_api_params(self, n), sexp head, sexp tail);
 SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
+SEXP_API sexp sexp_equalp_bound (sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp bound);
 SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b);
 SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj);
 SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls);

lib/chibi/equiv.module

@@ -0,0 +1,6 @@
+
+(define-module (chibi equiv)
+  (export equiv?)
+  (import-immutable (scheme))
+  (import (srfi 69))
+  (include "equiv.scm"))

lib/chibi/equiv.scm

@@ -0,0 +1,44 @@
+
+(define (equiv? a b)
+  (let ((equivs (make-hash-table eq?)))
+    (define (get-equivs x)
+      (or (hash-table-ref/default equivs x #f)
+          (let ((tmp (make-hash-table eq?)))
+            (hash-table-set! equivs x tmp)
+            tmp)))
+    (define (merge! tab x)
+      (hash-table-set! tab x tab)
+      (cond ((hash-table-ref/default equivs x #f)
+             => (lambda (tab2)
+                  (hash-table-walk tab2 (lambda (key value)
+                                          (hash-table-set! tab key tab)))))))
+    (define (equiv? a b)
+      (cond
+       ((eq? a b))
+       ((pair? a)
+        (and (pair? b)
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (and (equiv? (car a) (car b))
+                       (equiv? (cdr a) (cdr b))))))))
+       ((vector? a)
+        (and (vector? b)
+             (= (vector-length a) (vector-length b))
+             (let ((a-tab (get-equivs a)))
+               (hash-table-ref
+                a-tab
+                b
+                (lambda ()
+                  (merge! a-tab b)
+                  (let lp ((i (- (vector-length a) 1)))
+                    (or (< i 0)
+                        (and (equiv? (vector-ref a i) (vector-ref b i))
+                             (lp (- i 1))))))))))
+       (else
+        (equal? a b))))
+    (let ((res (equal?/bounded a b 1000000)))
+      (and res (or (> res 0) (equiv? a b)) #t))))

opcodes.c

@@ -96,6 +96,7 @@ _FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-outp
 _FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"current-output-port", sexp_display_op),
 _FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "flush-output", (sexp)"current-output-port", sexp_flush_output_op),
 _FN2(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?", 0, sexp_equalp_op),
+_FN3(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "equal?/bounded", 0, sexp_equalp_bound),
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "list?", 0, sexp_listp_op),
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "identifier?", 0, sexp_identifierp_op),
 _FN1(_I(SEXP_SYMBOL), _I(SEXP_OBJECT), "identifier->symbol", 0, sexp_syntactic_closure_expr_op),

sexp.c

@@ -654,7 +654,7 @@ sexp sexp_length_op (sexp ctx sexp_api_params(self, n), sexp ls1) {
   return sexp_make_fixnum(res + (sexp_pairp(ls2) ? 1 : 0));
 }
 
-sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
+sexp sexp_equalp_bound (sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp bound) {
   sexp_uint_t size;
   sexp_sint_t i, len;
   sexp t, *p, *q;
@@ -662,7 +662,7 @@ sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
 
  loop:
   if (a == b)
-    return SEXP_TRUE;
+    return bound;
   else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))
            || (sexp_pointer_tag(a) != sexp_pointer_tag(b)))
     return SEXP_FALSE;
@@ -670,12 +670,15 @@ sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
   /* a and b are both pointers of the same type */
 #if SEXP_USE_BIGNUMS
   if (sexp_pointer_tag(a) == SEXP_BIGNUM)
-    return sexp_make_boolean(!sexp_bignum_compare(a, b));
+    return !sexp_bignum_compare(a, b) ? bound : SEXP_FALSE;
 #endif
 #if SEXP_USE_FLONUMS && ! SEXP_USE_IMMEDIATE_FLONUMS
   if (sexp_pointer_tag(a) == SEXP_FLONUM)
-    return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
+    return (sexp_flonum_value(a) == sexp_flonum_value(b)) ? bound : SEXP_FALSE;
 #endif
+  if (sexp_unbox_fixnum(bound) < 0)
+    return bound;
+  bound = sexp_fx_sub(bound, SEXP_ONE);
   t = sexp_object_type(ctx, a);
   p0 = ((char*)a) + offsetof(struct sexp_struct, value);
   p = (sexp*) (((char*)a) + sexp_type_field_base(t));
@@ -698,13 +701,20 @@ sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
   /* check eq-object slots */
   len = sexp_type_num_eq_slots_of_object(t, a);
   if (len > 0) {
-    for (i=0; i<len-1; i++)
+    for (i=0; i<len-1; i++) {
-      if (p[i] != q[i] && sexp_not(sexp_equalp(ctx, p[i], q[i])))
+      bound = sexp_equalp_bound(ctx sexp_api_pass(self, n), p[i], q[i], bound);
-        return SEXP_FALSE;
+      if (sexp_not(bound)) return SEXP_FALSE;
+    }
     /* tail-recurse on the last value */
     a = p[len-1]; b = q[len-1]; goto loop;
   }
-  return SEXP_TRUE;
+  return bound;
+}
+
+sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) {
+  return sexp_make_boolean(
+    sexp_truep(sexp_equalp_bound(ctx sexp_api_pass(self, n), a, b,
+                                 sexp_make_fixnum(1000000000))));
 }
 
 /********************* strings, symbols, vectors **********************/