From a9ef840df948688ab1f217dcfd80f4e69436b4b0 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Tue, 27 May 2014 21:35:19 +0900 Subject: [PATCH 1/4] vectors, blobs, strings with equal contets are equal --- src/bool.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/bool.c b/src/bool.c index fa56fa31..ef497362 100644 --- a/src/bool.c +++ b/src/bool.c @@ -6,6 +6,9 @@ #include "picrin.h" #include "picrin/pair.h" +#include "picrin/vector.h" +#include "picrin/blob.h" +#include "picrin/string.h" bool pic_equal_p(pic_state *pic, pic_value x, pic_value y) @@ -22,6 +25,27 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) 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)); + case PIC_TT_BLOB: { + int i; + struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); + for(i = 0; i < v1->len; ++i){ + if(v1->data[i] != v2->data[i]) + return false; + } + return true; + } + case PIC_TT_VECTOR:{ + size_t i; + struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); + + for(i = 0; i < v1->len; ++i){ + if(! pic_equal_p(pic, v1->data[i], v2->data[i])) + return false; + } + return true; + } + case PIC_TT_STRING: + return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0; default: return false; } From dcef9579f59a89f7182c12389b3605de9bcf1860 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Wed, 28 May 2014 02:55:19 +0900 Subject: [PATCH 2/4] check length before compare contents --- src/bool.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/bool.c b/src/bool.c index ef497362..904a21d6 100644 --- a/src/bool.c +++ b/src/bool.c @@ -28,6 +28,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) case PIC_TT_BLOB: { int i; struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); + if(v1->len != v2->len){ + return false; + } for(i = 0; i < v1->len; ++i){ if(v1->data[i] != v2->data[i]) return false; @@ -38,6 +41,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) size_t i; struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); + if(v1->len != v2->len){ + return false; + } for(i = 0; i < v1->len; ++i){ if(! pic_equal_p(pic, v1->data[i], v2->data[i])) return false; From d706240adabde951fd95dec9173805b9f11b0c37 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Wed, 18 Jun 2014 00:47:50 +0900 Subject: [PATCH 3/4] implement circular refarence checking --- src/bool.c | 104 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 84 insertions(+), 20 deletions(-) diff --git a/src/bool.c b/src/bool.c index 904a21d6..8ed9cc02 100644 --- a/src/bool.c +++ b/src/bool.c @@ -10,33 +10,87 @@ #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)); - case PIC_TT_BLOB: { - int i; - struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); - if(v1->len != v2->len){ + 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; } - for(i = 0; i < v1->len; ++i){ - if(v1->data[i] != v2->data[i]) - return false; - } - return true; - } + case PIC_TT_VECTOR:{ size_t i; struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); @@ -45,18 +99,28 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) return false; } for(i = 0; i < v1->len; ++i){ - if(! pic_equal_p(pic, v1->data[i], v2->data[i])) - return false; + if(! pic_internal_equal_p(pic, v1->data[i], v2->data[i], depth + 1, ht)){ + return false; + } } return true; } + case PIC_TT_BLOB: + return pic_blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); case PIC_TT_STRING: - return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0; + return pic_string_equal_p(pic_str_ptr(x), pic_str_ptr(y)); default: return false; } } +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) { From c4862cb291a78c26b0ed387e3c919076bf2d7df6 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Fri, 18 Jul 2014 00:55:46 +0900 Subject: [PATCH 4/4] add test of circular list equivalence --- t/r7rs-tests.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index eeac935e..39e5a90d 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")