commit 66f18437abc098b23c29f93c1a49687e0471b851
parent 82045a3e8dce30c1102dfa23eb42bf3ebd2b1a50
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 23 Nov 2011 06:04:17 -0300
Added vector support to equal?. Added tests for vector-copy/equal? for vectors. Some light refactoring in vector code.
Diffstat:
4 files changed, 73 insertions(+), 34 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -170,9 +170,10 @@ kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h \
kinteger.h imath.h krational.h imrat.h
kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kstring.h kbytevector.h kcontinuation.h \
- kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
- ksymbol.h kgeqp.h kinteger.h imath.h krational.h imrat.h kgequalp.h
+ ktoken.h kmem.h kpair.h kvector.h kgc.h kstring.h kbytevector.h \
+ kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
+ kenvironment.h ksymbol.h kgeqp.h kinteger.h imath.h krational.h imrat.h \
+ kgequalp.h
kgerror.o: kgerror.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -13,6 +13,7 @@
#include "kstate.h"
#include "kobject.h"
#include "kpair.h"
+#include "kvector.h"
#include "kstring.h" /* for kstring_equalp */
#include "kbytevector.h" /* for kbytevector_equalp */
#include "kcontinuation.h"
@@ -121,7 +122,7 @@ inline TValue equal_find(klisp_State *K, TValue obj)
inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
{
/* K isn't needed but added for consistency */
- (void)K;
+ UNUSED(K);
int32_t size1 = ivalue(kcdr(root1));
int32_t size2 = ivalue(kcdr(root2));
TValue new_size = i2tv(size1 + size2);
@@ -185,37 +186,65 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
while(!ks_sisempty(K)) {
obj2 = ks_spop(K);
obj1 = ks_spop(K);
-/* REFACTOR these ifs: compare both types first, then switch on type */
+
if (!eq2p(K, obj1, obj2)) {
- if (ttispair(obj1) && ttispair(obj2)) {
- /* if they were already compaired, consider equal for now
- otherwise they are equal if both their cars and cdrs are */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- ks_spush(K, kcdr(obj1));
- ks_spush(K, kcdr(obj2));
- ks_spush(K, kcar(obj1));
- ks_spush(K, kcar(obj2));
- }
- } else if (ttisstring(obj1) && ttisstring(obj2)) {
- if (!kstring_equalp(obj1, obj2)) {
- result = false;
+ /* This type comparison works because we just care about
+ pairs, vectors, strings & bytevectors */
+ if (ttype(obj1) == ttype(obj2)) {
+ switch(ttype(obj1)) {
+ case K_TPAIR:
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if both their cars
+ and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
break;
- }
- } else if (ttisbytevector(obj1) && ttisbytevector(obj2)) {
- if (!kbytevector_equalp(obj1, obj2)) {
- result = false;
+ case K_TVECTOR:
+ if (kvector_length(obj1) == kvector_length(obj2)) {
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if all their elements
+ are equal pairwise */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ uint32_t i = kvector_length(obj1);
+ TValue *array1 = kvector_array(obj1);
+ TValue *array2 = kvector_array(obj1);
+ while(i-- > 0) {
+ ks_spush(K, array1[i]);
+ ks_spush(K, array2[i]);
+ }
+ }
+ } else {
+ result = false;
+ goto end;
+ }
break;
+ case K_TSTRING:
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TBYTEVECTOR:
+ if (!kbytevector_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ default:
+ result = false;
+ goto end;
}
- } else if (ttisvector(obj1) && ttisvector(obj2)) {
- fprintf(stderr, "TODO: equal? for vectors not implemented!\n");
- result = false;
} else {
result = false;
- break;
+ goto end;
}
}
}
-
+end:
/* if result is false, the stack may not be empty */
ks_sclear(K);
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -47,8 +47,8 @@ void make_vector(klisp_State *K)
klispE_throw_simple(K, "vector length is too big");
return;
}
- TValue new_vector = (ivalue(tv_s) == 0)
- ? K->empty_vector
+ TValue new_vector = (ivalue(tv_s) == 0)?
+ K->empty_vector
: kvector_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_vector);
}
@@ -101,9 +101,6 @@ void vector_setS(klisp_State *K)
klispE_throw_simple_with_irritants(K, "vector index out of bounds",
1, tv_i);
return;
- } else if (kvector_immutablep(vector)) {
- klispE_throw_simple(K, "immutable vector");
- return;
}
int32_t i = ivalue(tv_i);
@@ -111,6 +108,9 @@ void vector_setS(klisp_State *K)
klispE_throw_simple_with_irritants(K, "vector index out of bounds",
1, tv_i);
return;
+ } else if (kvector_immutablep(vector)) {
+ klispE_throw_simple(K, "immutable vector");
+ return;
}
kvector_array(vector)[i] = tv_new_value;
@@ -155,7 +155,8 @@ void vector(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
TValue ptree = K->next_value;
- kapply_cc(K, list_to_vector_h(K, "vector", ptree));
+ TValue res = list_to_vector_h(K, "vector", ptree);
+ kapply_cc(K, res);
}
/* (R7RS 3rd draft 6.3.6) list->vector */
@@ -165,7 +166,8 @@ void list_to_vector(klisp_State *K)
TValue ptree = K->next_value;
bind_1p(K, ptree, ls);
- kapply_cc(K, list_to_vector_h(K, "list->vector", ls));
+ TValue res = list_to_vector_h(K, "list->vector", ls);
+ kapply_cc(K, res);
}
/* (R7RS 3rd draft 6.3.6) vector->list */
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -86,7 +86,14 @@
($check-predicate (mutable-vector? (list->vector (list "a" "b"))))
;; (R7RS 3rd draft, section 6.3.6) vector-copy
-;; TODO: implement equal? for vectors first
+($check equal? (vector-copy (vector 1 2 3)) (vector 1 2 3))
+($check equal? (vector-copy (vector (vector 1 2 3) (vector 4 5 6)))
+ (vector (vector 1 2 3) (vector 4 5 6)))
+($check-predicate (mutable-vector? (vector-copy (vector 1 2 3))))
+
+($check-predicate
+ (mutable-vector?
+ (vector-copy (vector->immutable-vector (vector 1 2 3)))))
;; XXX vector->immutable-vector
