1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
|
/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <ctype.h>
#include <limits.h>
#include <unicase.h>
#include "libguile/_scm.h"
#include "libguile/validate.h"
#include "libguile/chars.h"
#include "libguile/srfi-14.h"
SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
(SCM x),
"Return @code{#t} iff @var{x} is a character, else @code{#f}.")
#define FUNC_NAME s_scm_char_p
{
return scm_from_bool (SCM_CHARP(x));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the Unicode code point of @var{x} is equal to the\n"
"code point of @var{y}, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff the code point of @var{x} is less than the code\n"
"point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (SCM_CHAR(x) < SCM_CHAR(y));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the Unicode code point of @var{x} is less than or\n"
"equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (SCM_CHAR(x) <= SCM_CHAR(y));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
"the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (SCM_CHAR(x) > SCM_CHAR(y));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
"or equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (SCM_CHAR(x) >= SCM_CHAR(y));
}
#undef FUNC_NAME
/* FIXME?: R6RS specifies that these comparisons are case-folded.
This is the same thing as comparing the uppercase characters in
practice, but, not in theory. Unicode has table containing their
definition of case-folded character mappings. A more correct
implementation would be to use that table and make a char-foldcase
function. */
SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
"the same as the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (scm_c_upcase(SCM_CHAR(x))==scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
"less than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool ((scm_c_upcase(SCM_CHAR(x))) < scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n"
"less than or equal to the case-folded code point of @var{y}, else\n"
"@code{#f}")
#define FUNC_NAME s_scm_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) <= scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
"than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) > scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME
SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
"greater than or equal to the case-folded code point of @var{y}, else\n"
"@code{#f}.")
#define FUNC_NAME s_scm_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) >= scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_alphabetic_p
{
return scm_char_set_contains_p (scm_char_set_letter, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_numeric_p
{
return scm_char_set_contains_p (scm_char_set_digit, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_whitespace_p
{
return scm_char_set_contains_p (scm_char_set_whitespace, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_upper_case_p
{
return scm_char_set_contains_p (scm_char_set_upper_case, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_lower_case_p
{
return scm_char_set_contains_p (scm_char_set_lower_case, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n"
"@code{#f}.\n")
#define FUNC_NAME s_scm_char_is_both_p
{
if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
return SCM_BOOL_T;
return scm_char_set_contains_p (scm_char_set_upper_case, chr);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
(SCM chr),
"Return the Unicode code point of @var{chr}.")
#define FUNC_NAME s_scm_char_to_integer
{
SCM_VALIDATE_CHAR (1, chr);
return scm_from_uint32 (SCM_CHAR(chr));
}
#undef FUNC_NAME
SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
(SCM n),
"Return the character that has Unicode code point @var{n}. The integer\n"
"@var{n} must be a valid code point. Valid code points are in the\n"
"ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n"
"@code{#x10FFFF} inclusive.")
#define FUNC_NAME s_scm_integer_to_char
{
scm_t_wchar cn;
cn = scm_to_wchar (n);
/* Avoid the surrogates. */
if (!SCM_IS_UNICODE_CHAR (cn))
scm_out_of_range (FUNC_NAME, n);
return SCM_MAKE_CHAR (cn);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
(SCM chr),
"Return the uppercase character version of @var{chr}.")
#define FUNC_NAME s_scm_char_upcase
{
SCM_VALIDATE_CHAR (1, chr);
return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
(SCM chr),
"Return the lowercase character version of @var{chr}.")
#define FUNC_NAME s_scm_char_downcase
{
SCM_VALIDATE_CHAR (1, chr);
return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr)));
}
#undef FUNC_NAME
/*
TODO: change name to scm_i_.. ? --hwn
*/
scm_t_wchar
scm_c_upcase (scm_t_wchar c)
{
return uc_toupper ((int) c);
}
scm_t_wchar
scm_c_downcase (scm_t_wchar c)
{
return uc_tolower ((int) c);
}
/* There are a few sets of character names: R5RS, Guile
extensions for control characters, and leftover Guile extensions.
They are listed in order of precedence. */
static const char *const scm_r5rs_charnames[] = {
"space", "newline"
};
static const scm_t_uint32 const scm_r5rs_charnums[] = {
0x20, 0x0A
};
#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))
/* The abbreviated names for control characters. */
static const char *const scm_C0_control_charnames[] = {
/* C0 controls */
"nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
"bs", "ht", "lf", "vt", "ff", "cr", "so", "si",
"dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
"can", "em", "sub", "esc", "fs", "gs", "rs", "us",
"sp", "del"
};
static const scm_t_uint32 const scm_C0_control_charnums[] = {
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
0x20, 0x7f
};
#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *))
static const char *const scm_alt_charnames[] = {
"null", "backspace", "tab", "nl", "newline", "np", "page", "return",
};
static const scm_t_uint32 const scm_alt_charnums[] = {
0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
};
#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))
/* Returns the string charname for a character if it exists, or NULL
otherwise. */
const char *
scm_i_charname (SCM chr)
{
size_t c;
scm_t_uint32 i = SCM_CHAR (chr);
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if (scm_r5rs_charnums[c] == i)
return scm_r5rs_charnames[c];
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if (scm_C0_control_charnums[c] == i)
return scm_C0_control_charnames[c];
for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if (scm_alt_charnums[c] == i)
return scm_alt_charnames[i];
return NULL;
}
/* Return a character from a string charname. */
SCM
scm_i_charname_to_char (const char *charname, size_t charname_len)
{
size_t c;
/* The R5RS charnames. These are supposed to be case
insensitive. */
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if ((strlen (scm_r5rs_charnames[c]) == charname_len)
&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
/* Then come the controls. These are not case sensitive. */
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if ((strlen (scm_C0_control_charnames[c]) == charname_len)
&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);
/* Lastly are some old names carried over for compatibility. */
for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if ((strlen (scm_alt_charnames[c]) == charname_len)
&& (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_alt_charnums[c]);
return SCM_BOOL_F;
}
void
scm_init_chars ()
{
#include "libguile/chars.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/
|