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