HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
char-set-filter! does not properly iterate over the charset
[bpt/guile.git] / libguile / srfi-14.c
1 /* srfi-14.c --- SRFI-14 procedures for Guile
2 *
3 * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
4 *
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
9 *
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
14 *
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18 * 02110-1301 USA
19 */
20
21 #ifdef HAVE_CONFIG_H
22 # include <config.h>
23 #endif
24
25
26 #include <string.h>
27 #include <unictype.h>
28
29 #include "libguile.h"
30 #include "libguile/srfi-14.h"
31 #include "libguile/strings.h"
32 #include "libguile/chars.h"
33
34 /* Include the pre-computed standard charset data. */
35 #include "libguile/srfi-14.i.c"
36
37 #define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
38
39 #define SCM_CHARSET_SET(cs, idx) \
40 scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)
41
42 #define SCM_CHARSET_UNSET(cs, idx) \
43 scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)
44
45 /* Smob type code for character sets. */
46 int scm_tc16_charset = 0;
47 int scm_tc16_charset_cursor = 0;
48
49 /* True if N exists in charset CS. */
50 int
51 scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n)
52 {
53 size_t i;
54
55 i = 0;
56 while (i < cs->len)
57 {
58 if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
59 return 1;
60 i++;
61 }
62
63 return 0;
64 }
65
66 /* Put N into charset CS. */
67 void
68 scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
69 {
70 size_t i;
71 size_t len;
72
73 len = cs->len;
74
75 i = 0;
76 while (i < len)
77 {
78 /* Already in this range */
79 if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
80 {
81 return;
82 }
83
84 if (n == cs->ranges[i].lo - 1)
85 {
86 /* This char is one below the current range. */
87 if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
88 {
89 /* It is also one above the previous range, so combine them. */
90 cs->ranges[i - 1].hi = cs->ranges[i].hi;
91 if (i < len - 1)
92 memmove (cs->ranges + i, cs->ranges + (i + 1),
93 sizeof (scm_t_char_range) * (len - i - 1));
94 cs->ranges = scm_gc_realloc (cs->ranges,
95 sizeof (scm_t_char_range) * len,
96 sizeof (scm_t_char_range) * (len -
97 1),
98 "character-set");
99 cs->len = len - 1;
100 return;
101 }
102 else
103 {
104 /* Expand the range down by one. */
105 cs->ranges[i].lo = n;
106 return;
107 }
108 }
109 else if (n == cs->ranges[i].hi + 1)
110 {
111 /* This char is one above the current range. */
112 if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n)
113 {
114 /* It is also one below the next range, so combine them. */
115 cs->ranges[i].hi = cs->ranges[i + 1].hi;
116 if (i < len - 2)
117 memmove (cs->ranges + (i + 1), cs->ranges + (i + 2),
118 sizeof (scm_t_char_range) * (len - i - 2));
119 cs->ranges = scm_gc_realloc (cs->ranges,
120 sizeof (scm_t_char_range) * len,
121 sizeof (scm_t_char_range) * (len -
122 1),
123 "character-set");
124 cs->len = len - 1;
125 return;
126 }
127 else
128 {
129 /* Expand the range up by one. */
130 cs->ranges[i].hi = n;
131 return;
132 }
133 }
134 else if (n < cs->ranges[i].lo - 1)
135 {
136 /* This is a new range below the current one. */
137 cs->ranges = scm_gc_realloc (cs->ranges,
138 sizeof (scm_t_char_range) * len,
139 sizeof (scm_t_char_range) * (len + 1),
140 "character-set");
141 memmove (cs->ranges + (i + 1), cs->ranges + i,
142 sizeof (scm_t_char_range) * (len - i));
143 cs->ranges[i].lo = n;
144 cs->ranges[i].hi = n;
145 cs->len = len + 1;
146 return;
147 }
148
149 i++;
150 }
151
152 /* This is a new range above all previous ranges. */
153 if (len == 0)
154 {
155 cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
156 }
157 else
158 {
159 cs->ranges = scm_gc_realloc (cs->ranges,
160 sizeof (scm_t_char_range) * len,
161 sizeof (scm_t_char_range) * (len + 1),
162 "character-set");
163 }
164 cs->ranges[len].lo = n;
165 cs->ranges[len].hi = n;
166 cs->len = len + 1;
167
168 return;
169 }
170
171 /* Put LO to HI inclusive into charset CS. */
172 static void
173 scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
174 {
175 size_t i;
176
177 i = 0;
178 while (i < cs->len)
179 {
180 /* Already in this range */
181 if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
182 return;
183
184 /* cur: +---+
185 new: +---+
186 */
187 if (cs->ranges[i].lo - 1 > hi)
188 {
189 /* Add a new range below the current one. */
190 cs->ranges = scm_gc_realloc (cs->ranges,
191 sizeof (scm_t_char_range) * cs->len,
192 sizeof (scm_t_char_range) * (cs->len + 1),
193 "character-set");
194 memmove (cs->ranges + (i + 1), cs->ranges + i,
195 sizeof (scm_t_char_range) * (cs->len - i));
196 cs->ranges[i].lo = lo;
197 cs->ranges[i].hi = hi;
198 cs->len += 1;
199 return;
200 }
201
202 /* cur: +---+ or +---+ or +---+
203 new: +---+ +---+ +---+
204 */
205 if (cs->ranges[i].lo > lo
206 && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
207 {
208 cs->ranges[i].lo = lo;
209 return;
210 }
211
212 /* cur: +---+ or +---+ or +---+
213 new: +---+ +---+ +---+
214 */
215 else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
216 {
217 if (cs->ranges[i].lo > lo)
218 cs->ranges[i].lo = lo;
219 if (cs->ranges[i].hi < hi)
220 cs->ranges[i].hi = hi;
221 while (i < cs->len - 1)
222 {
223 /* cur: --+ +---+
224 new: -----+
225 */
226 if (cs->ranges[i + 1].lo - 1 > hi)
227 break;
228
229 /* cur: --+ +---+ or --+ +---+ or --+ +--+
230 new: -----+ ------+ ---------+
231 */
232 /* Combine this range with the previous one. */
233 if (cs->ranges[i + 1].hi > hi)
234 cs->ranges[i].hi = cs->ranges[i + 1].hi;
235 if (i + 1 < cs->len)
236 memmove (cs->ranges + i + 1, cs->ranges + i + 2,
237 sizeof (scm_t_char_range) * (cs->len - i - 2));
238 cs->ranges = scm_gc_realloc (cs->ranges,
239 sizeof (scm_t_char_range) * cs->len,
240 sizeof (scm_t_char_range) * (cs->len - 1),
241 "character-set");
242 cs->len -= 1;
243 }
244 return;
245 }
246 i ++;
247 }
248
249 /* This is a new range above all previous ranges. */
250 if (cs->len == 0)
251 {
252 cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
253 }
254 else
255 {
256 cs->ranges = scm_gc_realloc (cs->ranges,
257 sizeof (scm_t_char_range) * cs->len,
258 sizeof (scm_t_char_range) * (cs->len + 1),
259 "character-set");
260 }
261 cs->len += 1;
262 cs->ranges[cs->len - 1].lo = lo;
263 cs->ranges[cs->len - 1].hi = hi;
264
265 return;
266 }
267
268 /* If N is in charset CS, remove it. */
269 void
270 scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
271 {
272 size_t i;
273 size_t len;
274
275 len = cs->len;
276
277 i = 0;
278 while (i < len)
279 {
280 if (n < cs->ranges[i].lo)
281 /* Not in this set. */
282 return;
283
284 if (n == cs->ranges[i].lo && n == cs->ranges[i].hi)
285 {
286 /* Remove this one-character range. */
287 if (len == 1)
288 {
289 scm_gc_free (cs->ranges,
290 sizeof (scm_t_char_range) * cs->len,
291 "character-set");
292 cs->ranges = NULL;
293 cs->len = 0;
294 return;
295 }
296 else if (i < len - 1)
297 {
298 memmove (cs->ranges + i, cs->ranges + (i + 1),
299 sizeof (scm_t_char_range) * (len - i - 1));
300 cs->ranges = scm_gc_realloc (cs->ranges,
301 sizeof (scm_t_char_range) * len,
302 sizeof (scm_t_char_range) * (len -
303 1),
304 "character-set");
305 cs->len = len - 1;
306 return;
307 }
308 else if (i == len - 1)
309 {
310 cs->ranges = scm_gc_realloc (cs->ranges,
311 sizeof (scm_t_char_range) * len,
312 sizeof (scm_t_char_range) * (len -
313 1),
314 "character-set");
315 cs->len = len - 1;
316 return;
317 }
318 }
319 else if (n == cs->ranges[i].lo)
320 {
321 /* Shrink this range from the left. */
322 cs->ranges[i].lo = n + 1;
323 return;
324 }
325 else if (n == cs->ranges[i].hi)
326 {
327 /* Shrink this range from the right. */
328 cs->ranges[i].hi = n - 1;
329 return;
330 }
331 else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi)
332 {
333 /* Split this range into two pieces. */
334 cs->ranges = scm_gc_realloc (cs->ranges,
335 sizeof (scm_t_char_range) * len,
336 sizeof (scm_t_char_range) * (len + 1),
337 "character-set");
338 if (i < len - 1)
339 memmove (cs->ranges + (i + 2), cs->ranges + (i + 1),
340 sizeof (scm_t_char_range) * (len - i - 1));
341 cs->ranges[i + 1].hi = cs->ranges[i].hi;
342 cs->ranges[i + 1].lo = n + 1;
343 cs->ranges[i].hi = n - 1;
344 cs->len = len + 1;
345 return;
346 }
347
348 i++;
349 }
350
351 /* This value is above all ranges, so do nothing here. */
352 return;
353 }
354
355 static int
356 charsets_equal (scm_t_char_set *a, scm_t_char_set *b)
357 {
358 if (a->len != b->len)
359 return 0;
360
361 if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0)
362 return 0;
363
364 return 1;
365 }
366
367 /* Return true if every character in A is also in B. */
368 static int
369 charsets_leq (scm_t_char_set *a, scm_t_char_set *b)
370 {
371 size_t i = 0, j = 0;
372 scm_t_wchar alo, ahi;
373
374 if (a->len == 0)
375 return 1;
376 if (b->len == 0)
377 return 0;
378 while (i < a->len)
379 {
380 alo = a->ranges[i].lo;
381 ahi = a->ranges[i].hi;
382 while (b->ranges[j].hi < alo)
383 {
384 if (j < b->len - 1)
385 j++;
386 else
387 return 0;
388 }
389 if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi)
390 return 0;
391 i++;
392 }
393
394 return 1;
395 }
396
397 /* Merge B into A. */
398 static void
399 charsets_union (scm_t_char_set *a, scm_t_char_set *b)
400 {
401 size_t i = 0;
402 scm_t_wchar blo, bhi, n;
403
404 if (b->len == 0)
405 return;
406
407 if (a->len == 0)
408 {
409 a->len = b->len;
410 a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len,
411 "character-set");
412 memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len);
413 return;
414 }
415
416 /* This needs optimization. */
417 while (i < b->len)
418 {
419 blo = b->ranges[i].lo;
420 bhi = b->ranges[i].hi;
421 for (n = blo; n <= bhi; n++)
422 scm_i_charset_set (a, n);
423
424 i++;
425 }
426
427 return;
428 }
429
430 /* Remove elements not both in A and B from A. */
431 static void
432 charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
433 {
434 size_t i = 0;
435 scm_t_wchar blo, bhi, n;
436 scm_t_char_set *c;
437
438 if (a->len == 0)
439 return;
440
441 if (b->len == 0)
442 {
443 scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
444 "character-set");
445 a->len = 0;
446 return;
447 }
448
449 c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set));
450 c->len = 0;
451 c->ranges = NULL;
452
453 while (i < b->len)
454 {
455 blo = b->ranges[i].lo;
456 bhi = b->ranges[i].hi;
457 for (n = blo; n <= bhi; n++)
458 if (scm_i_charset_get (a, n))
459 scm_i_charset_set (c, n);
460 i++;
461 }
462 scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
463 "character-set");
464
465 a->len = c->len;
466 if (c->len != 0)
467 a->ranges = c->ranges;
468 else
469 a->ranges = NULL;
470 free (c);
471 return;
472 }
473
474 /* Make P the compelement of Q. */
475 static void
476 charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
477 {
478 int k, idx;
479
480 if (q->len == 0)
481 {
482 /* Fill with all valid codepoints. */
483 p->len = 2;
484 p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
485 "character-set");
486 p->ranges[0].lo = 0;
487 p->ranges[0].hi = SCM_CODEPOINT_SURROGATE_START - 1;
488 p->ranges[1].lo = SCM_CODEPOINT_SURROGATE_END + 1;
489 p->ranges[1].hi = SCM_CODEPOINT_MAX;
490 return;
491 }
492
493 if (p->len > 0)
494 scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
495 "character-set");
496
497 p->len = 0;
498 if (q->ranges[0].lo > 0)
499 p->len++;
500 if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
501 p->len++;
502 p->len += q->len - 1;
503 p->ranges =
504 (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
505 "character-set");
506 idx = 0;
507 if (q->ranges[0].lo > 0)
508 {
509 p->ranges[idx].lo = 0;
510 p->ranges[idx++].hi = q->ranges[0].lo - 1;
511 }
512 for (k = 1; k < q->len; k++)
513 {
514 p->ranges[idx].lo = q->ranges[k - 1].hi + 1;
515 p->ranges[idx++].hi = q->ranges[k].lo - 1;
516 }
517 if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
518 {
519 p->ranges[idx].lo = q->ranges[q->len - 1].hi + 1;
520 p->ranges[idx].hi = SCM_CODEPOINT_MAX;
521 }
522 return;
523 }
524
525 /* Replace A with elements only found in one of A or B. */
526 static void
527 charsets_xor (scm_t_char_set *a, scm_t_char_set *b)
528 {
529 size_t i = 0;
530 scm_t_wchar blo, bhi, n;
531
532 if (b->len == 0)
533 {
534 return;
535 }
536
537 if (a->len == 0)
538 {
539 a->ranges =
540 (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) *
541 b->len, "character-set");
542 a->len = b->len;
543 memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len);
544 return;
545 }
546
547 while (i < b->len)
548 {
549 blo = b->ranges[i].lo;
550 bhi = b->ranges[i].hi;
551 for (n = blo; n <= bhi; n++)
552 {
553 if (scm_i_charset_get (a, n))
554 scm_i_charset_unset (a, n);
555 else
556 scm_i_charset_set (a, n);
557 }
558
559 i++;
560 }
561 return;
562 }
563
564 /* Smob print hook for character sets. */
565 static int
566 charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
567 {
568 size_t i;
569 int first = 1;
570 scm_t_char_set *p;
571 const size_t max_ranges_to_print = 50;
572
573 p = SCM_CHARSET_DATA (charset);
574
575 scm_puts ("#<charset {", port);
576 for (i = 0; i < p->len; i++)
577 {
578 if (first)
579 first = 0;
580 else
581 scm_puts (" ", port);
582 scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
583 if (p->ranges[i].lo != p->ranges[i].hi)
584 {
585 scm_puts ("..", port);
586 scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
587 }
588 if (i >= max_ranges_to_print)
589 {
590 /* Too many to print here. Quit early. */
591 scm_puts (" ...", port);
592 break;
593 }
594 }
595 scm_puts ("}>", port);
596 return 1;
597 }
598
599
600 /* Smob free hook for character sets. */
601 static size_t
602 charset_free (SCM charset)
603 {
604 scm_t_char_set *cs;
605 size_t len = 0;
606
607 cs = SCM_CHARSET_DATA (charset);
608 if (cs != NULL)
609 len = cs->len;
610 if (len > 0)
611 scm_gc_free (cs->ranges, sizeof (scm_t_char_range) * len,
612 "character-set");
613
614 cs->ranges = NULL;
615 cs->len = 0;
616
617 scm_gc_free (cs, sizeof (scm_t_char_set), "character-set");
618
619 scm_remember_upto_here_1 (charset);
620
621 return 0;
622 }
623
624
625 /* Smob print hook for character sets cursors. */
626 static int
627 charset_cursor_print (SCM cursor, SCM port,
628 scm_print_state *pstate SCM_UNUSED)
629 {
630 scm_t_char_set_cursor *cur;
631
632 cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
633
634 scm_puts ("#<charset-cursor ", port);
635 if (cur->range == (size_t) (-1))
636 scm_puts ("(empty)", port);
637 else
638 {
639 scm_write (scm_from_size_t (cur->range), port);
640 scm_puts (":", port);
641 scm_write (scm_from_int32 (cur->n), port);
642 }
643 scm_puts (">", port);
644 return 1;
645 }
646
647 /* Smob free hook for character sets. */
648 static size_t
649 charset_cursor_free (SCM charset)
650 {
651 scm_t_char_set_cursor *cur;
652
653 cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (charset);
654 scm_gc_free (cur, sizeof (scm_t_char_set_cursor), "charset-cursor");
655 scm_remember_upto_here_1 (charset);
656
657 return 0;
658 }
659
660
661 /* Create a new, empty character set. */
662 static SCM
663 make_char_set (const char *func_name)
664 {
665 scm_t_char_set *p;
666
667 p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set");
668 memset (p, 0, sizeof (scm_t_char_set));
669 SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
670 }
671
672
673 SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
674 (SCM obj),
675 "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
676 "otherwise.")
677 #define FUNC_NAME s_scm_char_set_p
678 {
679 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
680 }
681 #undef FUNC_NAME
682
683
684 SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
685 (SCM char_sets),
686 "Return @code{#t} if all given character sets are equal.")
687 #define FUNC_NAME s_scm_char_set_eq
688 {
689 int argnum = 1;
690 scm_t_char_set *cs1_data = NULL;
691
692 SCM_VALIDATE_REST_ARGUMENT (char_sets);
693
694 while (!scm_is_null (char_sets))
695 {
696 SCM csi = SCM_CAR (char_sets);
697 scm_t_char_set *csi_data;
698
699 SCM_VALIDATE_SMOB (argnum, csi, charset);
700 argnum++;
701 csi_data = SCM_CHARSET_DATA (csi);
702 if (cs1_data == NULL)
703 cs1_data = csi_data;
704 else if (!charsets_equal (cs1_data, csi_data))
705 return SCM_BOOL_F;
706 char_sets = SCM_CDR (char_sets);
707 }
708 return SCM_BOOL_T;
709 }
710 #undef FUNC_NAME
711
712
713 SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
714 (SCM char_sets),
715 "Return @code{#t} if every character set @var{cs}i is a subset\n"
716 "of character set @var{cs}i+1.")
717 #define FUNC_NAME s_scm_char_set_leq
718 {
719 int argnum = 1;
720 scm_t_char_set *prev_data = NULL;
721
722 SCM_VALIDATE_REST_ARGUMENT (char_sets);
723
724 while (!scm_is_null (char_sets))
725 {
726 SCM csi = SCM_CAR (char_sets);
727 scm_t_char_set *csi_data;
728
729 SCM_VALIDATE_SMOB (argnum, csi, charset);
730 argnum++;
731 csi_data = SCM_CHARSET_DATA (csi);
732 if (prev_data)
733 {
734 if (!charsets_leq (prev_data, csi_data))
735 return SCM_BOOL_F;
736 }
737 prev_data = csi_data;
738 char_sets = SCM_CDR (char_sets);
739 }
740 return SCM_BOOL_T;
741 }
742 #undef FUNC_NAME
743
744
745 SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
746 (SCM cs, SCM bound),
747 "Compute a hash value for the character set @var{cs}. If\n"
748 "@var{bound} is given and non-zero, it restricts the\n"
749 "returned value to the range 0 @dots{} @var{bound - 1}.")
750 #define FUNC_NAME s_scm_char_set_hash
751 {
752 const unsigned long default_bnd = 871;
753 unsigned long bnd;
754 scm_t_char_set *p;
755 unsigned long val = 0;
756 int k;
757 scm_t_wchar c;
758
759 SCM_VALIDATE_SMOB (1, cs, charset);
760
761 if (SCM_UNBNDP (bound))
762 bnd = default_bnd;
763 else
764 {
765 bnd = scm_to_ulong (bound);
766 if (bnd == 0)
767 bnd = default_bnd;
768 }
769
770 p = SCM_CHARSET_DATA (cs);
771 for (k = 0; k < p->len; k++)
772 {
773 for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++)
774 val = c + (val << 1);
775 }
776 return scm_from_ulong (val % bnd);
777 }
778 #undef FUNC_NAME
779
780
781 SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
782 (SCM cs), "Return a cursor into the character set @var{cs}.")
783 #define FUNC_NAME s_scm_char_set_cursor
784 {
785 scm_t_char_set *cs_data;
786 scm_t_char_set_cursor *cur_data;
787
788 SCM_VALIDATE_SMOB (1, cs, charset);
789 cs_data = SCM_CHARSET_DATA (cs);
790 cur_data =
791 (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor),
792 "charset-cursor");
793 if (cs_data->len == 0)
794 {
795 cur_data->range = (size_t) (-1);
796 cur_data->n = 0;
797 }
798 else
799 {
800 cur_data->range = 0;
801 cur_data->n = cs_data->ranges[0].lo;
802 }
803 SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
804 }
805 #undef FUNC_NAME
806
807
808 SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
809 (SCM cs, SCM cursor),
810 "Return the character at the current cursor position\n"
811 "@var{cursor} in the character set @var{cs}. It is an error to\n"
812 "pass a cursor for which @code{end-of-char-set?} returns true.")
813 #define FUNC_NAME s_scm_char_set_ref
814 {
815 scm_t_char_set *cs_data;
816 scm_t_char_set_cursor *cur_data;
817 size_t i;
818
819 SCM_VALIDATE_SMOB (1, cs, charset);
820 SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
821
822 cs_data = SCM_CHARSET_DATA (cs);
823 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
824
825 /* Validate that this cursor is still true. */
826 i = cur_data->range;
827 if (i == (size_t) (-1)
828 || i >= cs_data->len
829 || cur_data->n < cs_data->ranges[i].lo
830 || cur_data->n > cs_data->ranges[i].hi)
831 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
832 return SCM_MAKE_CHAR (cur_data->n);
833 }
834 #undef FUNC_NAME
835
836
837 SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
838 (SCM cs, SCM cursor),
839 "Advance the character set cursor @var{cursor} to the next\n"
840 "character in the character set @var{cs}. It is an error if the\n"
841 "cursor given satisfies @code{end-of-char-set?}.")
842 #define FUNC_NAME s_scm_char_set_cursor_next
843 {
844 scm_t_char_set *cs_data;
845 scm_t_char_set_cursor *cur_data;
846 size_t i;
847
848 SCM_VALIDATE_SMOB (1, cs, charset);
849 SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
850
851 cs_data = SCM_CHARSET_DATA (cs);
852 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
853
854 /* Validate that this cursor is still true. */
855 i = cur_data->range;
856 if (i == (size_t) (-1)
857 || i >= cs_data->len
858 || cur_data->n < cs_data->ranges[i].lo
859 || cur_data->n > cs_data->ranges[i].hi)
860 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
861 /* Increment the cursor. */
862 if (cur_data->n == cs_data->ranges[i].hi)
863 {
864 if (i + 1 < cs_data->len)
865 {
866 cur_data->range = i + 1;
867 cur_data->n = cs_data->ranges[i + 1].lo;
868 }
869 else
870 {
871 /* This is the end of the road. */
872 cur_data->range = (size_t) (-1);
873 cur_data->n = 0;
874 }
875 }
876 else
877 {
878 cur_data->n = cur_data->n + 1;
879 }
880
881 return cursor;
882 }
883 #undef FUNC_NAME
884
885
886 SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
887 (SCM cursor),
888 "Return @code{#t} if @var{cursor} has reached the end of a\n"
889 "character set, @code{#f} otherwise.")
890 #define FUNC_NAME s_scm_end_of_char_set_p
891 {
892 scm_t_char_set_cursor *cur_data;
893 SCM_VALIDATE_SMOB (1, cursor, charset_cursor);
894
895 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
896 if (cur_data->range == (size_t) (-1))
897 return SCM_BOOL_T;
898
899 return SCM_BOOL_F;
900 }
901 #undef FUNC_NAME
902
903
904 SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
905 (SCM kons, SCM knil, SCM cs),
906 "Fold the procedure @var{kons} over the character set @var{cs},\n"
907 "initializing it with @var{knil}.")
908 #define FUNC_NAME s_scm_char_set_fold
909 {
910 scm_t_char_set *cs_data;
911 int k;
912 scm_t_wchar n;
913
914 SCM_VALIDATE_PROC (1, kons);
915 SCM_VALIDATE_SMOB (3, cs, charset);
916
917 cs_data = SCM_CHARSET_DATA (cs);
918
919 if (cs_data->len == 0)
920 return knil;
921
922 for (k = 0; k < cs_data->len; k++)
923 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
924 {
925 knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
926 }
927 return knil;
928 }
929 #undef FUNC_NAME
930
931
932 SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
933 (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
934 "This is a fundamental constructor for character sets.\n"
935 "@itemize @bullet\n"
936 "@item @var{g} is used to generate a series of ``seed'' values\n"
937 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
938 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
939 "@item @var{p} tells us when to stop -- when it returns true\n"
940 "when applied to one of the seed values.\n"
941 "@item @var{f} maps each seed value to a character. These\n"
942 "characters are added to the base character set @var{base_cs} to\n"
943 "form the result; @var{base_cs} defaults to the empty set.\n"
944 "@end itemize")
945 #define FUNC_NAME s_scm_char_set_unfold
946 {
947 SCM result, tmp;
948
949 SCM_VALIDATE_PROC (1, p);
950 SCM_VALIDATE_PROC (2, f);
951 SCM_VALIDATE_PROC (3, g);
952 if (!SCM_UNBNDP (base_cs))
953 {
954 SCM_VALIDATE_SMOB (5, base_cs, charset);
955 result = scm_char_set_copy (base_cs);
956 }
957 else
958 result = make_char_set (FUNC_NAME);
959
960 tmp = scm_call_1 (p, seed);
961 while (scm_is_false (tmp))
962 {
963 SCM ch = scm_call_1 (f, seed);
964 if (!SCM_CHARP (ch))
965 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
966 SCM_CHARSET_SET (result, SCM_CHAR (ch));
967
968 seed = scm_call_1 (g, seed);
969 tmp = scm_call_1 (p, seed);
970 }
971 return result;
972 }
973 #undef FUNC_NAME
974
975
976 SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
977 (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
978 "This is a fundamental constructor for character sets.\n"
979 "@itemize @bullet\n"
980 "@item @var{g} is used to generate a series of ``seed'' values\n"
981 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
982 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
983 "@item @var{p} tells us when to stop -- when it returns true\n"
984 "when applied to one of the seed values.\n"
985 "@item @var{f} maps each seed value to a character. These\n"
986 "characters are added to the base character set @var{base_cs} to\n"
987 "form the result; @var{base_cs} defaults to the empty set.\n"
988 "@end itemize")
989 #define FUNC_NAME s_scm_char_set_unfold_x
990 {
991 SCM tmp;
992
993 SCM_VALIDATE_PROC (1, p);
994 SCM_VALIDATE_PROC (2, f);
995 SCM_VALIDATE_PROC (3, g);
996 SCM_VALIDATE_SMOB (5, base_cs, charset);
997
998 tmp = scm_call_1 (p, seed);
999 while (scm_is_false (tmp))
1000 {
1001 SCM ch = scm_call_1 (f, seed);
1002 if (!SCM_CHARP (ch))
1003 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
1004 SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
1005
1006 seed = scm_call_1 (g, seed);
1007 tmp = scm_call_1 (p, seed);
1008 }
1009 return base_cs;
1010 }
1011 #undef FUNC_NAME
1012
1013
1014 SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
1015 (SCM proc, SCM cs),
1016 "Apply @var{proc} to every character in the character set\n"
1017 "@var{cs}. The return value is not specified.")
1018 #define FUNC_NAME s_scm_char_set_for_each
1019 {
1020 scm_t_char_set *cs_data;
1021 int k;
1022 scm_t_wchar n;
1023
1024 SCM_VALIDATE_PROC (1, proc);
1025 SCM_VALIDATE_SMOB (2, cs, charset);
1026
1027 cs_data = SCM_CHARSET_DATA (cs);
1028
1029 if (cs_data->len == 0)
1030 return SCM_UNSPECIFIED;
1031
1032 for (k = 0; k < cs_data->len; k++)
1033 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1034 {
1035 scm_call_1 (proc, SCM_MAKE_CHAR (n));
1036 }
1037
1038 return SCM_UNSPECIFIED;
1039 }
1040 #undef FUNC_NAME
1041
1042
1043 SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
1044 (SCM proc, SCM cs),
1045 "Map the procedure @var{proc} over every character in @var{cs}.\n"
1046 "@var{proc} must be a character -> character procedure.")
1047 #define FUNC_NAME s_scm_char_set_map
1048 {
1049 SCM result;
1050 int k;
1051 scm_t_char_set *cs_data;
1052 scm_t_wchar n;
1053
1054 SCM_VALIDATE_PROC (1, proc);
1055 SCM_VALIDATE_SMOB (2, cs, charset);
1056
1057 result = make_char_set (FUNC_NAME);
1058 cs_data = SCM_CHARSET_DATA (cs);
1059
1060 if (cs_data->len == 0)
1061 return result;
1062
1063 for (k = 0; k < cs_data->len; k++)
1064 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1065 {
1066 SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
1067 if (!SCM_CHARP (ch))
1068 SCM_MISC_ERROR ("procedure ~S returned non-char",
1069 scm_list_1 (proc));
1070 SCM_CHARSET_SET (result, SCM_CHAR (ch));
1071 }
1072 return result;
1073 }
1074 #undef FUNC_NAME
1075
1076
1077 SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
1078 (SCM cs),
1079 "Return a newly allocated character set containing all\n"
1080 "characters in @var{cs}.")
1081 #define FUNC_NAME s_scm_char_set_copy
1082 {
1083 SCM ret;
1084 scm_t_char_set *p1, *p2;
1085
1086 SCM_VALIDATE_SMOB (1, cs, charset);
1087 ret = make_char_set (FUNC_NAME);
1088 p1 = SCM_CHARSET_DATA (cs);
1089 p2 = SCM_CHARSET_DATA (ret);
1090 p2->len = p1->len;
1091
1092 if (p1->len == 0)
1093 p2->ranges = NULL;
1094 else
1095 {
1096 p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len,
1097 "character-set");
1098 memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len);
1099 }
1100
1101 return ret;
1102 }
1103 #undef FUNC_NAME
1104
1105
1106 SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
1107 (SCM rest),
1108 "Return a character set containing all given characters.")
1109 #define FUNC_NAME s_scm_char_set
1110 {
1111 SCM cs;
1112 int argnum = 1;
1113
1114 SCM_VALIDATE_REST_ARGUMENT (rest);
1115 cs = make_char_set (FUNC_NAME);
1116 while (!scm_is_null (rest))
1117 {
1118 scm_t_wchar c;
1119
1120 SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
1121 argnum++;
1122 rest = SCM_CDR (rest);
1123 SCM_CHARSET_SET (cs, c);
1124 }
1125 return cs;
1126 }
1127 #undef FUNC_NAME
1128
1129
1130 SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
1131 (SCM list, SCM base_cs),
1132 "Convert the character list @var{list} to a character set. If\n"
1133 "the character set @var{base_cs} is given, the character in this\n"
1134 "set are also included in the result.")
1135 #define FUNC_NAME s_scm_list_to_char_set
1136 {
1137 SCM cs;
1138
1139 SCM_VALIDATE_LIST (1, list);
1140 if (SCM_UNBNDP (base_cs))
1141 cs = make_char_set (FUNC_NAME);
1142 else
1143 {
1144 SCM_VALIDATE_SMOB (2, base_cs, charset);
1145 cs = scm_char_set_copy (base_cs);
1146 }
1147 while (!scm_is_null (list))
1148 {
1149 SCM chr = SCM_CAR (list);
1150 scm_t_wchar c;
1151
1152 SCM_VALIDATE_CHAR_COPY (0, chr, c);
1153 list = SCM_CDR (list);
1154
1155
1156 SCM_CHARSET_SET (cs, c);
1157 }
1158 return cs;
1159 }
1160 #undef FUNC_NAME
1161
1162
1163 SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
1164 (SCM list, SCM base_cs),
1165 "Convert the character list @var{list} to a character set. The\n"
1166 "characters are added to @var{base_cs} and @var{base_cs} is\n"
1167 "returned.")
1168 #define FUNC_NAME s_scm_list_to_char_set_x
1169 {
1170 SCM_VALIDATE_LIST (1, list);
1171 SCM_VALIDATE_SMOB (2, base_cs, charset);
1172 while (!scm_is_null (list))
1173 {
1174 SCM chr = SCM_CAR (list);
1175 scm_t_wchar c;
1176
1177 SCM_VALIDATE_CHAR_COPY (0, chr, c);
1178 list = SCM_CDR (list);
1179
1180 SCM_CHARSET_SET (base_cs, c);
1181 }
1182 return base_cs;
1183 }
1184 #undef FUNC_NAME
1185
1186
1187 SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
1188 (SCM str, SCM base_cs),
1189 "Convert the string @var{str} to a character set. If the\n"
1190 "character set @var{base_cs} is given, the characters in this\n"
1191 "set are also included in the result.")
1192 #define FUNC_NAME s_scm_string_to_char_set
1193 {
1194 SCM cs;
1195 size_t k = 0, len;
1196
1197 SCM_VALIDATE_STRING (1, str);
1198 if (SCM_UNBNDP (base_cs))
1199 cs = make_char_set (FUNC_NAME);
1200 else
1201 {
1202 SCM_VALIDATE_SMOB (2, base_cs, charset);
1203 cs = scm_char_set_copy (base_cs);
1204 }
1205 len = scm_i_string_length (str);
1206 while (k < len)
1207 {
1208 scm_t_wchar c = scm_i_string_ref (str, k++);
1209 SCM_CHARSET_SET (cs, c);
1210 }
1211 scm_remember_upto_here_1 (str);
1212 return cs;
1213 }
1214 #undef FUNC_NAME
1215
1216
1217 SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
1218 (SCM str, SCM base_cs),
1219 "Convert the string @var{str} to a character set. The\n"
1220 "characters from the string are added to @var{base_cs}, and\n"
1221 "@var{base_cs} is returned.")
1222 #define FUNC_NAME s_scm_string_to_char_set_x
1223 {
1224 size_t k = 0, len;
1225
1226 SCM_VALIDATE_STRING (1, str);
1227 SCM_VALIDATE_SMOB (2, base_cs, charset);
1228 len = scm_i_string_length (str);
1229 while (k < len)
1230 {
1231 scm_t_wchar c = scm_i_string_ref (str, k++);
1232 SCM_CHARSET_SET (base_cs, c);
1233 }
1234 scm_remember_upto_here_1 (str);
1235 return base_cs;
1236 }
1237 #undef FUNC_NAME
1238
1239
1240 SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
1241 (SCM pred, SCM cs, SCM base_cs),
1242 "Return a character set containing every character from @var{cs}\n"
1243 "so that it satisfies @var{pred}. If provided, the characters\n"
1244 "from @var{base_cs} are added to the result.")
1245 #define FUNC_NAME s_scm_char_set_filter
1246 {
1247 SCM ret;
1248 int k;
1249 scm_t_wchar n;
1250 scm_t_char_set *p;
1251
1252 SCM_VALIDATE_PROC (1, pred);
1253 SCM_VALIDATE_SMOB (2, cs, charset);
1254 if (!SCM_UNBNDP (base_cs))
1255 {
1256 SCM_VALIDATE_SMOB (3, base_cs, charset);
1257 ret = scm_char_set_copy (base_cs);
1258 }
1259 else
1260 ret = make_char_set (FUNC_NAME);
1261
1262 p = SCM_CHARSET_DATA (cs);
1263
1264 if (p->len == 0)
1265 return ret;
1266
1267 for (k = 0; k < p->len; k++)
1268 for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
1269 {
1270 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1271
1272 if (scm_is_true (res))
1273 SCM_CHARSET_SET (ret, n);
1274 }
1275 return ret;
1276 }
1277 #undef FUNC_NAME
1278
1279
1280 SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
1281 (SCM pred, SCM cs, SCM base_cs),
1282 "Return a character set containing every character from @var{cs}\n"
1283 "so that it satisfies @var{pred}. The characters are added to\n"
1284 "@var{base_cs} and @var{base_cs} is returned.")
1285 #define FUNC_NAME s_scm_char_set_filter_x
1286 {
1287 int k;
1288 scm_t_wchar n;
1289 scm_t_char_set *p;
1290
1291 SCM_VALIDATE_PROC (1, pred);
1292 SCM_VALIDATE_SMOB (2, cs, charset);
1293 SCM_VALIDATE_SMOB (3, base_cs, charset);
1294 p = SCM_CHARSET_DATA (cs);
1295 if (p->len == 0)
1296 return base_cs;
1297
1298 for (k = 0; k < p->len; k++)
1299 for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
1300 {
1301 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1302
1303 if (scm_is_true (res))
1304 SCM_CHARSET_SET (base_cs, n);
1305 }
1306 return base_cs;
1307 }
1308 #undef FUNC_NAME
1309
1310
1311 /* Return a character set containing all the characters from [LOWER,UPPER),
1312 giving range errors if ERROR, adding chars from BASE_CS, and recycling
1313 BASE_CS if REUSE is true. */
1314 static SCM
1315 scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
1316 SCM error, SCM base_cs, int reuse)
1317 {
1318 SCM cs;
1319 size_t clower, cupper;
1320
1321 clower = scm_to_size_t (lower);
1322 cupper = scm_to_size_t (upper) - 1;
1323 SCM_ASSERT_RANGE (1, lower, clower >= 0);
1324 SCM_ASSERT_RANGE (2, upper, cupper >= 0);
1325 SCM_ASSERT_RANGE (2, upper, cupper >= clower);
1326 if (!SCM_UNBNDP (error))
1327 {
1328 if (scm_is_true (error))
1329 {
1330 SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
1331 SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
1332 if (clower < SCM_CODEPOINT_SURROGATE_START
1333 && cupper > SCM_CODEPOINT_SURROGATE_END)
1334 scm_error(scm_out_of_range_key,
1335 FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
1336 scm_list_2 (lower, upper), scm_list_1 (upper));
1337 }
1338 }
1339
1340 if (SCM_UNBNDP (base_cs))
1341 cs = make_char_set (FUNC_NAME);
1342 else
1343 {
1344 SCM_VALIDATE_SMOB (4, base_cs, charset);
1345 if (reuse)
1346 cs = base_cs;
1347 else
1348 cs = scm_char_set_copy (base_cs);
1349 }
1350
1351 if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
1352 && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
1353 return cs;
1354
1355 if (clower > SCM_CODEPOINT_MAX)
1356 clower = SCM_CODEPOINT_MAX;
1357 if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
1358 clower = SCM_CODEPOINT_SURROGATE_END + 1;
1359 if (cupper > SCM_CODEPOINT_MAX)
1360 cupper = SCM_CODEPOINT_MAX;
1361 if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
1362 cupper = SCM_CODEPOINT_SURROGATE_START - 1;
1363 if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
1364 {
1365 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
1366 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
1367 }
1368 else
1369 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
1370 return cs;
1371 }
1372
1373 SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
1374 (SCM lower, SCM upper, SCM error, SCM base_cs),
1375 "Return a character set containing all characters whose\n"
1376 "character codes lie in the half-open range\n"
1377 "[@var{lower},@var{upper}).\n"
1378 "\n"
1379 "If @var{error} is a true value, an error is signalled if the\n"
1380 "specified range contains characters which are not valid\n"
1381 "Unicode code points. If @var{error} is @code{#f},\n"
1382 "these characters are silently left out of the resultung\n"
1383 "character set.\n"
1384 "\n"
1385 "The characters in @var{base_cs} are added to the result, if\n"
1386 "given.")
1387 #define FUNC_NAME s_scm_ucs_range_to_char_set
1388 {
1389 return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
1390 error, base_cs, 0);
1391 }
1392 #undef FUNC_NAME
1393
1394
1395 SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
1396 (SCM lower, SCM upper, SCM error, SCM base_cs),
1397 "Return a character set containing all characters whose\n"
1398 "character codes lie in the half-open range\n"
1399 "[@var{lower},@var{upper}).\n"
1400 "\n"
1401 "If @var{error} is a true value, an error is signalled if the\n"
1402 "specified range contains characters which are not contained in\n"
1403 "the implemented character range. If @var{error} is @code{#f},\n"
1404 "these characters are silently left out of the resultung\n"
1405 "character set.\n"
1406 "\n"
1407 "The characters are added to @var{base_cs} and @var{base_cs} is\n"
1408 "returned.")
1409 #define FUNC_NAME s_scm_ucs_range_to_char_set_x
1410 {
1411 SCM_VALIDATE_SMOB (4, base_cs, charset);
1412 return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
1413 error, base_cs, 1);
1414 }
1415 #undef FUNC_NAME
1416
1417 SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
1418 (SCM x),
1419 "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.")
1420 #define FUNC_NAME s_scm_to_char_set
1421 {
1422 if (scm_is_string (x))
1423 return scm_string_to_char_set (x, SCM_UNDEFINED);
1424 else if (SCM_CHARP (x))
1425 return scm_char_set (scm_list_1 (x));
1426 else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x))
1427 return x;
1428 else
1429 scm_wrong_type_arg (NULL, 0, x);
1430 }
1431 #undef FUNC_NAME
1432
1433 SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
1434 (SCM cs),
1435 "Return the number of elements in character set @var{cs}.")
1436 #define FUNC_NAME s_scm_char_set_size
1437 {
1438 int k, count = 0;
1439 scm_t_char_set *cs_data;
1440
1441 SCM_VALIDATE_SMOB (1, cs, charset);
1442 cs_data = SCM_CHARSET_DATA (cs);
1443
1444 if (cs_data->len == 0)
1445 return scm_from_int (0);
1446
1447 for (k = 0; k < cs_data->len; k++)
1448 count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1;
1449
1450 return scm_from_int (count);
1451 }
1452 #undef FUNC_NAME
1453
1454
1455 SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
1456 (SCM pred, SCM cs),
1457 "Return the number of the elements int the character set\n"
1458 "@var{cs} which satisfy the predicate @var{pred}.")
1459 #define FUNC_NAME s_scm_char_set_count
1460 {
1461 int k, count = 0;
1462 scm_t_wchar n;
1463 scm_t_char_set *cs_data;
1464
1465 SCM_VALIDATE_PROC (1, pred);
1466 SCM_VALIDATE_SMOB (2, cs, charset);
1467 cs_data = SCM_CHARSET_DATA (cs);
1468 if (cs_data->len == 0)
1469 return scm_from_int (0);
1470
1471 for (k = 0; k < cs_data->len; k++)
1472 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1473 {
1474 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1475 if (scm_is_true (res))
1476 count++;
1477 }
1478 return SCM_I_MAKINUM (count);
1479 }
1480 #undef FUNC_NAME
1481
1482
1483 SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
1484 (SCM cs),
1485 "Return a list containing the elements of the character set\n"
1486 "@var{cs}.")
1487 #define FUNC_NAME s_scm_char_set_to_list
1488 {
1489 int k;
1490 scm_t_wchar n;
1491 SCM result = SCM_EOL;
1492 scm_t_char_set *p;
1493
1494 SCM_VALIDATE_SMOB (1, cs, charset);
1495 p = SCM_CHARSET_DATA (cs);
1496 if (p->len == 0)
1497 return SCM_EOL;
1498
1499 for (k = p->len - 1; k >= 0; k--)
1500 for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--)
1501 result = scm_cons (SCM_MAKE_CHAR (n), result);
1502 return result;
1503 }
1504 #undef FUNC_NAME
1505
1506
1507 SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
1508 (SCM cs),
1509 "Return a string containing the elements of the character set\n"
1510 "@var{cs}. The order in which the characters are placed in the\n"
1511 "string is not defined.")
1512 #define FUNC_NAME s_scm_char_set_to_string
1513 {
1514 int k;
1515 int count = 0;
1516 int idx = 0;
1517 int wide = 0;
1518 SCM result;
1519 scm_t_wchar n;
1520 scm_t_char_set *cs_data;
1521 char *buf;
1522 scm_t_wchar *wbuf;
1523
1524 SCM_VALIDATE_SMOB (1, cs, charset);
1525 cs_data = SCM_CHARSET_DATA (cs);
1526 if (cs_data->len == 0)
1527 return scm_nullstr;
1528
1529 if (cs_data->ranges[cs_data->len - 1].hi > 255)
1530 wide = 1;
1531
1532 count = scm_to_int (scm_char_set_size (cs));
1533 if (wide)
1534 result = scm_i_make_wide_string (count, &wbuf);
1535 else
1536 result = scm_i_make_string (count, &buf);
1537
1538 for (k = 0; k < cs_data->len; k++)
1539 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1540 {
1541 if (wide)
1542 wbuf[idx++] = n;
1543 else
1544 buf[idx++] = n;
1545 }
1546 return result;
1547 }
1548 #undef FUNC_NAME
1549
1550
1551 SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
1552 (SCM cs, SCM ch),
1553 "Return @code{#t} iff the character @var{ch} is contained in the\n"
1554 "character set @var{cs}.")
1555 #define FUNC_NAME s_scm_char_set_contains_p
1556 {
1557 SCM_VALIDATE_SMOB (1, cs, charset);
1558 SCM_VALIDATE_CHAR (2, ch);
1559 return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
1560 }
1561 #undef FUNC_NAME
1562
1563
1564 SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
1565 (SCM pred, SCM cs),
1566 "Return a true value if every character in the character set\n"
1567 "@var{cs} satisfies the predicate @var{pred}.")
1568 #define FUNC_NAME s_scm_char_set_every
1569 {
1570 int k;
1571 scm_t_wchar n;
1572 SCM res = SCM_BOOL_T;
1573 scm_t_char_set *cs_data;
1574
1575 SCM_VALIDATE_PROC (1, pred);
1576 SCM_VALIDATE_SMOB (2, cs, charset);
1577
1578 cs_data = SCM_CHARSET_DATA (cs);
1579 if (cs_data->len == 0)
1580 return SCM_BOOL_T;
1581
1582 for (k = 0; k < cs_data->len; k++)
1583 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1584 {
1585 res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1586 if (scm_is_false (res))
1587 return res;
1588 }
1589 return SCM_BOOL_T;
1590 }
1591 #undef FUNC_NAME
1592
1593
1594 SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
1595 (SCM pred, SCM cs),
1596 "Return a true value if any character in the character set\n"
1597 "@var{cs} satisfies the predicate @var{pred}.")
1598 #define FUNC_NAME s_scm_char_set_any
1599 {
1600 int k;
1601 scm_t_wchar n;
1602 scm_t_char_set *cs_data;
1603
1604 SCM_VALIDATE_PROC (1, pred);
1605 SCM_VALIDATE_SMOB (2, cs, charset);
1606
1607 cs_data = SCM_CHARSET_DATA (cs);
1608 if (cs_data->len == 0)
1609 return SCM_BOOL_T;
1610
1611 for (k = 0; k < cs_data->len; k++)
1612 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1613 {
1614 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1615 if (scm_is_true (res))
1616 return res;
1617 }
1618 return SCM_BOOL_F;
1619 }
1620 #undef FUNC_NAME
1621
1622
1623 SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
1624 (SCM cs, SCM rest),
1625 "Add all character arguments to the first argument, which must\n"
1626 "be a character set.")
1627 #define FUNC_NAME s_scm_char_set_adjoin
1628 {
1629 SCM_VALIDATE_SMOB (1, cs, charset);
1630 SCM_VALIDATE_REST_ARGUMENT (rest);
1631 cs = scm_char_set_copy (cs);
1632
1633 while (!scm_is_null (rest))
1634 {
1635 SCM chr = SCM_CAR (rest);
1636 scm_t_wchar c;
1637
1638 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1639 rest = SCM_CDR (rest);
1640
1641 SCM_CHARSET_SET (cs, c);
1642 }
1643 return cs;
1644 }
1645 #undef FUNC_NAME
1646
1647
1648 SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
1649 (SCM cs, SCM rest),
1650 "Delete all character arguments from the first argument, which\n"
1651 "must be a character set.")
1652 #define FUNC_NAME s_scm_char_set_delete
1653 {
1654 SCM_VALIDATE_SMOB (1, cs, charset);
1655 SCM_VALIDATE_REST_ARGUMENT (rest);
1656 cs = scm_char_set_copy (cs);
1657
1658 while (!scm_is_null (rest))
1659 {
1660 SCM chr = SCM_CAR (rest);
1661 scm_t_wchar c;
1662
1663 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1664 rest = SCM_CDR (rest);
1665
1666 SCM_CHARSET_UNSET (cs, c);
1667 }
1668 return cs;
1669 }
1670 #undef FUNC_NAME
1671
1672
1673 SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
1674 (SCM cs, SCM rest),
1675 "Add all character arguments to the first argument, which must\n"
1676 "be a character set.")
1677 #define FUNC_NAME s_scm_char_set_adjoin_x
1678 {
1679 SCM_VALIDATE_SMOB (1, cs, charset);
1680 SCM_VALIDATE_REST_ARGUMENT (rest);
1681
1682 while (!scm_is_null (rest))
1683 {
1684 SCM chr = SCM_CAR (rest);
1685 scm_t_wchar c;
1686
1687 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1688 rest = SCM_CDR (rest);
1689
1690 SCM_CHARSET_SET (cs, c);
1691 }
1692 return cs;
1693 }
1694 #undef FUNC_NAME
1695
1696
1697 SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
1698 (SCM cs, SCM rest),
1699 "Delete all character arguments from the first argument, which\n"
1700 "must be a character set.")
1701 #define FUNC_NAME s_scm_char_set_delete_x
1702 {
1703 SCM_VALIDATE_SMOB (1, cs, charset);
1704 SCM_VALIDATE_REST_ARGUMENT (rest);
1705
1706 while (!scm_is_null (rest))
1707 {
1708 SCM chr = SCM_CAR (rest);
1709 scm_t_wchar c;
1710
1711 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1712 rest = SCM_CDR (rest);
1713
1714 SCM_CHARSET_UNSET (cs, c);
1715 }
1716 return cs;
1717 }
1718 #undef FUNC_NAME
1719
1720
1721 SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
1722 (SCM cs), "Return the complement of the character set @var{cs}.")
1723 #define FUNC_NAME s_scm_char_set_complement
1724 {
1725 SCM res;
1726 scm_t_char_set *p, *q;
1727
1728 SCM_VALIDATE_SMOB (1, cs, charset);
1729
1730 res = make_char_set (FUNC_NAME);
1731 p = SCM_CHARSET_DATA (res);
1732 q = SCM_CHARSET_DATA (cs);
1733
1734 charsets_complement (p, q);
1735 return res;
1736 }
1737 #undef FUNC_NAME
1738
1739
1740 SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
1741 (SCM rest),
1742 "Return the union of all argument character sets.")
1743 #define FUNC_NAME s_scm_char_set_union
1744 {
1745 int c = 1;
1746 SCM res;
1747 scm_t_char_set *p;
1748
1749 SCM_VALIDATE_REST_ARGUMENT (rest);
1750
1751 res = make_char_set (FUNC_NAME);
1752 p = SCM_CHARSET_DATA (res);
1753 while (!scm_is_null (rest))
1754 {
1755 SCM cs = SCM_CAR (rest);
1756 SCM_VALIDATE_SMOB (c, cs, charset);
1757 c++;
1758 rest = SCM_CDR (rest);
1759
1760
1761 charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs));
1762 }
1763 return res;
1764 }
1765 #undef FUNC_NAME
1766
1767
1768 SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
1769 (SCM rest),
1770 "Return the intersection of all argument character sets.")
1771 #define FUNC_NAME s_scm_char_set_intersection
1772 {
1773 SCM res;
1774
1775 SCM_VALIDATE_REST_ARGUMENT (rest);
1776
1777 if (scm_is_null (rest))
1778 res = make_char_set (FUNC_NAME);
1779 else
1780 {
1781 scm_t_char_set *p;
1782 int argnum = 2;
1783
1784 res = scm_char_set_copy (SCM_CAR (rest));
1785 p = SCM_CHARSET_DATA (res);
1786 rest = SCM_CDR (rest);
1787
1788 while (scm_is_pair (rest))
1789 {
1790 SCM cs = SCM_CAR (rest);
1791 scm_t_char_set *cs_data;
1792
1793 SCM_VALIDATE_SMOB (argnum, cs, charset);
1794 argnum++;
1795 cs_data = SCM_CHARSET_DATA (cs);
1796 rest = SCM_CDR (rest);
1797 charsets_intersection (p, cs_data);
1798 }
1799 }
1800
1801 return res;
1802 }
1803 #undef FUNC_NAME
1804
1805
1806 SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
1807 (SCM cs1, SCM rest),
1808 "Return the difference of all argument character sets.")
1809 #define FUNC_NAME s_scm_char_set_difference
1810 {
1811 int c = 2;
1812 SCM res, compl;
1813 scm_t_char_set *p, *q;
1814
1815 SCM_VALIDATE_SMOB (1, cs1, charset);
1816 SCM_VALIDATE_REST_ARGUMENT (rest);
1817
1818 res = scm_char_set_copy (cs1);
1819 p = SCM_CHARSET_DATA (res);
1820 compl = make_char_set (FUNC_NAME);
1821 q = SCM_CHARSET_DATA (compl);
1822 while (!scm_is_null (rest))
1823 {
1824 SCM cs = SCM_CAR (rest);
1825 SCM_VALIDATE_SMOB (c, cs, charset);
1826 c++;
1827 rest = SCM_CDR (rest);
1828
1829 charsets_complement (q, SCM_CHARSET_DATA (cs));
1830 charsets_intersection (p, q);
1831 }
1832 return res;
1833 }
1834 #undef FUNC_NAME
1835
1836
1837 SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
1838 (SCM rest),
1839 "Return the exclusive-or of all argument character sets.")
1840 #define FUNC_NAME s_scm_char_set_xor
1841 {
1842 SCM res;
1843
1844 SCM_VALIDATE_REST_ARGUMENT (rest);
1845
1846 if (scm_is_null (rest))
1847 res = make_char_set (FUNC_NAME);
1848 else
1849 {
1850 int argnum = 2;
1851 scm_t_char_set *p;
1852
1853 res = scm_char_set_copy (SCM_CAR (rest));
1854 p = SCM_CHARSET_DATA (res);
1855 rest = SCM_CDR (rest);
1856
1857 while (scm_is_pair (rest))
1858 {
1859 SCM cs = SCM_CAR (rest);
1860 scm_t_char_set *cs_data;
1861
1862 SCM_VALIDATE_SMOB (argnum, cs, charset);
1863 argnum++;
1864 cs_data = SCM_CHARSET_DATA (cs);
1865 rest = SCM_CDR (rest);
1866
1867 charsets_xor (p, cs_data);
1868 }
1869 }
1870 return res;
1871 }
1872 #undef FUNC_NAME
1873
1874
1875 SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
1876 (SCM cs1, SCM rest),
1877 "Return the difference and the intersection of all argument\n"
1878 "character sets.")
1879 #define FUNC_NAME s_scm_char_set_diff_plus_intersection
1880 {
1881 int c = 2;
1882 SCM res1, res2;
1883 scm_t_char_set *p, *q;
1884
1885 SCM_VALIDATE_SMOB (1, cs1, charset);
1886 SCM_VALIDATE_REST_ARGUMENT (rest);
1887
1888 res1 = scm_char_set_copy (cs1);
1889 res2 = make_char_set (FUNC_NAME);
1890 p = SCM_CHARSET_DATA (res1);
1891 q = SCM_CHARSET_DATA (res2);
1892 while (!scm_is_null (rest))
1893 {
1894 SCM cs = SCM_CAR (rest);
1895 scm_t_char_set *r;
1896
1897 SCM_VALIDATE_SMOB (c, cs, charset);
1898 c++;
1899 r = SCM_CHARSET_DATA (cs);
1900
1901 charsets_union (q, r);
1902 charsets_intersection (p, r);
1903 rest = SCM_CDR (rest);
1904 }
1905 return scm_values (scm_list_2 (res1, res2));
1906 }
1907 #undef FUNC_NAME
1908
1909
1910 SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
1911 (SCM cs), "Return the complement of the character set @var{cs}.")
1912 #define FUNC_NAME s_scm_char_set_complement_x
1913 {
1914 SCM_VALIDATE_SMOB (1, cs, charset);
1915 cs = scm_char_set_complement (cs);
1916 return cs;
1917 }
1918 #undef FUNC_NAME
1919
1920
1921 SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
1922 (SCM cs1, SCM rest),
1923 "Return the union of all argument character sets.")
1924 #define FUNC_NAME s_scm_char_set_union_x
1925 {
1926 SCM_VALIDATE_SMOB (1, cs1, charset);
1927 SCM_VALIDATE_REST_ARGUMENT (rest);
1928
1929 cs1 = scm_char_set_union (scm_cons (cs1, rest));
1930 return cs1;
1931 }
1932 #undef FUNC_NAME
1933
1934
1935 SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
1936 (SCM cs1, SCM rest),
1937 "Return the intersection of all argument character sets.")
1938 #define FUNC_NAME s_scm_char_set_intersection_x
1939 {
1940 SCM_VALIDATE_SMOB (1, cs1, charset);
1941 SCM_VALIDATE_REST_ARGUMENT (rest);
1942
1943 cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
1944 return cs1;
1945 }
1946 #undef FUNC_NAME
1947
1948
1949 SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
1950 (SCM cs1, SCM rest),
1951 "Return the difference of all argument character sets.")
1952 #define FUNC_NAME s_scm_char_set_difference_x
1953 {
1954 SCM_VALIDATE_SMOB (1, cs1, charset);
1955 SCM_VALIDATE_REST_ARGUMENT (rest);
1956
1957 cs1 = scm_char_set_difference (cs1, rest);
1958 return cs1;
1959 }
1960 #undef FUNC_NAME
1961
1962
1963 SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
1964 (SCM cs1, SCM rest),
1965 "Return the exclusive-or of all argument character sets.")
1966 #define FUNC_NAME s_scm_char_set_xor_x
1967 {
1968 /* a side-effecting variant should presumably give consistent results:
1969 (define a (char-set #\a))
1970 (char-set-xor a a a) -> char set #\a
1971 (char-set-xor! a a a) -> char set #\a
1972 */
1973 cs1 = scm_char_set_xor (scm_cons (cs1, rest));
1974 return cs1;
1975 }
1976 #undef FUNC_NAME
1977
1978
1979 SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
1980 "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
1981 SCM rest),
1982 "Return the difference and the intersection of all argument\n"
1983 "character sets.")
1984 #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
1985 {
1986 SCM diff, intersect;
1987
1988 diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
1989 intersect =
1990 scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
1991 cs1 = diff;
1992 cs2 = intersect;
1993 return scm_values (scm_list_2 (cs1, cs2));
1994 }
1995 #undef FUNC_NAME
1996
1997 \f
1998
1999 /* Standard character sets. */
2000
2001 SCM scm_char_set_lower_case;
2002 SCM scm_char_set_upper_case;
2003 SCM scm_char_set_title_case;
2004 SCM scm_char_set_letter;
2005 SCM scm_char_set_digit;
2006 SCM scm_char_set_letter_and_digit;
2007 SCM scm_char_set_graphic;
2008 SCM scm_char_set_printing;
2009 SCM scm_char_set_whitespace;
2010 SCM scm_char_set_iso_control;
2011 SCM scm_char_set_punctuation;
2012 SCM scm_char_set_symbol;
2013 SCM scm_char_set_hex_digit;
2014 SCM scm_char_set_blank;
2015 SCM scm_char_set_ascii;
2016 SCM scm_char_set_empty;
2017 SCM scm_char_set_full;
2018
2019
2020 /* Create an empty character set and return it after binding it to NAME. */
2021 static inline SCM
2022 define_charset (const char *name, const scm_t_char_set *p)
2023 {
2024 SCM cs;
2025
2026 SCM_NEWSMOB (cs, scm_tc16_charset, p);
2027 scm_c_define (name, cs);
2028 return scm_permanent_object (cs);
2029 }
2030
2031 #ifdef SCM_CHARSET_DEBUG
2032 SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0,
2033 (SCM charset),
2034 "Print out the internal C structure of @var{charset}.\n")
2035 #define FUNC_NAME s_scm_debug_char_set
2036 {
2037 int i;
2038 scm_t_char_set *cs = SCM_CHARSET_DATA (charset);
2039 fprintf (stderr, "cs %p\n", cs);
2040 fprintf (stderr, "len %d\n", cs->len);
2041 fprintf (stderr, "arr %p\n", cs->ranges);
2042 for (i = 0; i < cs->len; i++)
2043 {
2044 if (cs->ranges[i].lo == cs->ranges[i].hi)
2045 fprintf (stderr, "%04x\n", cs->ranges[i].lo);
2046 else
2047 fprintf (stderr, "%04x..%04x\t[%d]\n",
2048 cs->ranges[i].lo,
2049 cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1);
2050 }
2051 printf ("\n");
2052 return SCM_UNSPECIFIED;
2053 }
2054 #undef FUNC_NAME
2055 #endif /* SCM_CHARSET_DEBUG */
2056 \f
2057
2058
2059 void
2060 scm_init_srfi_14 (void)
2061 {
2062 scm_tc16_charset = scm_make_smob_type ("character-set", 0);
2063 scm_set_smob_free (scm_tc16_charset, charset_free);
2064 scm_set_smob_print (scm_tc16_charset, charset_print);
2065
2066 scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
2067 scm_set_smob_free (scm_tc16_charset_cursor, charset_cursor_free);
2068 scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);
2069
2070 scm_char_set_upper_case =
2071 define_charset ("char-set:upper-case", &cs_upper_case);
2072 scm_char_set_lower_case =
2073 define_charset ("char-set:lower-case", &cs_lower_case);
2074 scm_char_set_title_case =
2075 define_charset ("char-set:title-case", &cs_title_case);
2076 scm_char_set_letter = define_charset ("char-set:letter", &cs_letter);
2077 scm_char_set_digit = define_charset ("char-set:digit", &cs_digit);
2078 scm_char_set_letter_and_digit =
2079 define_charset ("char-set:letter+digit", &cs_letter_plus_digit);
2080 scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic);
2081 scm_char_set_printing = define_charset ("char-set:printing", &cs_printing);
2082 scm_char_set_whitespace =
2083 define_charset ("char-set:whitespace", &cs_whitespace);
2084 scm_char_set_iso_control =
2085 define_charset ("char-set:iso-control", &cs_iso_control);
2086 scm_char_set_punctuation =
2087 define_charset ("char-set:punctuation", &cs_punctuation);
2088 scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol);
2089 scm_char_set_hex_digit =
2090 define_charset ("char-set:hex-digit", &cs_hex_digit);
2091 scm_char_set_blank = define_charset ("char-set:blank", &cs_blank);
2092 scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii);
2093 scm_char_set_empty = define_charset ("char-set:empty", &cs_empty);
2094 scm_char_set_full = define_charset ("char-set:full", &cs_full);
2095
2096 #include "libguile/srfi-14.x"
2097 }
2098
2099 /* End of srfi-14.c. */
Unnamed repository; edit this file 'description' to name the repository.