Merge pull request #118 from KeenS/equal

vectors, blobs, strings with equal contets are equal

src/bool.c

@@ -10,20 +10,86 @@
 #include "picrin/blob.h"
 #include "picrin/string.h"
 
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y)
+bool pic_string_equal_p(struct pic_string *str1, struct pic_string *str2)
 {
+  return pic_strcmp(str1, str2) == 0;
+}
+
+bool pic_blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
+{
+  if(blob1->len != blob2->len){
+    return false;
+  }
+  size_t i;
+  for(i = 0; i < blob1->len; ++i){
+    if(blob1->data[i] != blob2->data[i])
+      return false;
+  }
+  return true;  
+}
+
+bool
+pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
+{
+
+  if (depth > 10){
+    if(depth > 200){
+      pic_errorf(pic, "Stack overflow in equal\n");
+    }
+    if (NULL == ht){
+      xh_init_ptr(ht, sizeof(void *));
+    }
+    switch(pic_type(x)){
+    case PIC_TT_PAIR:
+    case PIC_TT_VECTOR:{
+      xh_entry *e = xh_get(ht, pic_obj_ptr(x));
+      if(e){
+        /* `x' was seen already.  */
+        return true;
+      }else{
+        xh_put(ht, pic_obj_ptr(x), NULL);
+      }
+    }
+    default:;
+    }
+  }
+
   enum pic_tt type;
+  pic_value local = pic_nil_value();
+  size_t rapid_count = 0;
+
+ LOOP:
 
   if (pic_eqv_p(x, y))
     return true;
   
   type = pic_type(x);
-  if (type != pic_type(y))
+  
+  if (type != pic_type(y)){
     return false;    
+  }
+  
   switch (type) {
   case PIC_TT_PAIR:
-    return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y)) && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
+    if(pic_nil_p(local)){
+      local = x;
+    }
+    if(pic_internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)){
+      x = pic_cdr(pic, x);
+      y = pic_cdr(pic, y);
+      ++rapid_count;
+      
+      if(rapid_count == 2){
+        rapid_count = 0;
+        local = pic_cdr(pic, local);
+        if (pic_eq_p(local, x)) {
+          return true;
+        }
+      }
+      goto LOOP;
+    }else{
+      return false;
+    }
   case PIC_TT_BLOB: {
     size_t i;
     struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
@@ -45,7 +111,7 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
       return false;
     }
     for (i = 0; i < u->len; ++i) {
-      if (! pic_equal_p(pic, u->data[i], v->data[i]))
+      if (! pic_internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
         return false;
     }
     return true;
@@ -57,6 +123,13 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y)
   }
 }
 
+bool
+pic_equal_p(pic_state *pic, pic_value x, pic_value y){
+  xhash ht;
+  xh_init_ptr(&ht, 0);
+  return pic_internal_equal_p(pic, x, y, 0, &ht);
+}
+
 static pic_value
 pic_bool_eq_p(pic_state *pic)
 {

t/r7rs-tests.scm

@@ -635,6 +635,53 @@
 (test #t (equal? (make-vector 5 'a)
                  (make-vector 5 'a)))
 
+;; circular objects
+(let ((l '(1 . 2))
+      (m '(1 . 2)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #t (equal? l m)))
+
+(let ((l '(1 . 2))
+      (m '(2 . 1)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #f (equal? l m)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #t (equal? v w)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 2)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #f (equal? v w)))
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #t  (equal? v w)))
+
+(let ((v (make-vector 2 2))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #f (equal? v w)))
+
 (test-end)
 
 (test-begin "6.2 Numbers")