commit 6430dd969c0003e64ff55b33a29a80ab7f2f7fcd
parent 64b64193bb2de53e4e69ea6bd8e497e9171b3240
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 8 Jul 2011 18:00:34 -0300
Added blob?, make-blob? and blob-length to the ground environment.
Diffstat:
6 files changed, 190 insertions(+), 4 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -34,7 +34,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.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
+ kgstrings.o kgblobs.o
# TEMP: in klisp there is no distinction between core & lib
LIB_O=
@@ -252,3 +252,7 @@ imrat.o: imrat.c imrat.h imath.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kerror.h
kblob.o: kblob.c kblob.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
+kgblobs.o: kgblobs.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h \
+ kgblobs.h kgnumbers.h
diff --git a/src/kgblobs.c b/src/kgblobs.c
@@ -0,0 +1,148 @@
+/*
+** kgblobs.c
+** Blobs 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 "kblob.h"
+
+#include "kghelpers.h"
+#include "kgblobs.h"
+#include "kgnumbers.h" /* for keintegerp & knegativep */
+
+/* 13.1.1? blob? */
+/* uses typep */
+
+/* 13.1.2? make-blob */
+void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
+ maybe_byte);
+
+ uint8_t fill = 0;
+ if (get_opt_tpar(K, "make-blob", K_TFIXINT, &maybe_byte)) {
+ if (ivalue(maybe_byte) < 0 || ivalue(maybe_byte) > 255) {
+ klispE_throw_simple(K, "bad fill byte");
+ return;
+ }
+ fill = ivalue(maybe_byte);
+ }
+
+ if (knegativep(K, tv_s)) {
+ klispE_throw_simple(K, "negative size");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "size is too big");
+ return;
+ }
+/* XXX/TODO */
+/* TValue new_blob = kblob_new_sf(K, ivalue(tv_s), fill); */
+ TValue new_blob = kblob_new(K, ivalue(tv_s));
+ if (fill != 0) {
+ int s = ivalue(tv_s);
+ uint8_t *ptr = kblob_buf(new_blob);
+ while(s--)
+ *ptr++ = fill;
+ }
+
+ kapply_cc(K, new_blob);
+}
+
+/* 13.1.3? blob-length */
+void blob_length(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "blob", ttisblob, blob);
+
+ TValue res = i2tv(kblob_size(blob));
+ kapply_cc(K, res);
+}
+
+/* init ground */
+void kinit_blobs_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 byte vectors.
+ */
+
+ /* 13.1.1? blob? */
+ add_applicative(K, ground_env, "blob?", typep, 2, symbol,
+ i2tv(K_TBLOB));
+ /* 13.1.2? make-blob */
+ add_applicative(K, ground_env, "make-blob", make_blob, 0);
+ /* 13.1.3? blob-length */
+ add_applicative(K, ground_env, "blob-length", blob_length, 0);
+
+/* TODO put the blob equivalents here */
+#if 0
+ /* 13.1.4? string-ref */
+ add_applicative(K, ground_env, "string-ref", string_ref, 0);
+ /* 13.1.5? string-set! */
+ add_applicative(K, ground_env, "string-set!", string_setS, 0);
+ /* 13.2.1? string */
+ add_applicative(K, ground_env, "string", string, 0);
+ /* 13.2.2? string=?, string-ci=? */
+ add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_eqp));
+ add_applicative(K, ground_env, "string-ci=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
+ /* 13.2.3? string<?, string<=?, string>?, string>=? */
+ add_applicative(K, ground_env, "string<?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ltp));
+ add_applicative(K, ground_env, "string<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_lep));
+ add_applicative(K, ground_env, "string>?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_gtp));
+ add_applicative(K, ground_env, "string>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_gep));
+ /* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
+ add_applicative(K, ground_env, "string-ci<?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
+ add_applicative(K, ground_env, "string-ci<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
+ add_applicative(K, ground_env, "string-ci>?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
+ add_applicative(K, ground_env, "string-ci>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
+ /* 13.2.5? substring */
+ add_applicative(K, ground_env, "substring", substring, 0);
+ /* 13.2.6? string-append */
+ add_applicative(K, ground_env, "string-append", string_append, 0);
+ /* 13.2.7? string->list, list->string */
+ add_applicative(K, ground_env, "string->list", string_to_list, 0);
+ add_applicative(K, ground_env, "list->string", list_to_string, 0);
+ /* 13.2.8? string-copy */
+ add_applicative(K, ground_env, "string-copy", string_copy, 0);
+ /* 13.2.9? string->immutable-string */
+ add_applicative(K, ground_env, "string->immutable-string",
+ string_to_immutable_string, 0);
+
+ /* TODO: add string-immutable? or general immutable? */
+ /* TODO: add string-upcase and string-downcase like in r7rs-draft */
+
+ /* 13.2.10? string-fill! */
+ add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
+#endif
+}
diff --git a/src/kgblobs.h b/src/kgblobs.h
@@ -0,0 +1,34 @@
+/*
+** kgblobs.h
+** Blobs features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgblobs_h
+#define kgblobs_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* ??.1.1? blob? */
+/* uses typep */
+
+/* ??.1.2? make-blob */
+void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* ??.1.3? blob-length */
+void blob_length(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* init ground */
+void kinit_blobs_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -35,6 +35,7 @@
#include "kgstrings.h"
#include "kgchars.h"
#include "kgports.h"
+#include "kgblobs.h"
/* for initing cont names */
#include "ktable.h"
@@ -130,6 +131,7 @@ void kinit_ground_env(klisp_State *K)
kinit_strings_ground_env(K);
kinit_chars_ground_env(K);
kinit_ports_ground_env(K);
+ kinit_blobs_ground_env(K);
/*
** Initialize the names of the continuation used in
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -487,6 +487,4 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.2.10? string-fill! */
add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
-
-
}
diff --git a/src/kobject.h b/src/kobject.h
@@ -487,7 +487,7 @@ typedef struct __attribute__ ((__packed__)) {
TValue mark; /* for cycle/sharing aware algorithms */
uint32_t size;
int32_t __dummy; /* for alignment to 64 bits */
- char b[]; /* buffer */
+ uint8_t b[]; /* buffer */
} Blob;
/*
