klisp

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

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:
Msrc/Makefile | 34++++++++++++++++++++--------------
Msrc/kgc.c | 12++++++++++++
Msrc/kgequalp.c | 3+++
Msrc/kghelpers.c | 2+-
Msrc/kghelpers.h | 2+-
Msrc/kground.c | 2++
Asrc/kgvectors.c | 244+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kgvectors.h | 15+++++++++++++++
Msrc/kobject.h | 15++++++++++++++-
Msrc/kstate.c | 5+++++
Msrc/kstate.h | 4++++
Asrc/kvector.c | 65+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kvector.h | 34++++++++++++++++++++++++++++++++++
Msrc/kwrite.c | 10++++++++++
Msrc/tests/test-all.k | 1+
Asrc/tests/vectors.k | 98+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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))))