commit 21cd8de4d55864ec3a380dfa1a8a85c459dcb154
parent 12e79d94e0fee73b63217e42ec2993c8296b2339
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 27 Nov 2011 20:26:22 -0300
Added char-digit?, char->digit, and digit->char to the ground environment.
Diffstat:
6 files changed, 180 insertions(+), 18 deletions(-)
diff --git a/TODO b/TODO
@@ -16,12 +16,12 @@
functions in kghelpers
** check if all inline functions need to be inline
* fix:
-** fix some inconsistencies between the man page and the interpreter
- behaviour.
** fix/test the tty detection in the interpreter
** current-jiffy (r7rs)
** jiffies-per-second (r7rs)
* documentation
+** fix some inconsistencies between the man page and the interpreter
+ behaviour.
** update the manual with the current features
** add a section to the manual with the interpreter usaged
* operatives:
diff --git a/src/kchar.c b/src/kchar.c
@@ -15,3 +15,26 @@ bool kchar_numericp(TValue ch) { return isdigit(chvalue(ch)) != 0; }
bool kchar_whitespacep(TValue ch) { return isspace(chvalue(ch)) != 0; }
bool kchar_upper_casep(TValue ch) { return isupper(chvalue(ch)) != 0; }
bool kchar_lower_casep(TValue ch) { return islower(chvalue(ch)) != 0; }
+
+/* Helpers for binary typed predicates */
+bool kchar_eqp(TValue ch1, TValue ch2) { return chvalue(ch1) == chvalue(ch2); }
+bool kchar_ltp(TValue ch1, TValue ch2) { return chvalue(ch1) < chvalue(ch2); }
+bool kchar_lep(TValue ch1, TValue ch2) { return chvalue(ch1) <= chvalue(ch2); }
+bool kchar_gtp(TValue ch1, TValue ch2) { return chvalue(ch1) > chvalue(ch2); }
+bool kchar_gep(TValue ch1, TValue ch2) { return chvalue(ch1) >= chvalue(ch2); }
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) == tolower(chvalue(ch2)); }
+
+bool kchar_ci_ltp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) < tolower(chvalue(ch2)); }
+
+bool kchar_ci_lep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) <= tolower(chvalue(ch2)); }
+
+bool kchar_ci_gtp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) > tolower(chvalue(ch2)); }
+
+bool kchar_ci_gep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+
diff --git a/src/kchar.h b/src/kchar.h
@@ -18,5 +18,17 @@ bool kchar_numericp(TValue ch);
bool kchar_whitespacep(TValue ch);
bool kchar_upper_casep(TValue ch);
bool kchar_lower_casep(TValue ch);
+/* Helpers for binary typed predicates */
+bool kchar_eqp(TValue ch1, TValue ch2);
+bool kchar_ltp(TValue ch1, TValue ch2);
+bool kchar_lep(TValue ch1, TValue ch2);
+bool kchar_gtp(TValue ch1, TValue ch2);
+bool kchar_gep(TValue ch1, TValue ch2);
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2);
+bool kchar_ci_ltp(TValue ch1, TValue ch2);
+bool kchar_ci_lep(TValue ch1, TValue ch2);
+bool kchar_ci_gtp(TValue ch1, TValue ch2);
+bool kchar_ci_gep(TValue ch1, TValue ch2);
#endif
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -99,27 +99,89 @@ void kchar_change_case(klisp_State *K)
/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
/* use ftyped_bpredp */
-/* Helpers for binary typed predicates */
-bool kchar_eqp(TValue ch1, TValue ch2) { return chvalue(ch1) == chvalue(ch2); }
-bool kchar_ltp(TValue ch1, TValue ch2) { return chvalue(ch1) < chvalue(ch2); }
-bool kchar_lep(TValue ch1, TValue ch2) { return chvalue(ch1) <= chvalue(ch2); }
-bool kchar_gtp(TValue ch1, TValue ch2) { return chvalue(ch1) > chvalue(ch2); }
-bool kchar_gep(TValue ch1, TValue ch2) { return chvalue(ch1) >= chvalue(ch2); }
+/* 14.2.? char-digit?, char->digit, digit->char */
+void char_digitp(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
+ UNUSED(xparams);
+ bind_al1tp(K, ptree, "character", ttischar, chtv, basetv);
+
+ int base = 10; /* default */
+
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
+ char ch = tolower(chvalue(chtv));
+ bool b = (isdigit(ch) && (ch - '0') < base) ||
+ (isalpha(ch) && (ch - 'a' + 10) < base);
+ kapply_cc(K, b2tv(b));
+}
+
+void char_to_digit(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
+ UNUSED(xparams);
+ bind_al1tp(K, ptree, "character", ttischar, chtv, basetv);
+
+ int base = 10; /* default */
+
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
+ char ch = tolower(chvalue(chtv));
+ int digit = 0;
+
+ if (isdigit(ch) && (ch - '0') < base)
+ digit = ch - '0';
+ else if (isalpha(ch) && (ch - 'a' + 10) < base)
+ digit = ch - 'a' + 10;
+ else {
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, ch2tv(ch), i2tv(base));
+ return;
+ }
+ kapply_cc(K, i2tv(digit));
+}
-bool kchar_ci_eqp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) == tolower(chvalue(ch2)); }
+void digit_to_char(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
-bool kchar_ci_ltp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) < tolower(chvalue(ch2)); }
+ UNUSED(denv);
+ UNUSED(xparams);
+ bind_al1tp(K, ptree, "exact integer", ttiseinteger, digittv, basetv);
-bool kchar_ci_lep(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) <= tolower(chvalue(ch2)); }
+ int base = 10; /* default */
-bool kchar_ci_gtp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) > tolower(chvalue(ch2)); }
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
-bool kchar_ci_gep(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+ if (ttisbigint(digittv) || ivalue(digittv) < 0 ||
+ ivalue(digittv) >= base) {
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, digittv, i2tv(base));
+ return;
+ }
+ int digit = ivalue(digittv);
+ char ch = digit <= 9?
+ '0' + digit :
+ 'a' + (digit - 10);
+ kapply_cc(K, ch2tv(ch));
+}
/* init ground */
void kinit_chars_ground_env(klisp_State *K)
@@ -189,4 +251,8 @@ void kinit_chars_ground_env(klisp_State *K)
symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
+ /* 14.2.? char-digit?, char->digit, digit->char */
+ add_applicative(K, ground_env, "char-digit?", char_digitp, 0);
+ add_applicative(K, ground_env, "char->digit", char_to_digit, 0);
+ add_applicative(K, ground_env, "digit->char", digit_to_char, 0);
}
diff --git a/src/kobject.h b/src/kobject.h
@@ -244,9 +244,14 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisbigint(o) (tbasetype_(o) == K_TAG_BIGINT)
#define ttiseinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
+/* for items in bytevectors */
#define ttisu8(o) ({ \
TValue o__ = (o); \
(ttisfixint(o__) && ivalue(o__) >= 0 && ivalue(o__) < 256); })
+/* for bases in char->digit and related functions */
+#define ttisbase(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && ivalue(o__) >= 2 && ivalue(o__) <= 36); })
#define ttisinteger(o) ({ TValue o__ = (o); \
(ttiseinteger(o__) || \
(ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -105,3 +105,59 @@
($check equal? (integer->char #x30) #\0)
($check equal? (integer->char #x41) #\A)
($check equal? (integer->char #x61) #\a)
+
+;; XXX char-digit?
+($check-predicate (char-digit? #\0))
+($check-predicate (char-digit? #\9))
+($check-not-predicate (char-digit? #\a))
+($check-not-predicate (char-digit? #\2 2))
+($check-predicate (char-digit? #\f 16))
+($check-predicate (char-digit? #\F 16))
+($check-not-predicate (char-digit? #\!))
+
+;; errors
+
+($check-error (char-digit?))
+($check-error (char-digit? 12))
+($check-error (char-digit? #\9 10 #\a))
+($check-error (char-digit? #\9 10 10))
+($check-error (char-digit? #\0 1))
+($check-error (char-digit? #\0 0))
+($check-error (char-digit? #\0 -1))
+($check-error (char-digit? #\0 37))
+
+;; XXX char->digit
+($check =? (char->digit #\0) 0)
+($check =? (char->digit #\9) 9)
+($check =? (char->digit #\f 16) 15)
+($check =? (char->digit #\F 16) 15)
+($check =? (char->digit #\z 36) 35)
+($check =? (char->digit #\Z 36) 35)
+
+;; errors
+($check-error (char->digit))
+($check-error (char->digit 0))
+($check-error (char->digit #\0 10 10))
+($check-error (char->digit #\0 1))
+($check-error (char->digit #\0 37))
+($check-error (char->digit #\0 0))
+($check-error (char->digit #\0 -1))
+($check-error (char->digit #\a 10))
+($check-error (char->digit #\2 2))
+
+;; XXX digit->char
+($check char=? (digit->char 0) #\0)
+($check char=? (digit->char 9) #\9)
+($check char=? (char-downcase (digit->char 15 16)) #\f)
+($check char=? (char-downcase (digit->char 35 36)) #\z)
+
+;; errors
+($check-error (digit->char))
+($check-error (digit->char #\0))
+($check-error (digit->char 0 10 10))
+($check-error (digit->char 0 1))
+($check-error (digit->char 0 37))
+($check-error (digit->char 0 0))
+($check-error (digit->char 0 -1))
+($check-error (digit->char 10 10))
+($check-error (digit->char 2 2))
