commit 4334d29f126a24d21444006f0de2739708b5e63d
parent a1ca4a6a0cbdbcfb8a78abf45226e2553cdd0615
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 19 Apr 2011 18:30:12 -0300
Added immutable strings. Added string->immutable-string to the ground environment. symbol->string now returns the immutable string that is inside the symbol obj with no copying overhead. PENDING: interning of strings to make eq? work correctly on immutable strings. USE hashtable with weak keys.
Diffstat:
14 files changed, 128 insertions(+), 70 deletions(-)
diff --git a/src/kerror.c b/src/kerror.c
@@ -33,7 +33,7 @@ void clear_buffers(klisp_State *K)
void klispE_throw(klisp_State *K, char *msg)
{
- TValue error_msg = kstring_new(K, msg, strlen(msg));
+ TValue error_msg = kstring_new_b_imm(K, msg);
/* TEMP */
clear_buffers(K);
@@ -53,7 +53,7 @@ void klispE_throw_extra(klisp_State *K, char *msg, char *extra_msg) {
strcpy(msg_buf+l1, extra_msg);
/* if the mem allocator could throw errors, this
could potentially leak msg_buf */
- TValue error_msg = kstring_new(K, msg_buf, tl);
+ TValue error_msg = kstring_new_bs_imm(K, msg_buf, tl);
klispM_freemem(K, msg_buf, tl);
clear_buffers(K);
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -181,7 +181,7 @@ 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
diff --git a/src/kground.c b/src/kground.c
@@ -807,7 +807,13 @@ void kinit_ground_env(klisp_State *K)
/* 13.2.8? string-copy */
add_applicative(K, ground_env, "string-copy", string_copy, 0);
- /* 13.2.9? string-fill! */
+ /* 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? */
+
+ /* 13.2.10? string-fill! */
add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
/*
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -49,7 +49,7 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
return;
}
- TValue new_str = kstring_new_sc(K, ivalue(tv_s), fill);
+ TValue new_str = kstring_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_str);
}
@@ -102,6 +102,9 @@ void string_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* TODO show index */
klispE_throw(K, "string-set!: index out of bounds");
return;
+ } else if (kstring_immutablep(str)) {
+ klispE_throw(K, "string-set!: immutable string");
+ return;
}
int32_t i = ivalue(tv_i);
@@ -130,7 +133,7 @@ inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
if (pairs == 0) {
return K->empty_string;
} else {
- new_str = kstring_new_g(K, pairs);
+ new_str = kstring_new_s(K, pairs);
char *buf = kstring_buf(new_str);
TValue tail = ls;
while(pairs--) {
@@ -162,14 +165,9 @@ void string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* Helpers for binary predicates */
/* XXX: this should probably be in file kstring.h */
-bool kstring_eqp(TValue str1, TValue str2)
-{
- int32_t size = kstring_size(str1);
- if (kstring_size(str2) != size)
- return false;
- else
- return ((size == 0) ||
- memcmp(kstring_buf(str1), kstring_buf(str2), size) == 0);
+
+bool kstring_eqp(TValue str1, TValue str2) {
+ return tv_equal(str1, str2) || kstring_equalp(str1, str2);
}
bool kstring_ci_eqp(TValue str1, TValue str2)
@@ -241,6 +239,7 @@ bool kstring_ci_gep(TValue str1, TValue str2)
}
/* 13.2.5? substring */
+/* TEMP: at least for now this always returns mutable strings */
void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -278,12 +277,13 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (size == 0) {
new_str = K->empty_string;
} else {
- new_str = kstring_new(K, kstring_buf(str)+start, size);
+ new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
/* 13.2.6? string-append */
+/* TEMP: at least for now this always returns mutable strings */
/* TEMP: this does 3 passes over the list */
void string_append(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
@@ -314,7 +314,7 @@ void string_append(klisp_State *K, TValue *xparams, TValue ptree,
if (size == 0) {
new_str = K->empty_string;
} else {
- new_str = kstring_new_g(K, size);
+ new_str = kstring_new_s(K, size);
char *buf = kstring_buf(new_str);
/* loop again to copy the chars of each string */
tail = ptree;
@@ -369,6 +369,7 @@ void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 13.2.8? string-copy */
+/* TEMP: at least for now this always returns mutable strings */
void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -380,12 +381,29 @@ void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (tv_equal(str, K->empty_string)) {
new_str = str;
} else {
- new_str = kstring_new(K, kstring_buf(str), kstring_size(str));
+ new_str = kstring_new_bs(K, kstring_buf(str), kstring_size(str));
}
kapply_cc(K, new_str);
}
-/* 13.2.9? string-fill! */
+/* 13.2.9? string->immutable-string */
+void string_to_immutable_string(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, "string->immutable-string", ptree, "string", ttisstring, str);
+
+ TValue res_str;
+ if (kstring_immutablep(str)) {/* this includes the empty list */
+ res_str = str;
+ } else {
+ res_str = kstring_new_bs_imm(K, kstring_buf(str), kstring_size(str));
+ }
+ kapply_cc(K, res_str);
+}
+
+/* 13.2.10? string-fill! */
void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -393,22 +411,26 @@ void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2tp(K, "string-fill!", ptree, "string", ttisstring, str,
"char", ttischar, tv_ch);
+ if (kstring_immutablep(str)) {
+ klispE_throw(K, "string-fill!: immutable string");
+ return;
+ }
+
memset(kstring_buf(str), chvalue(tv_ch), kstring_size(str));
kapply_cc(K, KINERT);
}
/* 13.3.1? symbol->string */
-/* TEMP: for now all strings are mutable, this returns a new object
- each time */
+/* The strings in symbols are immutable so we can just return that */
void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, "symbol->string", ptree, "symbol", ttissymbol, sym);
- TValue new_str = kstring_new(K, ksymbol_buf(sym), ksymbol_size(sym));
- kapply_cc(K, new_str);
+ TValue str = ksymbol_str(sym);
+ kapply_cc(K, str);
}
/* 13.3.2? string->symbol */
@@ -421,6 +443,7 @@ void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
because the report only says that read objects when written and read
again must be equal? which happens here
*/
+/* If the string is mutable it is copied */
void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -78,12 +78,14 @@ void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
/* 13.2.8? string-copy */
void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-/* 13.2.9? string-fill! */
+/* 13.2.9? string->immutable-string */
+void string_to_immutable_string(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv);
+
+/* 13.2.10? string-fill! */
void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 13.3.1? symbol->string */
-/* TEMP: for now all strings are mutable, this returns a new object
- each time */
void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
diff --git a/src/kobject.h b/src/kobject.h
@@ -627,6 +627,7 @@ int32_t kmark_count;
#define kis_unmarked(p_) (tv_equal(kget_mark(p_), KFALSE))
/* Macros to access kflags & type in GCHeader */
+/* TODO: 1 should always be reserved for mutability flag */
#define gch_get_type(o_) (obj2gch(o_)->tt)
#define gch_get_kflags(o_) (obj2gch(o_)->kflags)
#define tv_get_kflags(o_) (gch_get_kflags(tv2gch(o_)))
@@ -653,6 +654,7 @@ int32_t kmark_count;
#define kis_dyn_cont(c_) ((tv_get_kflags(c_) & K_FLAG_DYNAMIC) != 0)
#define kis_bool_check_cont(c_) ((tv_get_kflags(c_) & K_FLAG_BOOL_CHECK) != 0)
+/* for now only used in pairs and strings */
#define K_FLAG_IMMUTABLE 0x01
#define kis_mutable(o_) ((tv_get_kflags(o_) & K_FLAG_IMMUTABLE) == 0)
#define kis_immutable(o_) (!kis_mutable(o_))
@@ -671,6 +673,7 @@ int32_t kmark_count;
#define K_FLAG_WEAK_KEYS 0x01
#define K_FLAG_WEAK_VALUES 0x02
+#define K_FLAG_WEAK_NOTHING 0x00
#define ktable_has_weak_keys(o_) \
((tv_get_kflags(o_) & K_FLAG_WEAK_KEYS) != 0)
diff --git a/src/kread.c b/src/kread.c
@@ -4,15 +4,6 @@
** See Copyright Notice in klisp.h
*/
-
-/*
-** TODO:
-**
-** - Read mutable/immutable objects (cons function should be a parameter)
-** this is needed because some functions (like load) return immutable objs
-**
-*/
-
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
diff --git a/src/kstate.c b/src/kstate.c
@@ -161,9 +161,9 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->sbuf = (TValue *)s;
/* the dynamic ports and the keys for the dynamic ports */
- TValue in_port = kmake_std_port(K, kstring_new_ns(K, "*STDIN*"),
+ TValue in_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDIN*"),
false, KNIL, KNIL, stdin);
- TValue out_port = kmake_std_port(K, kstring_new_ns(K, "*STDOUT*"),
+ TValue out_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDOUT*"),
true, KNIL, KNIL, stdout);
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
diff --git a/src/kstring.c b/src/kstring.c
@@ -13,7 +13,7 @@
#include "kmem.h"
#include "kgc.h"
-/* TEMP: this is for initializing the above value, for now, from ktoken.h */
+/* TEMP: this is for initializing the above value */
TValue kstring_new_empty(klisp_State *K)
{
String *new_str;
@@ -21,7 +21,7 @@ TValue kstring_new_empty(klisp_State *K)
new_str = klispM_malloc(K, sizeof(String) + 1);
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
+ klispC_link(K, (GCObject *) new_str, K_TSTRING, K_FLAG_IMMUTABLE);
/* string specific fields */
new_str->mark = KFALSE;
@@ -31,8 +31,8 @@ TValue kstring_new_empty(klisp_State *K)
return gc2str(new_str);
}
-/* TEMP: for now all strings are mutable */
-TValue kstring_new_g(klisp_State *K, uint32_t size)
+/* with just size */
+TValue kstring_new_s_g(klisp_State *K, bool m, uint32_t size)
{
String *new_str;
@@ -43,7 +43,8 @@ TValue kstring_new_g(klisp_State *K, uint32_t size)
new_str = klispM_malloc(K, sizeof(String) + size + 1);
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
+ klispC_link(K, (GCObject *) new_str, K_TSTRING,
+ m? 0 : K_FLAG_IMMUTABLE);
/* string specific fields */
new_str->mark = KFALSE;
@@ -58,34 +59,39 @@ TValue kstring_new_g(klisp_State *K, uint32_t size)
return gc2str(new_str);
}
-TValue kstring_new(klisp_State *K, const char *buf, uint32_t size)
+/* with buffer & size */
+TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf, uint32_t size)
{
- TValue new_str = kstring_new_g(K, size);
+ TValue new_str = kstring_new_s_g(K, m, size);
memcpy(kstring_buf(new_str), buf, size);
return new_str;
}
-/* with no size, no embedded '\0's */
-TValue kstring_new_ns(klisp_State *K, const char *buf)
+/* with buffer but no size, no embedded '\0's */
+TValue kstring_new_b_g(klisp_State *K, bool m, const char *buf)
{
- return (kstring_new(K, buf, strlen(buf)));
+ return (kstring_new_bs_g(K, m, buf, strlen(buf)));
}
-TValue kstring_new_sc(klisp_State *K, uint32_t size, char fill)
+/* with size and fill char */
+TValue kstring_new_sf_g(klisp_State *K, bool m, uint32_t size, char fill)
{
- TValue new_str = kstring_new_g(K, size);
+ TValue new_str = kstring_new_s_g(K, m, size);
memset(kstring_buf(new_str), fill, size);
return new_str;
}
-/* both obj1 and obj2 should be strings! */
+/* both obj1 and obj2 should be strings */
bool kstring_equalp(TValue obj1, TValue obj2)
{
+ klisp_assert(ttisstring(obj1) && ttisstring(obj2));
+
String *str1 = tv2str(obj1);
String *str2 = tv2str(obj2);
if (str1->size == str2->size) {
- return (memcmp(str1->b, str2->b, str1->size) == 0);
+ return (str1->size == 0) ||
+ (memcmp(str1->b, str2->b, str1->size) == 0);
} else {
return false;
}
diff --git a/src/kstring.h b/src/kstring.h
@@ -12,21 +12,47 @@
#include "kobject.h"
#include "kstate.h"
-/* TEMP: for now all strings are mutable */
-
+/* used for initialization */
TValue kstring_new_empty(klisp_State *K);
-TValue kstring_new(klisp_State *K, const char *buf, uint32_t size);
-/* with no size, no embedded '\0's */
-TValue kstring_new_ns(klisp_State *K, const char *buf);
-TValue kstring_new_g(klisp_State *K, uint32_t size);
-TValue kstring_new_sc(klisp_State *K, uint32_t size, char fill);
-
+/* general string constructor, buf remains uninit
+ (except for an extra trailing zero used for printing */
+TValue kstring_new_s_g(klisp_State *K, bool m, uint32_t size);
+/* with buffer & size */
+TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf, uint32_t size);
+/* with buffer but no size, no embedded '\0's */
+TValue kstring_new_b_g(klisp_State *K, bool m, const char *buf);
+/* with size & fill char */
+TValue kstring_new_sf_g(klisp_State *K, bool m, uint32_t size, char fill);
+
+/* macros for mutable & immutable versions of the above */
+#define kstring_new_s(K_, size_) \
+ kstring_new_s_g(K_, true, size_)
+#define kstring_new_bs(K_, buf_, size_) \
+ kstring_new_bs_g(K_, true, buf_, size_)
+#define kstring_new_b(K_, buf_) \
+ kstring_new_b_g(K_, true, buf_)
+#define kstring_new_sf(K_, size_, fill_) \
+ kstring_new_sf_g(K_, true, size_, fill_)
+
+#define kstring_new_s_imm(K_, size_) \
+ kstring_new_s_g(K_, false, size_)
+#define kstring_new_bs_imm(K_, buf_, size_) \
+ kstring_new_bs_g(K_, false, buf_, size_)
+#define kstring_new_b_imm(K_, buf_) \
+ kstring_new_b_g(K_, false, buf_)
+#define kstring_new_sf_imm(K_, size_, fill_) \
+ kstring_new_sf_g(K_, false, size_, fill_)
+
+/* some macros to access the parts of the string */
#define kstring_buf(tv_) (tv2str(tv_)->b)
#define kstring_size(tv_) (tv2str(tv_)->size)
-#define kstring_is_empty(tv_) (kstring_size(tv_) == 0)
+#define kstring_emptyp(tv_) (kstring_size(tv_) == 0)
+#define kstring_mutablep(tv_) (kis_mutable(tv_))
+#define kstring_immutablep(tv_) (kis_immutable(tv_))
-/* both obj1 and obj2 should be strings! */
+/* both obj1 and obj2 should be strings, this compares char by char
+ but differentiates immutable from mutable strings */
bool kstring_equalp(TValue obj1, TValue obj2);
#endif
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -33,10 +33,8 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
tbl = kcdr(tbl);
}
- /* Didn't find it, alloc new string and save in symbol table */
- /* NOTE: there are no embedded '\0's in symbols */
- /* GC: root new_str */
- TValue new_str = kstring_new(K, buf, size); /* this copies the buf */
+ /* Didn't find it, alloc new immutable string and save in symbol table */
+ TValue new_str = kstring_new_bs_imm(K, buf, size);
krooted_tvs_push(K, new_str);
Symbol *new_sym = klispM_new(K, Symbol);
krooted_tvs_pop(K);
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -17,9 +17,10 @@
TValue ksymbol_new_i(klisp_State *K, const char *buf, int32_t size);
/* For identifiers, simplified for unknown size */
TValue ksymbol_new(klisp_State *K, const char *buf);
-/* For general strings */
+/* For general strings, copies str if not immutable */
TValue ksymbol_new_check_i(klisp_State *K, TValue str);
+#define ksymbol_str(tv_) (tv2sym(tv_)->str)
#define ksymbol_buf(tv_) (kstring_buf(tv2sym(tv_)->str))
#define ksymbol_size(tv_) (kstring_size(tv2sym(tv_)->str))
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -188,8 +188,7 @@ TValue ktok_get_source_info(klisp_State *K)
{
/* NOTE: the filename doesn't contains embedded '\0's */
TValue filename_str =
- kstring_new(K, K->ktok_source_info.saved_filename,
- strlen(K->ktok_source_info.saved_filename));
+ kstring_new_b_imm(K, K->ktok_source_info.saved_filename);
krooted_tvs_push(K, filename_str);
/* TEMP: for now, lines and column names are fixints */
TValue res = kcons(K, i2tv(K->ktok_source_info.saved_line),
@@ -521,7 +520,10 @@ TValue ktok_read_string(klisp_State *K)
i++;
}
}
- TValue new_str = kstring_new(K, ks_tbget_buffer(K), i);
+ /* TEMP: for now strings "read" are mutable but strings "loaded" are
+ not */
+ TValue new_str = kstring_new_bs_g(K, K->read_mconsp,
+ ks_tbget_buffer(K), i);
krooted_tvs_push(K, new_str);
ks_tbclear(K); /* shouldn't cause gc, but still */
krooted_tvs_pop(K);
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -44,7 +44,7 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
((kbigint_negativep(bigint))? 1 : 0);
krooted_tvs_push(K, bigint);
- TValue buf_str = kstring_new_g(K, size);
+ TValue buf_str = kstring_new_s(K, size);
krooted_tvs_push(K, buf_str);
/* write backwards so we can use printf later */
@@ -338,7 +338,7 @@ void kwrite_fsm(klisp_State *K, TValue obj)
break;
}
case K_TSTRING: {
- if (kstring_is_empty(obj)) {
+ if (kstring_emptyp(obj)) {
kw_printf(K, "\"\"");
} else {
TValue mark = kget_mark(obj);
