Commit | Line | Data |
---|---|---|
25d50a05 | 1 | /* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
0f2d19dd | 24 | |
0f2d19dd | 25 | #include <ctype.h> |
465380de | 26 | #include <limits.h> |
904a78f1 | 27 | #include <unicase.h> |
0ca3a342 | 28 | #include <unictype.h> |
904a78f1 | 29 | |
a0599745 MD |
30 | #include "libguile/_scm.h" |
31 | #include "libguile/validate.h" | |
0f2d19dd | 32 | |
a0599745 | 33 | #include "libguile/chars.h" |
1fdbbd4c MV |
34 | #include "libguile/srfi-14.h" |
35 | ||
0f2d19dd JB |
36 | \f |
37 | ||
a1ec6916 | 38 | SCM_DEFINE (scm_char_p, "char?", 1, 0, 0, |
1bbd0b84 | 39 | (SCM x), |
cdbc7418 | 40 | "Return @code{#t} iff @var{x} is a character, else @code{#f}.") |
1bbd0b84 | 41 | #define FUNC_NAME s_scm_char_p |
0f2d19dd | 42 | { |
7888309b | 43 | return scm_from_bool (SCM_CHARP(x)); |
0f2d19dd | 44 | } |
1bbd0b84 | 45 | #undef FUNC_NAME |
0f2d19dd | 46 | |
f1d19308 | 47 | static SCM scm_i_char_eq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
48 | SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1, |
49 | (SCM x, SCM y, SCM rest), | |
50 | "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n" | |
51 | "code point of @var{y}, else @code{#f}.\n") | |
52 | #define FUNC_NAME s_scm_i_char_eq_p | |
53 | { | |
54 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
55 | return SCM_BOOL_T; | |
56 | while (!scm_is_null (rest)) | |
57 | { | |
58 | if (scm_is_false (scm_char_eq_p (x, y))) | |
59 | return SCM_BOOL_F; | |
60 | x = y; | |
61 | y = scm_car (rest); | |
62 | rest = scm_cdr (rest); | |
63 | } | |
64 | return scm_char_eq_p (x, y); | |
65 | } | |
66 | #undef FUNC_NAME | |
67 | ||
68 | SCM scm_char_eq_p (SCM x, SCM y) | |
69 | #define FUNC_NAME s_scm_i_char_eq_p | |
0f2d19dd | 70 | { |
362306b9 DH |
71 | SCM_VALIDATE_CHAR (1, x); |
72 | SCM_VALIDATE_CHAR (2, y); | |
bc36d050 | 73 | return scm_from_bool (scm_is_eq (x, y)); |
0f2d19dd | 74 | } |
1bbd0b84 | 75 | #undef FUNC_NAME |
0f2d19dd JB |
76 | |
77 | ||
f1d19308 | 78 | static SCM scm_i_char_less_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
79 | SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1, |
80 | (SCM x, SCM y, SCM rest), | |
81 | "Return @code{#t} iff the code point of @var{x} is less than the code\n" | |
82 | "point of @var{y}, else @code{#f}.") | |
83 | #define FUNC_NAME s_scm_i_char_less_p | |
84 | { | |
85 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
86 | return SCM_BOOL_T; | |
87 | while (!scm_is_null (rest)) | |
88 | { | |
89 | if (scm_is_false (scm_char_less_p (x, y))) | |
90 | return SCM_BOOL_F; | |
91 | x = y; | |
92 | y = scm_car (rest); | |
93 | rest = scm_cdr (rest); | |
94 | } | |
95 | return scm_char_less_p (x, y); | |
96 | } | |
97 | #undef FUNC_NAME | |
98 | ||
99 | SCM scm_char_less_p (SCM x, SCM y) | |
100 | #define FUNC_NAME s_scm_i_char_less_p | |
0f2d19dd | 101 | { |
34d19ef6 HWN |
102 | SCM_VALIDATE_CHAR (1, x); |
103 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 104 | return scm_from_bool (SCM_CHAR(x) < SCM_CHAR(y)); |
0f2d19dd | 105 | } |
1bbd0b84 | 106 | #undef FUNC_NAME |
0f2d19dd | 107 | |
f1d19308 | 108 | static SCM scm_i_char_leq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
109 | SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1, |
110 | (SCM x, SCM y, SCM rest), | |
111 | "Return @code{#t} if the Unicode code point of @var{x} is less than or\n" | |
112 | "equal to the code point of @var{y}, else @code{#f}.") | |
113 | #define FUNC_NAME s_scm_i_char_leq_p | |
114 | { | |
115 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
116 | return SCM_BOOL_T; | |
117 | while (!scm_is_null (rest)) | |
118 | { | |
119 | if (scm_is_false (scm_char_leq_p (x, y))) | |
120 | return SCM_BOOL_F; | |
121 | x = y; | |
122 | y = scm_car (rest); | |
123 | rest = scm_cdr (rest); | |
124 | } | |
125 | return scm_char_leq_p (x, y); | |
126 | } | |
127 | #undef FUNC_NAME | |
128 | ||
129 | SCM scm_char_leq_p (SCM x, SCM y) | |
130 | #define FUNC_NAME s_scm_i_char_leq_p | |
0f2d19dd | 131 | { |
34d19ef6 HWN |
132 | SCM_VALIDATE_CHAR (1, x); |
133 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 134 | return scm_from_bool (SCM_CHAR(x) <= SCM_CHAR(y)); |
0f2d19dd | 135 | } |
1bbd0b84 | 136 | #undef FUNC_NAME |
0f2d19dd | 137 | |
f1d19308 | 138 | static SCM scm_i_char_gr_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
139 | SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1, |
140 | (SCM x, SCM y, SCM rest), | |
141 | "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" | |
142 | "the code point of @var{y}, else @code{#f}.") | |
143 | #define FUNC_NAME s_scm_i_char_gr_p | |
144 | { | |
145 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
146 | return SCM_BOOL_T; | |
147 | while (!scm_is_null (rest)) | |
148 | { | |
149 | if (scm_is_false (scm_char_gr_p (x, y))) | |
150 | return SCM_BOOL_F; | |
151 | x = y; | |
152 | y = scm_car (rest); | |
153 | rest = scm_cdr (rest); | |
154 | } | |
155 | return scm_char_gr_p (x, y); | |
156 | } | |
157 | #undef FUNC_NAME | |
158 | ||
159 | SCM scm_char_gr_p (SCM x, SCM y) | |
160 | #define FUNC_NAME s_scm_i_char_gr_p | |
0f2d19dd | 161 | { |
34d19ef6 HWN |
162 | SCM_VALIDATE_CHAR (1, x); |
163 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 164 | return scm_from_bool (SCM_CHAR(x) > SCM_CHAR(y)); |
0f2d19dd | 165 | } |
1bbd0b84 | 166 | #undef FUNC_NAME |
0f2d19dd | 167 | |
f1d19308 | 168 | static SCM scm_i_char_geq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
169 | SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1, |
170 | (SCM x, SCM y, SCM rest), | |
171 | "Return @code{#t} if the Unicode code point of @var{x} is greater than\n" | |
172 | "or equal to the code point of @var{y}, else @code{#f}.") | |
173 | #define FUNC_NAME s_scm_i_char_geq_p | |
174 | { | |
175 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
176 | return SCM_BOOL_T; | |
177 | while (!scm_is_null (rest)) | |
178 | { | |
179 | if (scm_is_false (scm_char_geq_p (x, y))) | |
180 | return SCM_BOOL_F; | |
181 | x = y; | |
182 | y = scm_car (rest); | |
183 | rest = scm_cdr (rest); | |
184 | } | |
185 | return scm_char_geq_p (x, y); | |
186 | } | |
187 | #undef FUNC_NAME | |
188 | ||
189 | SCM scm_char_geq_p (SCM x, SCM y) | |
190 | #define FUNC_NAME s_scm_i_char_geq_p | |
0f2d19dd | 191 | { |
34d19ef6 HWN |
192 | SCM_VALIDATE_CHAR (1, x); |
193 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 194 | return scm_from_bool (SCM_CHAR(x) >= SCM_CHAR(y)); |
0f2d19dd | 195 | } |
1bbd0b84 | 196 | #undef FUNC_NAME |
0f2d19dd | 197 | |
3f12aedb MG |
198 | /* FIXME?: R6RS specifies that these comparisons are case-folded. |
199 | This is the same thing as comparing the uppercase characters in | |
200 | practice, but, not in theory. Unicode has table containing their | |
201 | definition of case-folded character mappings. A more correct | |
202 | implementation would be to use that table and make a char-foldcase | |
203 | function. */ | |
204 | ||
f1d19308 | 205 | static SCM scm_i_char_ci_eq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
206 | SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1, |
207 | (SCM x, SCM y, SCM rest), | |
208 | "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" | |
209 | "the same as the case-folded code point of @var{y}, else @code{#f}.") | |
210 | #define FUNC_NAME s_scm_i_char_ci_eq_p | |
211 | { | |
212 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
213 | return SCM_BOOL_T; | |
214 | while (!scm_is_null (rest)) | |
215 | { | |
216 | if (scm_is_false (scm_char_ci_eq_p (x, y))) | |
217 | return SCM_BOOL_F; | |
218 | x = y; | |
219 | y = scm_car (rest); | |
220 | rest = scm_cdr (rest); | |
221 | } | |
222 | return scm_char_ci_eq_p (x, y); | |
223 | } | |
224 | #undef FUNC_NAME | |
225 | ||
226 | SCM scm_char_ci_eq_p (SCM x, SCM y) | |
227 | #define FUNC_NAME s_scm_i_char_ci_eq_p | |
0f2d19dd | 228 | { |
34d19ef6 HWN |
229 | SCM_VALIDATE_CHAR (1, x); |
230 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 231 | return scm_from_bool (scm_c_upcase(SCM_CHAR(x))==scm_c_upcase(SCM_CHAR(y))); |
0f2d19dd | 232 | } |
1bbd0b84 | 233 | #undef FUNC_NAME |
0f2d19dd | 234 | |
f1d19308 | 235 | static SCM scm_i_char_ci_less_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
236 | SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1, |
237 | (SCM x, SCM y, SCM rest), | |
238 | "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n" | |
239 | "less than the case-folded code point of @var{y}, else @code{#f}.") | |
240 | #define FUNC_NAME s_scm_i_char_ci_less_p | |
241 | { | |
242 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
243 | return SCM_BOOL_T; | |
244 | while (!scm_is_null (rest)) | |
245 | { | |
246 | if (scm_is_false (scm_char_ci_less_p (x, y))) | |
247 | return SCM_BOOL_F; | |
248 | x = y; | |
249 | y = scm_car (rest); | |
250 | rest = scm_cdr (rest); | |
251 | } | |
252 | return scm_char_ci_less_p (x, y); | |
253 | } | |
254 | #undef FUNC_NAME | |
255 | ||
256 | SCM scm_char_ci_less_p (SCM x, SCM y) | |
257 | #define FUNC_NAME s_scm_i_char_ci_less_p | |
0f2d19dd | 258 | { |
34d19ef6 HWN |
259 | SCM_VALIDATE_CHAR (1, x); |
260 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 261 | return scm_from_bool ((scm_c_upcase(SCM_CHAR(x))) < scm_c_upcase(SCM_CHAR(y))); |
0f2d19dd | 262 | } |
1bbd0b84 | 263 | #undef FUNC_NAME |
0f2d19dd | 264 | |
f1d19308 | 265 | static SCM scm_i_char_ci_leq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
266 | SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1, |
267 | (SCM x, SCM y, SCM rest), | |
ffb62a43 | 268 | "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n" |
8a1f4f98 AW |
269 | "less than or equal to the case-folded code point of @var{y}, else\n" |
270 | "@code{#f}") | |
271 | #define FUNC_NAME s_scm_i_char_ci_leq_p | |
272 | { | |
273 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
274 | return SCM_BOOL_T; | |
275 | while (!scm_is_null (rest)) | |
276 | { | |
277 | if (scm_is_false (scm_char_ci_leq_p (x, y))) | |
278 | return SCM_BOOL_F; | |
279 | x = y; | |
280 | y = scm_car (rest); | |
281 | rest = scm_cdr (rest); | |
282 | } | |
283 | return scm_char_ci_leq_p (x, y); | |
284 | } | |
285 | #undef FUNC_NAME | |
286 | ||
287 | SCM scm_char_ci_leq_p (SCM x, SCM y) | |
288 | #define FUNC_NAME s_scm_i_char_ci_leq_p | |
0f2d19dd | 289 | { |
34d19ef6 HWN |
290 | SCM_VALIDATE_CHAR (1, x); |
291 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 292 | return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) <= scm_c_upcase(SCM_CHAR(y))); |
0f2d19dd | 293 | } |
1bbd0b84 | 294 | #undef FUNC_NAME |
0f2d19dd | 295 | |
f1d19308 | 296 | static SCM scm_i_char_ci_gr_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
297 | SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1, |
298 | (SCM x, SCM y, SCM rest), | |
299 | "Return @code{#t} iff the case-folded code point of @var{x} is greater\n" | |
300 | "than the case-folded code point of @var{y}, else @code{#f}.") | |
301 | #define FUNC_NAME s_scm_i_char_ci_gr_p | |
302 | { | |
303 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
304 | return SCM_BOOL_T; | |
305 | while (!scm_is_null (rest)) | |
306 | { | |
307 | if (scm_is_false (scm_char_ci_gr_p (x, y))) | |
308 | return SCM_BOOL_F; | |
309 | x = y; | |
310 | y = scm_car (rest); | |
311 | rest = scm_cdr (rest); | |
312 | } | |
313 | return scm_char_ci_gr_p (x, y); | |
314 | } | |
315 | #undef FUNC_NAME | |
316 | ||
317 | SCM scm_char_ci_gr_p (SCM x, SCM y) | |
318 | #define FUNC_NAME s_scm_i_char_ci_gr_p | |
0f2d19dd | 319 | { |
34d19ef6 HWN |
320 | SCM_VALIDATE_CHAR (1, x); |
321 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 322 | return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) > scm_c_upcase(SCM_CHAR(y))); |
0f2d19dd | 323 | } |
1bbd0b84 | 324 | #undef FUNC_NAME |
0f2d19dd | 325 | |
f1d19308 | 326 | static SCM scm_i_char_ci_geq_p (SCM x, SCM y, SCM rest); |
8a1f4f98 AW |
327 | SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1, |
328 | (SCM x, SCM y, SCM rest), | |
329 | "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n" | |
330 | "greater than or equal to the case-folded code point of @var{y}, else\n" | |
331 | "@code{#f}.") | |
332 | #define FUNC_NAME s_scm_i_char_ci_geq_p | |
333 | { | |
334 | if (SCM_UNBNDP (x) || SCM_UNBNDP (y)) | |
335 | return SCM_BOOL_T; | |
336 | while (!scm_is_null (rest)) | |
337 | { | |
338 | if (scm_is_false (scm_char_ci_geq_p (x, y))) | |
339 | return SCM_BOOL_F; | |
340 | x = y; | |
341 | y = scm_car (rest); | |
342 | rest = scm_cdr (rest); | |
343 | } | |
344 | return scm_char_ci_geq_p (x, y); | |
345 | } | |
346 | #undef FUNC_NAME | |
347 | ||
348 | SCM scm_char_ci_geq_p (SCM x, SCM y) | |
349 | #define FUNC_NAME s_scm_i_char_ci_geq_p | |
0f2d19dd | 350 | { |
34d19ef6 HWN |
351 | SCM_VALIDATE_CHAR (1, x); |
352 | SCM_VALIDATE_CHAR (2, y); | |
7888309b | 353 | return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) >= scm_c_upcase(SCM_CHAR(y))); |
0f2d19dd | 354 | } |
1bbd0b84 | 355 | #undef FUNC_NAME |
0f2d19dd JB |
356 | |
357 | ||
3b3b36dd | 358 | SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, |
1bbd0b84 | 359 | (SCM chr), |
1fdbbd4c | 360 | "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n") |
1bbd0b84 | 361 | #define FUNC_NAME s_scm_char_alphabetic_p |
0f2d19dd | 362 | { |
1fdbbd4c | 363 | return scm_char_set_contains_p (scm_char_set_letter, chr); |
0f2d19dd | 364 | } |
1bbd0b84 | 365 | #undef FUNC_NAME |
0f2d19dd | 366 | |
3b3b36dd | 367 | SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0, |
1bbd0b84 | 368 | (SCM chr), |
1fdbbd4c | 369 | "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n") |
1bbd0b84 | 370 | #define FUNC_NAME s_scm_char_numeric_p |
0f2d19dd | 371 | { |
1fdbbd4c | 372 | return scm_char_set_contains_p (scm_char_set_digit, chr); |
0f2d19dd | 373 | } |
1bbd0b84 | 374 | #undef FUNC_NAME |
0f2d19dd | 375 | |
3b3b36dd | 376 | SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0, |
1bbd0b84 | 377 | (SCM chr), |
1fdbbd4c | 378 | "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n") |
1bbd0b84 | 379 | #define FUNC_NAME s_scm_char_whitespace_p |
0f2d19dd | 380 | { |
1fdbbd4c | 381 | return scm_char_set_contains_p (scm_char_set_whitespace, chr); |
0f2d19dd | 382 | } |
1bbd0b84 | 383 | #undef FUNC_NAME |
0f2d19dd JB |
384 | |
385 | ||
3b3b36dd | 386 | SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0, |
1bbd0b84 | 387 | (SCM chr), |
1fdbbd4c | 388 | "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n") |
1bbd0b84 | 389 | #define FUNC_NAME s_scm_char_upper_case_p |
0f2d19dd | 390 | { |
1fdbbd4c | 391 | return scm_char_set_contains_p (scm_char_set_upper_case, chr); |
0f2d19dd | 392 | } |
1bbd0b84 | 393 | #undef FUNC_NAME |
0f2d19dd JB |
394 | |
395 | ||
3b3b36dd | 396 | SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0, |
1bbd0b84 | 397 | (SCM chr), |
1fdbbd4c | 398 | "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n") |
1bbd0b84 | 399 | #define FUNC_NAME s_scm_char_lower_case_p |
0f2d19dd | 400 | { |
1fdbbd4c | 401 | return scm_char_set_contains_p (scm_char_set_lower_case, chr); |
0f2d19dd | 402 | } |
1bbd0b84 | 403 | #undef FUNC_NAME |
0f2d19dd | 404 | |
a1ec6916 | 405 | SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0, |
1bbd0b84 | 406 | (SCM chr), |
bb15a36c MG |
407 | "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n" |
408 | "@code{#f}.\n") | |
1bbd0b84 | 409 | #define FUNC_NAME s_scm_char_is_both_p |
0f2d19dd | 410 | { |
1fdbbd4c MV |
411 | if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr))) |
412 | return SCM_BOOL_T; | |
413 | return scm_char_set_contains_p (scm_char_set_upper_case, chr); | |
0f2d19dd | 414 | } |
1bbd0b84 | 415 | #undef FUNC_NAME |
0f2d19dd JB |
416 | |
417 | ||
a1ec6916 | 418 | SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0, |
1bbd0b84 | 419 | (SCM chr), |
bb15a36c | 420 | "Return the Unicode code point of @var{chr}.") |
1bbd0b84 | 421 | #define FUNC_NAME s_scm_char_to_integer |
0f2d19dd | 422 | { |
34d19ef6 | 423 | SCM_VALIDATE_CHAR (1, chr); |
904a78f1 | 424 | return scm_from_uint32 (SCM_CHAR(chr)); |
0f2d19dd | 425 | } |
1bbd0b84 | 426 | #undef FUNC_NAME |
0f2d19dd JB |
427 | |
428 | ||
3b3b36dd | 429 | SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0, |
1bbd0b84 | 430 | (SCM n), |
bb15a36c MG |
431 | "Return the character that has Unicode code point @var{n}. The integer\n" |
432 | "@var{n} must be a valid code point. Valid code points are in the\n" | |
433 | "ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n" | |
434 | "@code{#x10FFFF} inclusive.") | |
1bbd0b84 | 435 | #define FUNC_NAME s_scm_integer_to_char |
0f2d19dd | 436 | { |
904a78f1 MG |
437 | scm_t_wchar cn; |
438 | ||
439 | cn = scm_to_wchar (n); | |
440 | ||
441 | /* Avoid the surrogates. */ | |
442 | if (!SCM_IS_UNICODE_CHAR (cn)) | |
443 | scm_out_of_range (FUNC_NAME, n); | |
444 | ||
445 | return SCM_MAKE_CHAR (cn); | |
0f2d19dd | 446 | } |
1bbd0b84 | 447 | #undef FUNC_NAME |
0f2d19dd JB |
448 | |
449 | ||
3b3b36dd | 450 | SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0, |
1bbd0b84 | 451 | (SCM chr), |
cdbc7418 | 452 | "Return the uppercase character version of @var{chr}.") |
1bbd0b84 | 453 | #define FUNC_NAME s_scm_char_upcase |
0f2d19dd | 454 | { |
34d19ef6 | 455 | SCM_VALIDATE_CHAR (1, chr); |
904a78f1 | 456 | return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr))); |
0f2d19dd | 457 | } |
1bbd0b84 | 458 | #undef FUNC_NAME |
0f2d19dd JB |
459 | |
460 | ||
3b3b36dd | 461 | SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0, |
1bbd0b84 | 462 | (SCM chr), |
cdbc7418 | 463 | "Return the lowercase character version of @var{chr}.") |
1bbd0b84 | 464 | #define FUNC_NAME s_scm_char_downcase |
0f2d19dd | 465 | { |
34d19ef6 | 466 | SCM_VALIDATE_CHAR (1, chr); |
904a78f1 | 467 | return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr))); |
0f2d19dd | 468 | } |
1bbd0b84 | 469 | #undef FUNC_NAME |
0f2d19dd | 470 | |
820f33aa JG |
471 | SCM_DEFINE (scm_char_titlecase, "char-titlecase", 1, 0, 0, |
472 | (SCM chr), | |
473 | "Return the titlecase character version of @var{chr}.") | |
474 | #define FUNC_NAME s_scm_char_titlecase | |
475 | { | |
476 | SCM_VALIDATE_CHAR (1, chr); | |
477 | return SCM_MAKE_CHAR (scm_c_titlecase (SCM_CHAR(chr))); | |
478 | } | |
479 | #undef FUNC_NAME | |
480 | ||
0ca3a342 JG |
481 | SCM_DEFINE (scm_char_general_category, "char-general-category", 1, 0, 0, |
482 | (SCM chr), | |
483 | "Return a symbol representing the Unicode general category of " | |
484 | "@var{chr} or @code{#f} if a named category cannot be found.") | |
485 | #define FUNC_NAME s_scm_char_general_category | |
486 | { | |
487 | const char *sym; | |
488 | uc_general_category_t cat; | |
489 | ||
490 | SCM_VALIDATE_CHAR (1, chr); | |
491 | cat = uc_general_category (SCM_CHAR (chr)); | |
492 | sym = uc_general_category_name (cat); | |
493 | ||
494 | if (sym != NULL) | |
25d50a05 | 495 | return scm_from_utf8_symbol (sym); |
0ca3a342 JG |
496 | return SCM_BOOL_F; |
497 | } | |
498 | #undef FUNC_NAME | |
499 | ||
0f2d19dd JB |
500 | \f |
501 | ||
502 | ||
503 | ||
84fad130 HWN |
504 | /* |
505 | TODO: change name to scm_i_.. ? --hwn | |
506 | */ | |
507 | ||
1cc91f1b | 508 | |
904a78f1 MG |
509 | scm_t_wchar |
510 | scm_c_upcase (scm_t_wchar c) | |
0f2d19dd | 511 | { |
f49dbcad | 512 | return uc_toupper ((int) c); |
0f2d19dd JB |
513 | } |
514 | ||
1cc91f1b | 515 | |
904a78f1 MG |
516 | scm_t_wchar |
517 | scm_c_downcase (scm_t_wchar c) | |
0f2d19dd | 518 | { |
f49dbcad | 519 | return uc_tolower ((int) c); |
0f2d19dd JB |
520 | } |
521 | ||
820f33aa JG |
522 | scm_t_wchar |
523 | scm_c_titlecase (scm_t_wchar c) | |
524 | { | |
525 | return uc_totitle ((int) c); | |
526 | } | |
527 | ||
77332b21 | 528 | \f |
0f2d19dd | 529 | |
77332b21 MG |
530 | /* There are a few sets of character names: R5RS, Guile |
531 | extensions for control characters, and leftover Guile extensions. | |
532 | They are listed in order of precedence. */ | |
533 | ||
64bad3f5 MG |
534 | static const char *const scm_r5rs_charnames[] = { |
535 | "space", "newline" | |
536 | }; | |
77332b21 | 537 | |
64bad3f5 | 538 | static const scm_t_uint32 const scm_r5rs_charnums[] = { |
15b6a6b2 | 539 | 0x20, 0x0a |
64bad3f5 | 540 | }; |
77332b21 | 541 | |
64bad3f5 | 542 | #define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *)) |
77332b21 | 543 | |
15b6a6b2 MG |
544 | static const char *const scm_r6rs_charnames[] = { |
545 | "nul", "alarm", "backspace", "tab", "linefeed", "vtab", "page", | |
546 | "return", "esc", "delete" | |
547 | /* 'space' and 'newline' are already included from the R5RS list. */ | |
548 | }; | |
549 | ||
550 | static const scm_t_uint32 const scm_r6rs_charnums[] = { | |
551 | 0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, | |
552 | 0x0d, 0x1b, 0x7f | |
553 | }; | |
554 | ||
555 | #define SCM_N_R6RS_CHARNAMES (sizeof (scm_r6rs_charnames) / sizeof (char *)) | |
556 | ||
77332b21 | 557 | /* The abbreviated names for control characters. */ |
64bad3f5 MG |
558 | static const char *const scm_C0_control_charnames[] = { |
559 | /* C0 controls */ | |
560 | "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", | |
561 | "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", | |
562 | "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", | |
563 | "can", "em", "sub", "esc", "fs", "gs", "rs", "us", | |
564 | "sp", "del" | |
565 | }; | |
566 | ||
567 | static const scm_t_uint32 const scm_C0_control_charnums[] = { | |
568 | 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, | |
569 | 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, | |
570 | 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, | |
571 | 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, | |
572 | 0x20, 0x7f | |
573 | }; | |
574 | ||
575 | #define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *)) | |
576 | ||
577 | static const char *const scm_alt_charnames[] = { | |
15b6a6b2 | 578 | "null", "nl", "np" |
64bad3f5 MG |
579 | }; |
580 | ||
581 | static const scm_t_uint32 const scm_alt_charnums[] = { | |
15b6a6b2 | 582 | 0x00, 0x0a, 0x0c |
64bad3f5 MG |
583 | }; |
584 | ||
585 | #define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *)) | |
77332b21 MG |
586 | |
587 | /* Returns the string charname for a character if it exists, or NULL | |
588 | otherwise. */ | |
589 | const char * | |
590 | scm_i_charname (SCM chr) | |
591 | { | |
744c8724 | 592 | size_t c; |
77332b21 | 593 | scm_t_uint32 i = SCM_CHAR (chr); |
0f2d19dd | 594 | |
64bad3f5 | 595 | for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++) |
77332b21 MG |
596 | if (scm_r5rs_charnums[c] == i) |
597 | return scm_r5rs_charnames[c]; | |
0f2d19dd | 598 | |
15b6a6b2 MG |
599 | for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++) |
600 | if (scm_r6rs_charnums[c] == i) | |
601 | return scm_r6rs_charnames[c]; | |
602 | ||
64bad3f5 | 603 | for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++) |
77332b21 MG |
604 | if (scm_C0_control_charnums[c] == i) |
605 | return scm_C0_control_charnames[c]; | |
606 | ||
b3498751 MG |
607 | /* Since the characters in scm_alt_charnums is a subset of |
608 | scm_C0_control_charnums, this code is never reached. */ | |
64bad3f5 | 609 | for (c = 0; c < SCM_N_ALT_CHARNAMES; c++) |
77332b21 | 610 | if (scm_alt_charnums[c] == i) |
b3498751 | 611 | return scm_alt_charnames[c]; |
0f2d19dd | 612 | |
77332b21 MG |
613 | return NULL; |
614 | } | |
615 | ||
616 | /* Return a character from a string charname. */ | |
617 | SCM | |
618 | scm_i_charname_to_char (const char *charname, size_t charname_len) | |
619 | { | |
744c8724 | 620 | size_t c; |
77332b21 | 621 | |
15b6a6b2 | 622 | /* The R5RS charnames. These are supposed to be case insensitive. */ |
64bad3f5 | 623 | for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++) |
77332b21 MG |
624 | if ((strlen (scm_r5rs_charnames[c]) == charname_len) |
625 | && (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len))) | |
626 | return SCM_MAKE_CHAR (scm_r5rs_charnums[c]); | |
627 | ||
15b6a6b2 MG |
628 | /* The R6RS charnames. R6RS says that these should be case-sensitive. They |
629 | are left as case-insensitive to avoid confusion. */ | |
630 | for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++) | |
631 | if ((strlen (scm_r6rs_charnames[c]) == charname_len) | |
632 | && (!strncasecmp (scm_r6rs_charnames[c], charname, charname_len))) | |
633 | return SCM_MAKE_CHAR (scm_r6rs_charnums[c]); | |
634 | ||
635 | /* Then come the controls. By Guile convention, these are not case | |
636 | sensitive. */ | |
64bad3f5 | 637 | for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++) |
77332b21 MG |
638 | if ((strlen (scm_C0_control_charnames[c]) == charname_len) |
639 | && (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len))) | |
640 | return SCM_MAKE_CHAR (scm_C0_control_charnums[c]); | |
641 | ||
642 | /* Lastly are some old names carried over for compatibility. */ | |
64bad3f5 | 643 | for (c = 0; c < SCM_N_ALT_CHARNAMES; c++) |
77332b21 MG |
644 | if ((strlen (scm_alt_charnames[c]) == charname_len) |
645 | && (!strncasecmp (scm_alt_charnames[c], charname, charname_len))) | |
646 | return SCM_MAKE_CHAR (scm_alt_charnums[c]); | |
64bad3f5 | 647 | |
77332b21 MG |
648 | return SCM_BOOL_F; |
649 | } | |
0f2d19dd JB |
650 | |
651 | \f | |
652 | ||
1cc91f1b | 653 | |
0f2d19dd JB |
654 | void |
655 | scm_init_chars () | |
0f2d19dd | 656 | { |
a0599745 | 657 | #include "libguile/chars.x" |
0f2d19dd JB |
658 | } |
659 | ||
89e00824 ML |
660 | |
661 | /* | |
662 | Local Variables: | |
663 | c-file-style: "gnu" | |
664 | End: | |
665 | */ |