commit 1a607a12a0b55b476adba3d5c8bf695d54a39be4
parent 7b1baf7ba55e0be06ec609b7614d2091aceac676
Author: Oto Havle <havleoto@gmail.com>
Date: Tue, 22 Nov 2011 23:36:52 +0100
Added bytevectors (except equality and few r7rs procedures)
Diffstat:
16 files changed, 529 insertions(+), 17 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -35,12 +35,12 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o kscript.o \
kencapsulation.o kpromise.o kport.o kinteger.o krational.o \
- kreal.o ktable.o kgc.o imath.o imrat.o kbytevector.o \
+ kreal.o ktable.o kgc.o imath.o imrat.o kbytevector.o kvector.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o kgbytevectors.o kgsystem.o kgerror.o \
+ kgstrings.o kgbytevectors.o kgvectors.o kgsystem.o kgerror.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -140,10 +140,7 @@ kgbytevectors.o: kgbytevectors.c kstate.h klimits.h klisp.h kobject.h \
ksymbol.h kstring.h kgbytevectors.h kgnumbers.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kbytevector.h \
- kerror.h kpair.h
-kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h kghelpers.h kenvironment.h ksymbol.h kstring.h kgchars.h
+ kvector.h kerror.h kpair.h
kgcombiners.o: kgcombiners.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h koperative.h kapplicative.h kerror.h kghelpers.h \
@@ -160,14 +157,14 @@ kgencapsulations.o: kgencapsulations.c kstate.h klimits.h klisp.h \
kobject.h klispconf.h ktoken.h kmem.h kencapsulation.h kapplicative.h \
koperative.h kerror.h kpair.h kgc.h kghelpers.h kcontinuation.h \
kenvironment.h ksymbol.h kstring.h kgencapsulations.h
-kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
- kgcontrol.h
kgenvironments.o: kgenvironments.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
kgenvironments.h kgenv_mut.h kgpair_mut.h kgcontrol.h
+kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
+ kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
+ kgcontrol.h
kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h \
@@ -188,6 +185,9 @@ kgffi.o: kgffi.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
+kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kghelpers.h kenvironment.h ksymbol.h kstring.h kgchars.h
kgkd_vars.o: kgkd_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
@@ -225,8 +225,8 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
- kgstrings.h kgchars.h kgports.h kgbytevectors.h kgsystem.h kgerror.h \
- $(if $(USE_LIBFFI), kgffi.h) ktable.h keval.h krepl.h kscript.h
+ kgstrings.h kgchars.h kgports.h kgbytevectors.h kgvectors.h kgsystem.h \
+ kgerror.h kgffi.h ktable.h keval.h krepl.h kscript.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h ksymbol.h kstring.h kghelpers.h kenvironment.h kgchars.h \
@@ -239,6 +239,10 @@ kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
kgsystem.h
+kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kvector.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
+ kgvectors.h kgnumbers.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
@@ -275,8 +279,8 @@ kscript.o: kscript.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
kstate.o: kstate.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h keval.h koperative.h \
kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h \
- kscript.h ksymbol.h kport.h ktable.h kbytevector.h kgpairs_lists.h \
- kghelpers.h kerror.h kgerror.h
+ kscript.h ksymbol.h kport.h ktable.h kbytevector.h kvector.h \
+ kgpairs_lists.h kghelpers.h kerror.h kgerror.h
kstring.o: kstring.c kstring.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
ksymbol.o: ksymbol.c ksymbol.h kobject.h klimits.h klisp.h klispconf.h \
@@ -288,6 +292,8 @@ ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
ktoken.o: ktoken.c ktoken.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h kpair.h \
kgc.h kstring.h kbytevector.h ksymbol.h kerror.h kport.h
+kvector.o: kvector.c kvector.h kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kgc.h
kwrite.o: kwrite.c kwrite.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h \
kpair.h kgc.h kstring.h ksymbol.h kerror.h ktable.h kport.h \
diff --git a/src/kgc.c b/src/kgc.c
@@ -21,6 +21,7 @@
#include "ktable.h"
#include "kstring.h"
#include "kbytevector.h"
+#include "kvector.h"
#include "kerror.h"
#define GCSTEPSIZE 1024u
@@ -109,6 +110,7 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TTABLE:
case K_TERROR:
case K_TBYTEVECTOR:
+ case K_TVECTOR:
case K_TFPORT:
case K_TMPORT:
o->gch.gclist = K->gray;
@@ -333,6 +335,12 @@ static int32_t propagatemark (klisp_State *K) {
markvalue(K, p->buf);
return sizeof(MPort);
}
+ case K_TVECTOR: {
+ Vector *v = cast(Vector *, o);
+ markvalue(K, v->mark);
+ markvaluearray(K, v->array, v->sizearray);
+ return sizeof(Vector) + v->sizearray * sizeof(TValue);
+ }
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
type);
@@ -476,6 +484,9 @@ static void freeobj (klisp_State *K, GCObject *o) {
explicitly */
klispM_free(K, (MPort *)o);
break;
+ case K_TVECTOR:
+ klispM_freemem(K, o, sizeof(Vector) + sizeof(TValue) * o->vector.sizearray);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
@@ -605,6 +616,7 @@ static void markroot (klisp_State *K) {
markvalue(K, K->kd_strict_arith_key);
markvalue(K, K->empty_string);
markvalue(K, K->empty_bytevector);
+ markvalue(K, K->empty_vector);
markvalue(K, K->ktok_lparen);
markvalue(K, K->ktok_rparen);
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -202,6 +202,9 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
result = false;
break;
}
+ } else if (ttisvector(obj1) && ttisvector(obj2)) {
+ fprintf(stderr, "TODO: equal? for vectors not implemented!\n");
+ result = false;
} else {
result = false;
break;
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -268,7 +268,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
return pairs;
}
-int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
TValue obj, int32_t *cpairs)
{
TValue tail = obj;
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -273,7 +273,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
/* check that obj is a list, returns the number of pairs */
/* TODO change the return to void and add int32_t pairs obj */
-int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
TValue obj, int32_t *cpairs);
/*
diff --git a/src/kground.c b/src/kground.c
@@ -36,6 +36,7 @@
#include "kgchars.h"
#include "kgports.h"
#include "kgbytevectors.h"
+#include "kgvectors.h"
#include "kgsystem.h"
#include "kgerror.h"
@@ -143,6 +144,7 @@ void kinit_ground_env(klisp_State *K)
kinit_chars_ground_env(K);
kinit_ports_ground_env(K);
kinit_bytevectors_ground_env(K);
+ kinit_vectors_ground_env(K);
kinit_system_ground_env(K);
kinit_error_ground_env(K);
#if KUSE_LIBFFI
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -0,0 +1,244 @@
+/*
+** kgvectors.c
+** Vector (heterogenous array) features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+#include "kvector.h"
+#include "kpair.h"
+
+#include "kghelpers.h"
+#include "kgvectors.h"
+#include "kgnumbers.h" /* for keintegerp & knegativep */
+
+/* (R7RS 3rd draft 6.3.6) vector? */
+/* uses typep */
+
+/* ?.?.? immutable-vector?, mutable-vector? */
+/* use ftypep */
+
+/* (R7RS 3rd draft 6.3.6) make-vector */
+void make_vector(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill);
+ if (!get_opt_tpar(K, fill, "any", anytype))
+ fill = KINERT;
+
+ if (knegativep(tv_s)) {
+ klispE_throw_simple(K, "negative vector length");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "vector length is too big");
+ return;
+ }
+ TValue new_vector = (ivalue(tv_s) == 0)
+ ? K->empty_vector
+ : kvector_new_sf(K, ivalue(tv_s), fill);
+ kapply_cc(K, new_vector);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-length */
+void vector_length(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "vector", ttisvector, vector);
+
+ TValue res = i2tv(kvector_length(vector));
+ kapply_cc(K, res);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-ref */
+void vector_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_2tp(K, ptree, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_i);
+
+ if (!ttisfixint(tv_i)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+ int32_t i = ivalue(tv_i);
+ if (i < 0 || i >= kvector_length(vector)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+ kapply_cc(K, kvector_array(vector)[i]);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-set! */
+void vector_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_3tp(K, ptree, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_i, "any", anytype, tv_new_value);
+
+ if (!ttisfixint(tv_i)) {
+ 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);
+ if (i < 0 || i >= kvector_length(vector)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+
+ kvector_array(vector)[i] = tv_new_value;
+ kapply_cc(K, KINERT);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-copy */
+/* TEMP: at least for now this always returns mutable vectors */
+void vector_copy(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue new_vector = kvector_emptyp(v)
+ ? v
+ : kvector_new_bs_g(K, true, kvector_array(v), kvector_length(v));
+ kapply_cc(K, new_vector);
+}
+
+static TValue list_to_vector_h(klisp_State *K, const char *name, TValue ls)
+{
+ int32_t dummy;
+ int32_t pairs = check_list(K, name, false, ls, &dummy);
+
+ if (pairs == 0) {
+ return K->empty_vector;
+ } else {
+ TValue res = kvector_new_sf(K, pairs, KINERT);
+ for (int i = 0; i < pairs; i++) {
+ kvector_array(res)[i] = kcar(ls);
+ ls = kcdr(ls);
+ }
+ return res;
+ }
+}
+
+/* (R7RS 3rd draft 6.3.6) vector */
+void vector(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ kapply_cc(K, list_to_vector_h(K, "vector", ptree));
+}
+
+/* (R7RS 3rd draft 6.3.6) list->vector */
+void list_to_vector(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1p(K, ptree, ls);
+ kapply_cc(K, list_to_vector_h(K, "list->vector", ls));
+}
+
+/* (R7RS 3rd draft 6.3.6) vector->list */
+void vector_to_list(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue tail = KNIL;
+ krooted_vars_push(K, &tail);
+ size_t i = kvector_length(v);
+ while (i-- > 0)
+ tail = kcons(K, kvector_array(v)[i], tail);
+ krooted_vars_pop(K);
+ kapply_cc(K, tail);
+}
+
+/* ??.?.? vector->immutable-vector */
+void vector_to_immutable_vector(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue res = kvector_immutablep(v)
+ ? v
+ : kvector_new_bs_g(K, false, kvector_array(v), kvector_length(v));
+ kapply_cc(K, res);
+}
+
+/* init ground */
+void kinit_vectors_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is not in the report. The bindings here are
+ ** taken from the r7rs scheme draft and should not be considered standard.
+ ** They are provided in the meantime to allow programs to use vectors.
+ */
+
+ /* (R7RS 3rd draft 6.3.6) vector? */
+ add_applicative(K, ground_env, "vector?", typep, 2, symbol,
+ i2tv(K_TVECTOR));
+ /* ??.? immutable-vector?, mutable-vector? */
+ add_applicative(K, ground_env, "immutable-vector?", ftypep, 2, symbol,
+ p2tv(kimmutable_vectorp));
+ add_applicative(K, ground_env, "mutable-vector?", ftypep, 2, symbol,
+ p2tv(kmutable_vectorp));
+ /* (R7RS 3rd draft 6.3.6) make-vector */
+ add_applicative(K, ground_env, "make-vector", make_vector, 0);
+ /* (R7RS 3rd draft 6.3.6) vector-length */
+ add_applicative(K, ground_env, "vector-length", vector_length, 0);
+
+ /* (R7RS 3rd draft 6.3.6) vector-ref vector-set! */
+ add_applicative(K, ground_env, "vector-ref", vector_ref, 0);
+ add_applicative(K, ground_env, "vector-set!", vector_setS, 0);
+
+ /* (R7RS 3rd draft 6.3.6) vector, vector->list, list->vector */
+ add_applicative(K, ground_env, "vector", vector, 0);
+ add_applicative(K, ground_env, "vector->list", vector_to_list, 0);
+ add_applicative(K, ground_env, "list->vector", list_to_vector, 0);
+
+ /* ??.1.?? vector-copy */
+ add_applicative(K, ground_env, "vector-copy", vector_copy, 0);
+
+ /* TODO: vector->string, string->vector, vector-fill */
+ /* TODO: vector-copy! vector-copy-partial vector-copy-partial! */
+
+ /* ??.1.?? vector->immutable-vector */
+ add_applicative(K, ground_env, "vector->immutable-vector",
+ vector_to_immutable_vector, 0);
+
+}
diff --git a/src/kgvectors.h b/src/kgvectors.h
@@ -0,0 +1,15 @@
+/*
+** kgvectors.h
+** Vector (heterogenous array) features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgvectors_h
+#define kgvectors_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_vectors_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/kobject.h b/src/kobject.h
@@ -167,6 +167,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TBYTEVECTOR 41
#define K_TFPORT 42
#define K_TMPORT 43
+#define K_TVECTOR 44
/* for tables */
#define K_TDEADKEY 60
@@ -221,7 +222,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_BYTEVECTOR K_MAKE_VTAG(K_TBYTEVECTOR)
#define K_TAG_FPORT K_MAKE_VTAG(K_TFPORT)
#define K_TAG_MPORT K_MAKE_VTAG(K_TMPORT)
-
+#define K_TAG_VECTOR K_MAKE_VTAG(K_TVECTOR)
/*
** Macros to test types
@@ -309,6 +310,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttismport(o) (tbasetype_(o) == K_TAG_MPORT)
#define ttisport(o_) ({ int32_t t_ = tbasetype_(o_); \
t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
+#define ttisvector(o) (tbasetype_(o) == K_TAG_VECTOR)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -515,6 +517,14 @@ typedef struct __attribute__ ((__packed__)) {
uint8_t b[]; /* buffer */
} Bytevector;
+/* Vectors (heterogenous arrays) */
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ TValue mark; /* for cycle/sharing aware algorithms */
+ uint32_t sizearray; /* number of elements in array[] */
+ TValue array[]; /* array of elements */
+} Vector;
+
/*
** `module' operation for hashing (size is always a power of 2)
*/
@@ -576,6 +586,7 @@ union GCObject {
Port port; /* common fields for all types of ports */
FPort fport;
MPort mport;
+ Vector vector;
};
@@ -679,6 +690,7 @@ const TValue kfree;
#define gc2table(o_) (gc2tv(K_TAG_TABLE, o_))
#define gc2error(o_) (gc2tv(K_TAG_ERROR, o_))
#define gc2bytevector(o_) (gc2tv(K_TAG_BYTEVECTOR, o_))
+#define gc2vector(o_) (gc2tv(K_TAG_VECTOR, o_))
#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
@@ -696,6 +708,7 @@ const TValue kfree;
#define tv2table(v_) ((Table *) gcvalue(v_))
#define tv2error(v_) ((Error *) gcvalue(v_))
#define tv2bytevector(v_) ((Bytevector *) gcvalue(v_))
+#define tv2vector(v_) ((Vector *) gcvalue(v_))
#define tv2fport(v_) ((FPort *) gcvalue(v_))
#define tv2mport(v_) ((MPort *) gcvalue(v_))
#define tv2port(v_) ((Port *) gcvalue(v_))
diff --git a/src/kstate.c b/src/kstate.c
@@ -36,6 +36,7 @@
#include "kport.h"
#include "ktable.h"
#include "kbytevector.h"
+#include "kvector.h"
#include "kgpairs_lists.h" /* for creating list_app */
#include "kgerror.h" /* for creating error hierarchy */
@@ -158,6 +159,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->empty_bytevector = KNIL; /* trick constructor to create empty bytevector */
K->empty_bytevector = kbytevector_new_bs_imm(K, NULL, 0);
+ /* Empty vector */
+ /* MAYBE: see above */
+ K->empty_vector = kvector_new_bs_g(K, false, NULL, 0);
+
/* initialize tokenizer */
/* WORKAROUND: for stdin line buffering & reading of EOF */
diff --git a/src/kstate.h b/src/kstate.h
@@ -115,6 +115,10 @@ struct klisp_State {
/* Bytevectors */
TValue empty_bytevector;
+
+ /* Vectors */
+ TValue empty_vector;
+
/* tokenizer */
/* special tokens, see ktoken.c for rationale */
diff --git a/src/kvector.c b/src/kvector.c
@@ -0,0 +1,65 @@
+/*
+** kvector.c
+** Kernel Vectors (heterogenous arrays)
+** See Copyright Notice in klisp.h
+*/
+
+#include <string.h>
+
+#include "kvector.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "kmem.h"
+#include "kgc.h"
+
+/* helper function allocating vectors */
+
+static Vector *kvector_alloc(klisp_State *K, bool m, uint32_t length)
+{
+ Vector *new_vector;
+
+ if (length > (SIZE_MAX - sizeof(Vector)) / sizeof(TValue))
+ klispM_toobig(K);
+
+ klisp_assert(!m || length > 0);
+
+ size_t size = sizeof(Vector) + length * sizeof(TValue);
+ new_vector = (Vector *) klispM_malloc(K, size);
+ klispC_link(K, (GCObject *) new_vector, K_TVECTOR,
+ (m? 0 : K_FLAG_IMMUTABLE));
+ new_vector->mark = KFALSE;
+ new_vector->sizearray = length;
+
+ return new_vector;
+}
+
+TValue kvector_new_sf(klisp_State *K, uint32_t length, TValue fill)
+{
+ Vector *v = kvector_alloc(K, true, length);
+ for (int i = 0; i < length; i++)
+ v->array[i] = fill;
+ return gc2vector(v);
+}
+
+TValue kvector_new_bs_g(klisp_State *K, bool m,
+ const TValue *buf, uint32_t length)
+{
+ Vector *v = kvector_alloc(K, m, length);
+ memcpy(v->array, buf, sizeof(TValue) * length);
+ return gc2vector(v);
+}
+
+bool kvectorp(TValue obj)
+{
+ return ttisvector(obj);
+}
+
+bool kimmutable_vectorp(TValue obj)
+{
+ return ttisvector(obj) && kis_immutable(obj);
+}
+
+bool kmutable_vectorp(TValue obj)
+{
+ return ttisvector(obj) && kis_mutable(obj);
+}
diff --git a/src/kvector.h b/src/kvector.h
@@ -0,0 +1,34 @@
+/*
+** kvector.h
+** Kernel Vectors (heterogenous arrays)
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kvector_h
+#define kvector_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/* constructors */
+
+TValue kvector_new_sf(klisp_State *K, uint32_t length, TValue fill);
+TValue kvector_new_bs_g(klisp_State *K, bool m,
+ const TValue *buf, uint32_t length);
+
+/* predicates */
+
+bool kvectorp(TValue obj);
+bool kimmutable_vectorp(TValue obj);
+bool kmutable_vectorp(TValue obj);
+
+/* some macros to access the parts of vectors */
+
+#define kvector_array(tv_) (tv2vector(tv_)->array)
+#define kvector_length(tv_) (tv2vector(tv_)->sizearray)
+
+#define kvector_emptyp(tv_) (kvector_length(tv_) == 0)
+#define kvector_mutablep(tv_) (kis_mutable(tv_))
+#define kvector_immutablep(tv_) (kis_immutable(tv_))
+
+#endif
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -25,6 +25,7 @@
#include "kport.h"
#include "kenvironment.h"
#include "kbytevector.h"
+#include "kvector.h"
/*
** Stack for the write FSM
@@ -509,6 +510,15 @@ void kwrite_simple(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TVECTOR:
+ kw_printf(K, "#[vector");
+ #if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+ #endif
+ kw_printf(K, "]");
+ break;
default:
/* shouldn't happen */
kwrite_error(K, "unknown object type");
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -24,5 +24,6 @@
(load "tests/memory-ports.k")
(load "tests/error.k")
(load "tests/bytevectors.k")
+(load "tests/vectors.k")
(check-report)
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of vector (heterogenous array) features.
+;;
+
+;; (R7RS 3rd draft 6.3.6) vector?
+
+($check-predicate (applicative? vector?))
+($check-predicate (vector?))
+($check-predicate (vector? (make-vector 0)))
+($check-predicate (vector? (make-vector 1)))
+
+($check-not-predicate (vector? 0))
+($check-not-predicate (vector? ""))
+($check-not-predicate (vector? ()))
+($check-not-predicate (vector? (make-bytevector 0)))
+($check-not-predicate (vector? (make-bytevector 1)))
+
+;; XXX immutable-vector? mutable-vector?
+
+($check-predicate (applicative? immutable-vector? mutable-vector?))
+
+($check-predicate (immutable-vector?))
+($check-predicate (immutable-vector? (make-vector 0)))
+($check-not-predicate (immutable-vector? (make-vector 1)))
+($check-not-predicate (immutable-vector? (make-bytevector 0)))
+
+($check-predicate (mutable-vector?))
+($check-predicate (mutable-vector? (make-vector 1)))
+($check-not-predicate (mutable-vector? (make-vector 0)))
+($check-not-predicate (mutable-vector? (make-bytevector 1)))
+
+;; (R7RS 3rd draft, section 6.3.6) make-vector vector-length
+
+($check-predicate (applicative? make-vector vector-length))
+($check equal? (vector-length (make-vector 0)) 0)
+($check equal? (vector-length (make-vector 0 "value")) 0)
+($check equal? (vector-length (make-vector 1)) 1)
+($check equal? (vector-length (make-vector 1 (list 1 2 3))) 1)
+($check equal? (vector-length (make-vector 8192)) 8192)
+
+;; (R7RS 3rd draft, section 6.3.6) vector
+
+($check-predicate (applicative? vector?))
+($check-predicate (vector? (vector)))
+($check-predicate (immutable-vector? (vector)))
+($check equal? (vector-length (vector)) 0)
+($check-predicate (mutable-vector? (vector "x" "y")))
+($check equal? (vector-length (vector "x" "y")) 2)
+
+;; (R7RS 3rd draft, section 6.3.6) vector-ref
+
+($check-predicate (applicative? vector-ref))
+($check equal? (vector-ref (make-vector 10 #t) 1) #t)
+($check equal? (vector-ref (make-vector 10 "abc") 5) "abc")
+($check equal? (vector-ref (make-vector 10 1/2) 9) 1/2)
+($check equal? (vector-ref (vector 1/2 1/3 1/4) 2) 1/4)
+
+;; (R7RS 3rd draft, section 6.3.6) vector-set!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+
+($check-predicate (applicative? vector-set!))
+
+($let*
+ ((v (make-vector 10))
+ (w (vector->immutable-vector v)))
+ ($check equal? (vector-set! v 0 1) #inert)
+ ($check equal? (vector-ref v 0) 1)
+ ($check equal? (vector-set! v 0 "abc") #inert)
+ ($check equal? (vector-ref v 0) "abc")
+ ($check equal? (vector-set! v 6 v) #inert)
+ ($check equal? (vector-ref v 0) "abc")
+ ($check eq? (vector-ref v 6) v)
+ ($check-error (vector-ref v -1))
+ ($check-error (vector-ref v 10))
+ ($check-error (vector-ref v 12345))
+ ($check-error (vector-set! v -1 0))
+ ($check-error (vector-set! v 10 1/2))
+ ($check-error (vector-set! w 0 #t)))
+
+;; (R7RS 3rd draft, section 6.3.6) list->vector, vector->list
+
+($check-predicate (applicative? list->vector))
+($check-predicate (immutable-vector? (list->vector ())))
+($check-predicate (mutable-vector? (list->vector (list "a" "b"))))
+
+;; (R7RS 3rd draft, section 6.3.6) vector-copy
+;; TODO: implement equal? for vectors first
+
+;; XXX bytevector->immutable-bytevector
+
+($check-predicate (applicative? bytevector->immutable-bytevector))
+
+($check-predicate
+ (immutable-vector? (vector->immutable-vector (vector 1 2))))
+($check-not-predicate
+ (mutable-vector? (vector->immutable-vector (vector 1 2))))
