kgchars.c (8800B)
1 /* 2 ** kgchars.c 3 ** Characters features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <assert.h> 8 #include <stdio.h> 9 #include <stdlib.h> 10 #include <stdbool.h> 11 #include <stdint.h> 12 #include <ctype.h> 13 14 #include "kstate.h" 15 #include "kobject.h" 16 #include "kapplicative.h" 17 #include "koperative.h" 18 #include "kcontinuation.h" 19 #include "kerror.h" 20 #include "kchar.h" 21 22 #include "kghelpers.h" 23 #include "kgchars.h" 24 25 /* 14.1.1? char? */ 26 /* uses typep */ 27 28 /* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */ 29 /* use ftyped_predp */ 30 31 /* 14.1.3? char-upper-case?, char-lower-case? */ 32 /* use ftyped_predp */ 33 34 /* 14.1.4? char->integer, integer->char */ 35 void kchar_to_integer(klisp_State *K) 36 { 37 TValue *xparams = K->next_xparams; 38 TValue ptree = K->next_value; 39 TValue denv = K->next_env; 40 klisp_assert(ttisenvironment(K->next_env)); 41 UNUSED(xparams); 42 UNUSED(denv); 43 bind_1tp(K, ptree, "character", ttischar, ch); 44 45 kapply_cc(K, i2tv((int32_t) chvalue(ch))); 46 } 47 48 void kinteger_to_char(klisp_State *K) 49 { 50 TValue *xparams = K->next_xparams; 51 TValue ptree = K->next_value; 52 TValue denv = K->next_env; 53 klisp_assert(ttisenvironment(K->next_env)); 54 UNUSED(xparams); 55 UNUSED(denv); 56 bind_1tp(K, ptree, "exact integer", ttiseinteger, itv); 57 58 if (ttisbigint(itv)) { 59 klispE_throw_simple(K, "integer out of ASCII range [0 - 127]"); 60 return; 61 } 62 int32_t i = ivalue(itv); 63 64 /* for now only allow ASCII */ 65 if (i < 0 || i > 127) { 66 klispE_throw_simple(K, "integer out of ASCII range [0 - 127]"); 67 return; 68 } 69 kapply_cc(K, ch2tv((char) i)); 70 } 71 72 /* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */ 73 void kchar_change_case(klisp_State *K) 74 { 75 TValue *xparams = K->next_xparams; 76 TValue ptree = K->next_value; 77 TValue denv = K->next_env; 78 klisp_assert(ttisenvironment(K->next_env)); 79 /* 80 ** xparams[0]: conversion fn 81 */ 82 UNUSED(denv); 83 bind_1tp(K, ptree, "character", ttischar, chtv); 84 char ch = chvalue(chtv); 85 char (*fn)(char) = pvalue(xparams[0]); 86 ch = fn(ch); 87 kapply_cc(K, ch2tv(ch)); 88 } 89 90 /* 14.2.1? char=? */ 91 /* uses ftyped_bpredp */ 92 93 /* 14.2.2? char<?, char<=?, char>?, char>=? */ 94 /* use ftyped_bpredp */ 95 96 /* 14.2.3? char-ci=? */ 97 /* uses ftyped_bpredp */ 98 99 /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */ 100 /* use ftyped_bpredp */ 101 102 /* 14.2.? char-digit?, char->digit, digit->char */ 103 void char_digitp(klisp_State *K) 104 { 105 TValue *xparams = K->next_xparams; 106 TValue ptree = K->next_value; 107 TValue denv = K->next_env; 108 klisp_assert(ttisenvironment(K->next_env)); 109 110 UNUSED(denv); 111 UNUSED(xparams); 112 bind_al1tp(K, ptree, "character", ttischar, chtv, basetv); 113 114 int base = 10; /* default */ 115 116 if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) { 117 base = ivalue(basetv); 118 } 119 char ch = tolower(chvalue(chtv)); 120 bool b = (isdigit(ch) && (ch - '0') < base) || 121 (isalpha(ch) && (ch - 'a' + 10) < base); 122 kapply_cc(K, b2tv(b)); 123 } 124 125 void char_to_digit(klisp_State *K) 126 { 127 TValue *xparams = K->next_xparams; 128 TValue ptree = K->next_value; 129 TValue denv = K->next_env; 130 klisp_assert(ttisenvironment(K->next_env)); 131 132 UNUSED(denv); 133 UNUSED(xparams); 134 bind_al1tp(K, ptree, "character", ttischar, chtv, basetv); 135 136 int base = 10; /* default */ 137 138 if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) { 139 base = ivalue(basetv); 140 } 141 char ch = tolower(chvalue(chtv)); 142 int digit = 0; 143 144 if (isdigit(ch) && (ch - '0') < base) 145 digit = ch - '0'; 146 else if (isalpha(ch) && (ch - 'a' + 10) < base) 147 digit = ch - 'a' + 10; 148 else { 149 klispE_throw_simple_with_irritants(K, "Not a digit in this base", 150 2, ch2tv(ch), i2tv(base)); 151 return; 152 } 153 kapply_cc(K, i2tv(digit)); 154 } 155 156 void digit_to_char(klisp_State *K) 157 { 158 TValue *xparams = K->next_xparams; 159 TValue ptree = K->next_value; 160 TValue denv = K->next_env; 161 klisp_assert(ttisenvironment(K->next_env)); 162 163 UNUSED(denv); 164 UNUSED(xparams); 165 bind_al1tp(K, ptree, "exact integer", ttiseinteger, digittv, basetv); 166 167 int base = 10; /* default */ 168 169 if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) { 170 base = ivalue(basetv); 171 } 172 173 if (ttisbigint(digittv) || ivalue(digittv) < 0 || 174 ivalue(digittv) >= base) { 175 klispE_throw_simple_with_irritants(K, "Not a digit in this base", 176 2, digittv, i2tv(base)); 177 return; 178 } 179 int digit = ivalue(digittv); 180 char ch = digit <= 9? 181 '0' + digit : 182 'a' + (digit - 10); 183 kapply_cc(K, ch2tv(ch)); 184 } 185 186 /* init ground */ 187 void kinit_chars_ground_env(klisp_State *K) 188 { 189 TValue ground_env = G(K)->ground_env; 190 TValue symbol, value; 191 192 /* 193 ** This section is still missing from the report. The bindings here are 194 ** taken from r5rs scheme and should not be considered standard. They are 195 ** provided in the meantime to allow programs to use character features 196 ** (ASCII only). 197 */ 198 199 /* 14.1.1? char? */ 200 add_applicative(K, ground_env, "char?", typep, 2, symbol, 201 i2tv(K_TCHAR)); 202 /* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */ 203 /* unlike in r5rs these take an arbitrary number of chars 204 (even cyclical list) */ 205 add_applicative(K, ground_env, "char-alphabetic?", ftyped_predp, 3, 206 symbol, p2tv(kcharp), p2tv(kchar_alphabeticp)); 207 add_applicative(K, ground_env, "char-numeric?", ftyped_predp, 3, 208 symbol, p2tv(kcharp), p2tv(kchar_numericp)); 209 add_applicative(K, ground_env, "char-whitespace?", ftyped_predp, 3, 210 symbol, p2tv(kcharp), p2tv(kchar_whitespacep)); 211 /* 14.1.3? char-upper-case?, char-lower-case? */ 212 /* unlike in r5rs these take an arbitrary number of chars 213 (even cyclical list) */ 214 add_applicative(K, ground_env, "char-upper-case?", ftyped_predp, 3, 215 symbol, p2tv(kcharp), p2tv(kchar_upper_casep)); 216 add_applicative(K, ground_env, "char-lower-case?", ftyped_predp, 3, 217 symbol, p2tv(kcharp), p2tv(kchar_lower_casep)); 218 add_applicative(K, ground_env, "char-title-case?", ftyped_predp, 3, 219 symbol, p2tv(kcharp), p2tv(kchar_title_casep)); 220 /* 14.1.4? char->integer, integer->char */ 221 add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0); 222 add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0); 223 /* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */ 224 add_applicative(K, ground_env, "char-upcase", kchar_change_case, 1, 225 p2tv(toupper)); 226 add_applicative(K, ground_env, "char-downcase", kchar_change_case, 1, 227 p2tv(tolower)); 228 add_applicative(K, ground_env, "char-titlecase", kchar_change_case, 1, 229 p2tv(toupper)); 230 add_applicative(K, ground_env, "char-foldcase", kchar_change_case, 1, 231 p2tv(tolower)); 232 /* 14.2.1? char=? */ 233 add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3, 234 symbol, p2tv(kcharp), p2tv(kchar_eqp)); 235 /* 14.2.2? char<?, char<=?, char>?, char>=? */ 236 add_applicative(K, ground_env, "char<?", ftyped_bpredp, 3, 237 symbol, p2tv(kcharp), p2tv(kchar_ltp)); 238 add_applicative(K, ground_env, "char<=?", ftyped_bpredp, 3, 239 symbol, p2tv(kcharp), p2tv(kchar_lep)); 240 add_applicative(K, ground_env, "char>?", ftyped_bpredp, 3, 241 symbol, p2tv(kcharp), p2tv(kchar_gtp)); 242 add_applicative(K, ground_env, "char>=?", ftyped_bpredp, 3, 243 symbol, p2tv(kcharp), p2tv(kchar_gep)); 244 /* 14.2.3? char-ci=? */ 245 add_applicative(K, ground_env, "char-ci=?", ftyped_bpredp, 3, 246 symbol, p2tv(kcharp), p2tv(kchar_ci_eqp)); 247 /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */ 248 add_applicative(K, ground_env, "char-ci<?", ftyped_bpredp, 3, 249 symbol, p2tv(kcharp), p2tv(kchar_ci_ltp)); 250 add_applicative(K, ground_env, "char-ci<=?", ftyped_bpredp, 3, 251 symbol, p2tv(kcharp), p2tv(kchar_ci_lep)); 252 add_applicative(K, ground_env, "char-ci>?", ftyped_bpredp, 3, 253 symbol, p2tv(kcharp), p2tv(kchar_ci_gtp)); 254 add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3, 255 symbol, p2tv(kcharp), p2tv(kchar_ci_gep)); 256 /* 14.2.? char-digit?, char->digit, digit->char */ 257 add_applicative(K, ground_env, "char-digit?", char_digitp, 0); 258 add_applicative(K, ground_env, "char->digit", char_to_digit, 0); 259 add_applicative(K, ground_env, "digit->char", digit_to_char, 0); 260 }