From 3c09800abda31a3f5da8157b0ef2863850f6b662 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 19 Nov 2015 20:36:21 -0800
Subject: New equality substitution.

If the equal method is defined for structs, its return
value is used in their place for hashing and comparison.

* eval.h (eq_s, eql_s, equal_s): Declared.

* hash.c (equal_hash): If a COBJ defines an equalsub
function, we call it. If it returns non-nil, we
take the object in its place and recurse.

* lib.c (equal): Refactored to support equality substitution.
(less): Support equality substitution.

* lib.h (cobj_ops): New function pointer member, equalsub.
Only struct instances define this, currently.
(cobj_ops_init): Add null entry to initializer for equalsub.
(cobj_ops_init_ex): New initialiation macro for
situations when the equalsub member must be provided.

* struct.c (struct struct_type): new member eqmslot.
(make_struct_type): Initialize emslot to zero.
(static_slot_set, static_slot_ensure): If eqmslot is -1,
indicating positive knowledge that there is no equal method
static slot, we must invalidate that with a zero: it is no
longer known whether there is or isn't such a slot.
(get_equal_method, struct_inst_equalsub): New static functions.
(struct_inst_ops): Initialize the equalsub member using
new cobj_ops_init_ex macro.

* txr.1: Document equality substitution.
---
 lib.c | 99 +++++++++++++++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 73 insertions(+), 26 deletions(-)

(limited to 'lib.c')

diff --git a/lib.c b/lib.c
index 22df9bc7..0dc1b543 100644
--- a/lib.c
+++ b/lib.c
@@ -2066,16 +2066,16 @@ val equal(val left, val right)
   case NIL:
   case CHR:
   case NUM:
-    return nil;
+    break;
   case CONS:
   case LCONS:
-    if ((type(right) == CONS || type(right) == LCONS) &&
-        equal(car(left), car(right)) &&
-        equal(cdr(left), cdr(right)))
+    if (type(right) == CONS || type(right) == LCONS)
     {
-      return t;
+      if (equal(car(left), car(right)) && equal(cdr(left), cdr(right)))
+        return t;
+      return nil;
     }
-    return nil;
+    break;
   case LIT:
     switch (type(right)) {
     case LIT:
@@ -2085,10 +2085,12 @@ val equal(val left, val right)
     case LSTR:
       lazy_str_force(right);
       return equal(left, right->ls.prefix);
-    default:
+    case COBJ:
       break;
+    default:
+      return nil;
     }
-    return nil;
+    break;
   case STR:
     switch (type(right)) {
     case LIT:
@@ -2098,14 +2100,16 @@ val equal(val left, val right)
     case LSTR:
       lazy_str_force(right);
       return equal(left, right->ls.prefix);
-    default:
+    case COBJ:
       break;
+    default:
+      return nil;
     }
-    return nil;
+    break;
   case SYM:
   case PKG:
   case ENV:
-    return right == left ? t : nil;
+    break;
   case FUN:
     if (type(right) == FUN &&
         left->f.functype == right->f.functype &&
@@ -2129,7 +2133,7 @@ val equal(val left, val right)
       }
       return nil;
     }
-    return nil;
+    break;
   case VEC:
     if (type(right) == VEC) {
       cnum i, length;
@@ -2142,7 +2146,7 @@ val equal(val left, val right)
       }
       return t;
     }
-    return nil;
+    break;
   case LSTR:
     switch (type(right)) {
     case LIT:
@@ -2150,31 +2154,57 @@ val equal(val left, val right)
     case LSTR:
       lazy_str_force(left);
       return equal(left->ls.prefix, right);
-    default:
+    case COBJ:
       break;
+    default:
+      return nil;
     }
     return nil;
   case BGNUM:
-    if (type(right) == BGNUM && mp_cmp(mp(left), mp(right)) == MP_EQ)
-      return t;
-    return nil;
+    if (type(right) == BGNUM) {
+      if (mp_cmp(mp(left), mp(right)) == MP_EQ)
+        return t;
+      return nil;
+    }
+    break;
   case FLNUM:
-    if (type(right) == FLNUM && left->fl.n == right->fl.n)
-      return t;
-    return nil;
+    if (type(right) == FLNUM) {
+      if (left->fl.n == right->fl.n)
+        return t;
+      return nil;
+    }
+    break;
   case RNG:
-    if (type(right) == RNG &&
-        equal(from(left), from(right)) &&
-        equal(to(left), to(right)))
-      return t;
-    return nil;
+    if (type(right) == RNG) {
+      if (equal(from(left), from(right)) &&
+          equal(to(left), to(right)))
+        return t;
+      return nil;
+    }
+    break;
   case COBJ:
+    if (left->co.ops->equalsub) {
+      val lsub = left->co.ops->equalsub(left);
+      if (lsub)
+        return equal(lsub, right);
+    }
+
     if (type(right) == COBJ && left->co.ops == right->co.ops)
       return left->co.ops->equal(left, right);
+
     return nil;
   }
 
-  internal_error("unhandled case in equal function");
+  if (type(right) != COBJ)
+    return nil;
+
+  if (right->co.ops->equalsub) {
+    val rsub = right->co.ops->equalsub(right);
+    if (rsub)
+      return equal(left, rsub);
+  }
+
+  return nil;
 }
 
 alloc_bytes_t malloc_bytes;
@@ -3769,9 +3799,26 @@ val less(val left, val right)
   if (left == right)
     return nil;
 
+tail:
   l_type = type(left);
   r_type = type(right);
 
+  if (l_type == COBJ && left->co.ops->equalsub) {
+    val lsub = left->co.ops->equalsub(left);
+    if (lsub) {
+      left = lsub;
+      goto tail;
+    }
+  }
+
+  if (r_type == COBJ && right->co.ops->equalsub) {
+    val rsub = right->co.ops->equalsub(right);
+    if (rsub) {
+      right = rsub;
+      goto tail;
+    }
+  }
+
   switch (less_tab[l_type][r_type]) {
   case less_false:
     return nil;
-- 
cgit v1.2.3