commit e080606786e9e9851804c35ffdb664cf97e1204c
parent 4f96b63781f5cc69c48cbdb6a0c58d87d29526a0
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 16 Nov 2011 21:50:41 -0300
Added [immutable/mutable]-[pair/string/bytevector]? to the ground environment. Temporary fix to eq? for immutable bytevector (should probably intern).
Diffstat:
13 files changed, 77 insertions(+), 9 deletions(-)
diff --git a/src/kbytevector.c b/src/kbytevector.c
@@ -130,3 +130,11 @@ bool kbytevector_equalp(TValue obj1, TValue obj2)
}
bool kbytevectorp(TValue obj) { return ttisbytevector(obj); }
+bool kimmutable_bytevectorp(TValue obj)
+{
+ return ttisbytevector(obj) && kis_immutable(obj);
+}
+bool kmutable_bytevectorp(TValue obj)
+{
+ return ttisbytevector(obj) && kis_mutable(obj);
+}
diff --git a/src/kbytevector.h b/src/kbytevector.h
@@ -39,7 +39,9 @@ TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill);
/* both obj1 and obj2 should be bytevectors, this compares byte by byte
and doesn't differentiate immutable from mutable bytevectors */
bool kbytevector_equalp(TValue obj1, TValue obj2);
-bool kbytevector(TValue obj);
+bool kbytevectorp(TValue obj);
+bool kimmutable_bytevectorp(TValue obj);
+bool kmutable_bytevectorp(TValue obj);
/* some macros to access the parts of the bytevectors */
#define kbytevector_buf(tv_) (tv2bytevector(tv_)->b)
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -26,6 +26,9 @@
/* 13.1.1? bytevector? */
/* uses typep */
+/* 13.? immutable-bytevector?, mutable-bytevector? */
+/* use ftypep */
+
/* 13.1.2? make-bytevector */
void make_bytevector(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
@@ -318,6 +321,11 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.1.1? bytevector? */
add_applicative(K, ground_env, "bytevector?", typep, 2, symbol,
i2tv(K_TBYTEVECTOR));
+ /* ??.? immutable-bytevector?, mutable-bytevector? */
+ add_applicative(K, ground_env, "immutable-bytevector?", ftypep, 2, symbol,
+ p2tv(kimmutable_bytevectorp));
+ add_applicative(K, ground_env, "mutable-bytevector?", ftypep, 2, symbol,
+ p2tv(kmutable_bytevectorp));
/* ??.1.2? make-bytevector */
add_applicative(K, ground_env, "make-bytevector", make_bytevector, 0);
/* ??.1.3? bytevector-length */
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -20,6 +20,7 @@
#include "krational.h" /* for kbigrat_eqp */
#include "klisp.h"
#include "kghelpers.h"
+#include "kbytevector.h" /* temp until interned, for kbytevector_equalp */
/* 4.2.1 eq? */
/* 6.5.1 eq? */
@@ -28,8 +29,8 @@ void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* Helper (also used in equal?) */
inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
{
- /* TODO/FIXME: immutable bytevectors aren't interned and so will compare
- as un-eq? even if the contents are the same */
+ /* MAYBE: immutable bytevectors aren't interned and so we have to compare
+ them everytime, maybe we should intern them */
bool res = (tv_equal(obj1, obj2));
if (!res && (ttype(obj1) == ttype(obj2))) {
switch (ttype(obj1)) {
@@ -56,7 +57,14 @@ inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
(eq? obj1 obj2) */
res = kbigrat_eqp(K, obj1, obj2);
break;
+ case K_TBYTEVECTOR:
+ if (kbytevector_immutablep(obj1) && kbytevector_immutablep(obj2))
+ res = kbytevector_equalp(obj1, obj2);
+ else
+ res = false;
+ break;
} /* immutable strings are interned so are covered already */
+
}
return res;
}
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -491,6 +491,9 @@ void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
+/* ?.? immutable-pair?, mutable-pair */
+/* use ftypep */
+
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K)
{
@@ -513,4 +516,9 @@ void kinit_pair_mut_ground_env(klisp_State *K)
add_applicative(K, ground_env, "assq", assq, 0);
/* 6.4.3 memq? */
add_applicative(K, ground_env, "memq?", memqp, 0);
+ /* ?.? immutable-pair?, mutable-pair? */
+ add_applicative(K, ground_env, "immutable-pair?", ftypep, 2, symbol,
+ p2tv(kimmutable_pairp));
+ add_applicative(K, ground_env, "mutable-pair?", ftypep, 2, symbol,
+ p2tv(kmutable_pairp));
}
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -51,6 +51,9 @@ void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 6.4.3 memq? */
void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* ?.? immutable-pair?, mutable-pair */
+/* use ftypep */
+
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K);
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -29,6 +29,9 @@
/* 13.1.1? string? */
/* uses typep */
+/* 13.1.? immutable-string?, mutable-string? */
+/* use ftypep */
+
/* 13.1.2? make-string */
void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
@@ -439,6 +442,11 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.1.1? string? */
add_applicative(K, ground_env, "string?", typep, 2, symbol,
i2tv(K_TSTRING));
+ /* 13.? immutable-string?, mutable-string? */
+ add_applicative(K, ground_env, "immutable-string?", ftypep, 2, symbol,
+ p2tv(kimmutable_stringp));
+ add_applicative(K, ground_env, "mutable-string?", ftypep, 2, symbol,
+ p2tv(kmutable_stringp));
/* 13.1.2? make-string */
add_applicative(K, ground_env, "make-string", make_string, 0);
/* 13.1.3? string-length */
@@ -485,7 +493,6 @@ void kinit_strings_ground_env(klisp_State *K)
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! */
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -21,6 +21,9 @@
/* 13.1.1? string? */
/* uses typep */
+/* 13.1.? immutable-string?, mutable-string? */
+/* use ftypep */
+
/* 13.1.2? make-string */
void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/kpair.c b/src/kpair.c
@@ -58,3 +58,11 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...)
bool kpairp(TValue obj) { return ttispair(obj); }
+bool kimmutable_pairp(TValue obj)
+{
+ return ttispair(obj) && kis_immutable(obj);
+}
+bool kmutable_pairp(TValue obj)
+{
+ return ttispair(obj) && kis_mutable(obj);
+}
diff --git a/src/kpair.h b/src/kpair.h
@@ -14,11 +14,8 @@
/* can't be inlined... */
bool kpairp(TValue obj);
-
-inline bool kmutable_pairp(TValue obj)
-{
- return ttispair(obj) && kis_mutable(obj);
-}
+bool kimmutable_pairp(TValue obj);
+bool kmutable_pairp(TValue obj);
inline TValue kcar(TValue p)
{
diff --git a/src/kstring.c b/src/kstring.c
@@ -218,3 +218,11 @@ bool kstring_equalp(TValue obj1, TValue obj2)
}
bool kstringp(TValue obj) { return ttisstring(obj); }
+bool kimmutable_stringp(TValue obj)
+{
+ return ttisstring(obj) && kis_immutable(obj);
+}
+bool kmutable_stringp(TValue obj)
+{
+ return ttisstring(obj) && kis_mutable(obj);
+}
diff --git a/src/kstring.h b/src/kstring.h
@@ -58,5 +58,7 @@ TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill);
and doesn't differentiate immutable from mutable strings */
bool kstring_equalp(TValue obj1, TValue obj2);
bool kstringp(TValue obj);
+bool kimmutable_stringp(TValue obj);
+bool kmutable_stringp(TValue obj);
#endif
diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k
@@ -14,6 +14,9 @@
#inert)
denv)))
+;; mutable-pair?, immutable-pair?, mutable-string? & immutable-string?
+;; were added to the ground environment
+#|
($define! mutable-pair?
($lambda (obj)
($and? (pair? obj)
@@ -46,6 +49,9 @@
($define! immutable-string?
($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj)))))
+|#
+
+($define! nonempty-mutable-string? mutable-string?)
;; XXX/TODO Some of these could be removed if we had eager comprehension in
;; check.k (which would also complete the srfi-78 implementation). The problem
