Merge pull request #118 from KeenS/equal
vectors, blobs, strings with equal contets are equal
This commit is contained in:
commit
04d2369c2e
87
src/bool.c
87
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)
|
||||
{
|
||||
|
|
|
@ -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")
|
||||
|
|
Loading…
Reference in New Issue