klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/Makefile | 7++++---
Msrc/kgequalp.c | 75++++++++++++++++++++++++++++++++++++++++++++++++++++-----------------------
Msrc/kgvectors.c | 16+++++++++-------
Msrc/tests/vectors.k | 9++++++++-
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