diff --git a/src/bool.c b/src/bool.c index fc00554d..319355dc 100644 --- a/src/bool.c +++ b/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)) - return false; + + 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) { diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 45db84d1..7c7cfbeb 100644 --- a/t/r7rs-tests.scm +++ b/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")