1 /* srfi-14.c --- SRFI-14 procedures for Guile
3 * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
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.
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.
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
30 #include "libguile/srfi-14.h"
31 #include "libguile/strings.h"
33 /* Include the pre-computed standard charset data. */
34 #include "libguile/srfi-14.i.c"
36 #define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
38 #define SCM_CHARSET_SET(cs, idx) \
39 scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)
41 #define SCM_CHARSET_UNSET(cs, idx) \
42 scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)
44 /* Smob type code for character sets. */
45 int scm_tc16_charset
= 0;
46 int scm_tc16_charset_cursor
= 0;
48 /* True if N exists in charset CS. */
50 scm_i_charset_get (scm_t_char_set
*cs
, scm_t_wchar n
)
57 if (cs
->ranges
[i
].lo
<= n
&& n
<= cs
->ranges
[i
].hi
)
65 /* Put N into charset CS. */
67 scm_i_charset_set (scm_t_char_set
*cs
, scm_t_wchar n
)
77 /* Already in this range */
78 if (cs
->ranges
[i
].lo
<= n
&& n
<= cs
->ranges
[i
].hi
)
83 if (n
== cs
->ranges
[i
].lo
- 1)
85 /* This char is one below the current range. */
86 if (i
> 0 && cs
->ranges
[i
- 1].hi
+ 1 == n
)
88 /* It is also one above the previous range, so combine them. */
89 cs
->ranges
[i
- 1].hi
= cs
->ranges
[i
].hi
;
91 memmove (cs
->ranges
+ i
, cs
->ranges
+ (i
+ 1),
92 sizeof (scm_t_char_range
) * (len
- i
- 1));
93 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
94 sizeof (scm_t_char_range
) * len
,
95 sizeof (scm_t_char_range
) * (len
-
103 /* Expand the range down by one. */
104 cs
->ranges
[i
].lo
= n
;
108 else if (n
== cs
->ranges
[i
].hi
+ 1)
110 /* This char is one above the current range. */
111 if (i
< len
- 1 && cs
->ranges
[i
+ 1].lo
- 1 == n
)
113 /* It is also one below the next range, so combine them. */
114 cs
->ranges
[i
].hi
= cs
->ranges
[i
+ 1].hi
;
116 memmove (cs
->ranges
+ (i
+ 1), cs
->ranges
+ (i
+ 2),
117 sizeof (scm_t_char_range
) * (len
- i
- 2));
118 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
119 sizeof (scm_t_char_range
) * len
,
120 sizeof (scm_t_char_range
) * (len
-
128 /* Expand the range up by one. */
129 cs
->ranges
[i
].hi
= n
;
133 else if (n
< cs
->ranges
[i
].lo
- 1)
135 /* This is a new range below the current one. */
136 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
137 sizeof (scm_t_char_range
) * len
,
138 sizeof (scm_t_char_range
) * (len
+ 1),
140 memmove (cs
->ranges
+ (i
+ 1), cs
->ranges
+ i
,
141 sizeof (scm_t_char_range
) * (len
- i
));
142 cs
->ranges
[i
].lo
= n
;
143 cs
->ranges
[i
].hi
= n
;
151 /* This is a new range above all previous ranges. */
154 cs
->ranges
= scm_gc_malloc (sizeof (scm_t_char_range
), "character-set");
158 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
159 sizeof (scm_t_char_range
) * len
,
160 sizeof (scm_t_char_range
) * (len
+ 1),
163 cs
->ranges
[len
].lo
= n
;
164 cs
->ranges
[len
].hi
= n
;
170 /* If N is in charset CS, remove it. */
172 scm_i_charset_unset (scm_t_char_set
*cs
, scm_t_wchar n
)
182 if (n
< cs
->ranges
[i
].lo
)
183 /* Not in this set. */
186 if (n
== cs
->ranges
[i
].lo
&& n
== cs
->ranges
[i
].hi
)
188 /* Remove this one-character range. */
191 scm_gc_free (cs
->ranges
,
192 sizeof (scm_t_char_range
) * cs
->len
,
198 else if (i
< len
- 1)
200 memmove (cs
->ranges
+ i
, cs
->ranges
+ (i
+ 1),
201 sizeof (scm_t_char_range
) * (len
- i
- 1));
202 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
203 sizeof (scm_t_char_range
) * len
,
204 sizeof (scm_t_char_range
) * (len
-
210 else if (i
== len
- 1)
212 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
213 sizeof (scm_t_char_range
) * len
,
214 sizeof (scm_t_char_range
) * (len
-
221 else if (n
== cs
->ranges
[i
].lo
)
223 /* Shrink this range from the left. */
224 cs
->ranges
[i
].lo
= n
+ 1;
227 else if (n
== cs
->ranges
[i
].hi
)
229 /* Shrink this range from the right. */
230 cs
->ranges
[i
].hi
= n
- 1;
233 else if (n
> cs
->ranges
[i
].lo
&& n
< cs
->ranges
[i
].hi
)
235 /* Split this range into two pieces. */
236 cs
->ranges
= scm_gc_realloc (cs
->ranges
,
237 sizeof (scm_t_char_range
) * len
,
238 sizeof (scm_t_char_range
) * (len
+ 1),
241 memmove (cs
->ranges
+ (i
+ 2), cs
->ranges
+ (i
+ 1),
242 sizeof (scm_t_char_range
) * (len
- i
- 1));
243 cs
->ranges
[i
+ 1].hi
= cs
->ranges
[i
].hi
;
244 cs
->ranges
[i
+ 1].lo
= n
+ 1;
245 cs
->ranges
[i
].hi
= n
- 1;
253 /* This value is above all ranges, so do nothing here. */
258 charsets_equal (scm_t_char_set
*a
, scm_t_char_set
*b
)
260 if (a
->len
!= b
->len
)
263 if (memcmp (a
->ranges
, b
->ranges
, sizeof (scm_t_char_range
) * a
->len
) != 0)
269 /* Return true if every character in A is also in B. */
271 charsets_leq (scm_t_char_set
*a
, scm_t_char_set
*b
)
274 scm_t_wchar alo
, ahi
;
282 alo
= a
->ranges
[i
].lo
;
283 ahi
= a
->ranges
[i
].hi
;
284 while (b
->ranges
[j
].hi
< alo
)
291 if (alo
< b
->ranges
[j
].lo
|| ahi
> b
->ranges
[j
].hi
)
299 /* Merge B into A. */
301 charsets_union (scm_t_char_set
*a
, scm_t_char_set
*b
)
304 scm_t_wchar blo
, bhi
, n
;
312 a
->ranges
= scm_gc_malloc (sizeof (scm_t_char_range
) * b
->len
,
314 memcpy (a
->ranges
, b
->ranges
, sizeof (scm_t_char_range
) * b
->len
);
318 /* This needs optimization. */
321 blo
= b
->ranges
[i
].lo
;
322 bhi
= b
->ranges
[i
].hi
;
323 for (n
= blo
; n
<= bhi
; n
++)
324 scm_i_charset_set (a
, n
);
332 /* Remove elements not both in A and B from A. */
334 charsets_intersection (scm_t_char_set
*a
, scm_t_char_set
*b
)
337 scm_t_wchar blo
, bhi
, n
;
345 scm_gc_free (a
->ranges
, sizeof (scm_t_char_range
) * a
->len
,
351 c
= (scm_t_char_set
*) scm_malloc (sizeof (scm_t_char_set
));
357 blo
= b
->ranges
[i
].lo
;
358 bhi
= b
->ranges
[i
].hi
;
359 for (n
= blo
; n
<= bhi
; n
++)
360 if (scm_i_charset_get (a
, n
))
361 scm_i_charset_set (c
, n
);
364 scm_gc_free (a
->ranges
, sizeof (scm_t_char_range
) * a
->len
,
369 a
->ranges
= c
->ranges
;
376 /* Make P the compelement of Q. */
378 charsets_complement (scm_t_char_set
*p
, scm_t_char_set
*q
)
384 /* Fill with all valid codepoints. */
386 p
->ranges
= scm_gc_malloc (sizeof (scm_t_char_range
) * 2,
389 p
->ranges
[0].hi
= 0xd7ff;
390 p
->ranges
[1].lo
= 0xe000;
391 p
->ranges
[1].hi
= SCM_CODEPOINT_MAX
;
396 scm_gc_free (p
->ranges
, sizeof (scm_t_char_set
) * p
->len
,
400 if (q
->ranges
[0].lo
> 0)
402 if (q
->ranges
[q
->len
- 1].hi
< SCM_CODEPOINT_MAX
)
404 p
->len
+= q
->len
- 1;
406 (scm_t_char_range
*) scm_gc_malloc (sizeof (scm_t_char_range
) * p
->len
,
409 if (q
->ranges
[0].lo
> 0)
411 p
->ranges
[idx
].lo
= 0;
412 p
->ranges
[idx
++].hi
= q
->ranges
[0].lo
- 1;
414 for (k
= 1; k
< q
->len
; k
++)
416 p
->ranges
[idx
].lo
= q
->ranges
[k
- 1].hi
+ 1;
417 p
->ranges
[idx
++].hi
= q
->ranges
[k
].lo
- 1;
419 if (q
->ranges
[q
->len
- 1].hi
< SCM_CODEPOINT_MAX
)
421 p
->ranges
[idx
].lo
= q
->ranges
[q
->len
- 1].hi
+ 1;
422 p
->ranges
[idx
].hi
= SCM_CODEPOINT_MAX
;
427 /* Replace A with elements only found in one of A or B. */
429 charsets_xor (scm_t_char_set
*a
, scm_t_char_set
*b
)
432 scm_t_wchar blo
, bhi
, n
;
442 (scm_t_char_range
*) scm_gc_malloc (sizeof (scm_t_char_range
) *
443 b
->len
, "character-set");
445 memcpy (a
->ranges
, b
->ranges
, sizeof (scm_t_char_range
) * a
->len
);
451 blo
= b
->ranges
[i
].lo
;
452 bhi
= b
->ranges
[i
].hi
;
453 for (n
= blo
; n
<= bhi
; n
++)
455 if (scm_i_charset_get (a
, n
))
456 scm_i_charset_unset (a
, n
);
458 scm_i_charset_set (a
, n
);
466 /* Smob print hook for character sets. */
468 charset_print (SCM charset
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
473 const size_t max_ranges_to_print
= 50;
475 p
= SCM_CHARSET_DATA (charset
);
477 scm_puts ("#<charset {", port
);
478 for (i
= 0; i
< p
->len
; i
++)
483 scm_puts (" ", port
);
484 scm_write (SCM_MAKE_CHAR (p
->ranges
[i
].lo
), port
);
485 if (p
->ranges
[i
].lo
!= p
->ranges
[i
].hi
)
487 scm_puts ("..", port
);
488 scm_write (SCM_MAKE_CHAR (p
->ranges
[i
].hi
), port
);
490 if (i
>= max_ranges_to_print
)
492 /* Too many to print here. Quit early. */
493 scm_puts (" ...", port
);
497 scm_puts ("}>", port
);
502 /* Smob free hook for character sets. */
504 charset_free (SCM charset
)
509 cs
= SCM_CHARSET_DATA (charset
);
513 scm_gc_free (cs
->ranges
, sizeof (scm_t_char_range
) * len
,
519 scm_gc_free (cs
, sizeof (scm_t_char_set
), "character-set");
521 scm_remember_upto_here_1 (charset
);
527 /* Smob print hook for character sets cursors. */
529 charset_cursor_print (SCM cursor
, SCM port
,
530 scm_print_state
*pstate SCM_UNUSED
)
532 scm_t_char_set_cursor
*cur
;
534 cur
= (scm_t_char_set_cursor
*) SCM_SMOB_DATA (cursor
);
536 scm_puts ("#<charset-cursor ", port
);
537 if (cur
->range
== (size_t) (-1))
538 scm_puts ("(empty)", port
);
541 scm_write (scm_from_size_t (cur
->range
), port
);
542 scm_puts (":", port
);
543 scm_write (scm_from_int32 (cur
->n
), port
);
545 scm_puts (">", port
);
549 /* Smob free hook for character sets. */
551 charset_cursor_free (SCM charset
)
553 scm_t_char_set_cursor
*cur
;
555 cur
= (scm_t_char_set_cursor
*) SCM_SMOB_DATA (charset
);
556 scm_gc_free (cur
, sizeof (scm_t_char_set_cursor
), "charset-cursor");
557 scm_remember_upto_here_1 (charset
);
563 /* Create a new, empty character set. */
565 make_char_set (const char *func_name
)
569 p
= scm_gc_malloc (sizeof (scm_t_char_set
), "character-set");
570 memset (p
, 0, sizeof (scm_t_char_set
));
571 SCM_RETURN_NEWSMOB (scm_tc16_charset
, p
);
575 SCM_DEFINE (scm_char_set_p
, "char-set?", 1, 0, 0,
577 "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
579 #define FUNC_NAME s_scm_char_set_p
581 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset
, obj
));
586 SCM_DEFINE (scm_char_set_eq
, "char-set=", 0, 0, 1,
588 "Return @code{#t} if all given character sets are equal.")
589 #define FUNC_NAME s_scm_char_set_eq
592 scm_t_char_set
*cs1_data
= NULL
;
594 SCM_VALIDATE_REST_ARGUMENT (char_sets
);
596 while (!scm_is_null (char_sets
))
598 SCM csi
= SCM_CAR (char_sets
);
599 scm_t_char_set
*csi_data
;
601 SCM_VALIDATE_SMOB (argnum
, csi
, charset
);
603 csi_data
= SCM_CHARSET_DATA (csi
);
604 if (cs1_data
== NULL
)
606 else if (!charsets_equal (cs1_data
, csi_data
))
608 char_sets
= SCM_CDR (char_sets
);
615 SCM_DEFINE (scm_char_set_leq
, "char-set<=", 0, 0, 1,
617 "Return @code{#t} if every character set @var{cs}i is a subset\n"
618 "of character set @var{cs}i+1.")
619 #define FUNC_NAME s_scm_char_set_leq
622 scm_t_char_set
*prev_data
= NULL
;
624 SCM_VALIDATE_REST_ARGUMENT (char_sets
);
626 while (!scm_is_null (char_sets
))
628 SCM csi
= SCM_CAR (char_sets
);
629 scm_t_char_set
*csi_data
;
631 SCM_VALIDATE_SMOB (argnum
, csi
, charset
);
633 csi_data
= SCM_CHARSET_DATA (csi
);
636 if (!charsets_leq (prev_data
, csi_data
))
639 prev_data
= csi_data
;
640 char_sets
= SCM_CDR (char_sets
);
647 SCM_DEFINE (scm_char_set_hash
, "char-set-hash", 1, 1, 0,
649 "Compute a hash value for the character set @var{cs}. If\n"
650 "@var{bound} is given and non-zero, it restricts the\n"
651 "returned value to the range 0 @dots{} @var{bound - 1}.")
652 #define FUNC_NAME s_scm_char_set_hash
654 const unsigned long default_bnd
= 871;
657 unsigned long val
= 0;
661 SCM_VALIDATE_SMOB (1, cs
, charset
);
663 if (SCM_UNBNDP (bound
))
667 bnd
= scm_to_ulong (bound
);
672 p
= SCM_CHARSET_DATA (cs
);
673 for (k
= 0; k
< p
->len
; k
++)
675 for (c
= p
->ranges
[k
].lo
; c
<= p
->ranges
[k
].hi
; c
++)
676 val
= c
+ (val
<< 1);
678 return scm_from_ulong (val
% bnd
);
683 SCM_DEFINE (scm_char_set_cursor
, "char-set-cursor", 1, 0, 0,
684 (SCM cs
), "Return a cursor into the character set @var{cs}.")
685 #define FUNC_NAME s_scm_char_set_cursor
687 scm_t_char_set
*cs_data
;
688 scm_t_char_set_cursor
*cur_data
;
690 SCM_VALIDATE_SMOB (1, cs
, charset
);
691 cs_data
= SCM_CHARSET_DATA (cs
);
693 (scm_t_char_set_cursor
*) scm_gc_malloc (sizeof (scm_t_char_set_cursor
),
695 if (cs_data
->len
== 0)
697 cur_data
->range
= (size_t) (-1);
703 cur_data
->n
= cs_data
->ranges
[0].lo
;
705 SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor
, cur_data
);
711 SCM_DEFINE (scm_char_set_ref
, "char-set-ref", 2, 0, 0,
712 (SCM cs
, SCM cursor
),
713 "Return the character at the current cursor position\n"
714 "@var{cursor} in the character set @var{cs}. It is an error to\n"
715 "pass a cursor for which @code{end-of-char-set?} returns true.")
716 #define FUNC_NAME s_scm_char_set_ref
718 scm_t_char_set
*cs_data
;
719 scm_t_char_set_cursor
*cur_data
;
722 SCM_VALIDATE_SMOB (1, cs
, charset
);
723 SCM_VALIDATE_SMOB (2, cursor
, charset_cursor
);
725 cs_data
= SCM_CHARSET_DATA (cs
);
726 cur_data
= (scm_t_char_set_cursor
*) SCM_SMOB_DATA (cursor
);
728 /* Validate that this cursor is still true. */
730 if (i
== (size_t) (-1)
732 || cur_data
->n
< cs_data
->ranges
[i
].lo
733 || cur_data
->n
> cs_data
->ranges
[i
].hi
)
734 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor
));
735 return SCM_MAKE_CHAR (cur_data
->n
);
741 SCM_DEFINE (scm_char_set_cursor_next
, "char-set-cursor-next", 2, 0, 0,
742 (SCM cs
, SCM cursor
),
743 "Advance the character set cursor @var{cursor} to the next\n"
744 "character in the character set @var{cs}. It is an error if the\n"
745 "cursor given satisfies @code{end-of-char-set?}.")
746 #define FUNC_NAME s_scm_char_set_cursor_next
748 scm_t_char_set
*cs_data
;
749 scm_t_char_set_cursor
*cur_data
;
752 SCM_VALIDATE_SMOB (1, cs
, charset
);
753 SCM_VALIDATE_SMOB (2, cursor
, charset_cursor
);
755 cs_data
= SCM_CHARSET_DATA (cs
);
756 cur_data
= (scm_t_char_set_cursor
*) SCM_SMOB_DATA (cursor
);
758 /* Validate that this cursor is still true. */
760 if (i
== (size_t) (-1)
762 || cur_data
->n
< cs_data
->ranges
[i
].lo
763 || cur_data
->n
> cs_data
->ranges
[i
].hi
)
764 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor
));
765 /* Increment the cursor. */
766 if (cur_data
->n
== cs_data
->ranges
[i
].hi
)
768 if (i
+ 1 < cs_data
->len
)
770 cur_data
->range
= i
+ 1;
771 cur_data
->n
= cs_data
->ranges
[i
+ 1].lo
;
775 /* This is the end of the road. */
776 cur_data
->range
= (size_t) (-1);
782 cur_data
->n
= cur_data
->n
+ 1;
791 SCM_DEFINE (scm_end_of_char_set_p
, "end-of-char-set?", 1, 0, 0,
793 "Return @code{#t} if @var{cursor} has reached the end of a\n"
794 "character set, @code{#f} otherwise.")
795 #define FUNC_NAME s_scm_end_of_char_set_p
797 scm_t_char_set_cursor
*cur_data
;
798 SCM_VALIDATE_SMOB (1, cursor
, charset_cursor
);
800 cur_data
= (scm_t_char_set_cursor
*) SCM_SMOB_DATA (cursor
);
801 if (cur_data
->range
== (size_t) (-1))
810 SCM_DEFINE (scm_char_set_fold
, "char-set-fold", 3, 0, 0,
811 (SCM kons
, SCM knil
, SCM cs
),
812 "Fold the procedure @var{kons} over the character set @var{cs},\n"
813 "initializing it with @var{knil}.")
814 #define FUNC_NAME s_scm_char_set_fold
816 scm_t_char_set
*cs_data
;
820 SCM_VALIDATE_PROC (1, kons
);
821 SCM_VALIDATE_SMOB (3, cs
, charset
);
823 cs_data
= SCM_CHARSET_DATA (cs
);
825 if (cs_data
->len
== 0)
828 for (k
= 0; k
< cs_data
->len
; k
++)
829 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
831 knil
= scm_call_2 (kons
, SCM_MAKE_CHAR (n
), knil
);
838 SCM_DEFINE (scm_char_set_unfold
, "char-set-unfold", 4, 1, 0,
839 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base_cs
),
840 "This is a fundamental constructor for character sets.\n"
842 "@item @var{g} is used to generate a series of ``seed'' values\n"
843 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
844 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
845 "@item @var{p} tells us when to stop -- when it returns true\n"
846 "when applied to one of the seed values.\n"
847 "@item @var{f} maps each seed value to a character. These\n"
848 "characters are added to the base character set @var{base_cs} to\n"
849 "form the result; @var{base_cs} defaults to the empty set.\n"
851 #define FUNC_NAME s_scm_char_set_unfold
855 SCM_VALIDATE_PROC (1, p
);
856 SCM_VALIDATE_PROC (2, f
);
857 SCM_VALIDATE_PROC (3, g
);
858 if (!SCM_UNBNDP (base_cs
))
860 SCM_VALIDATE_SMOB (5, base_cs
, charset
);
861 result
= scm_char_set_copy (base_cs
);
864 result
= make_char_set (FUNC_NAME
);
866 tmp
= scm_call_1 (p
, seed
);
867 while (scm_is_false (tmp
))
869 SCM ch
= scm_call_1 (f
, seed
);
871 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
872 SCM_CHARSET_SET (result
, SCM_CHAR (ch
));
874 seed
= scm_call_1 (g
, seed
);
875 tmp
= scm_call_1 (p
, seed
);
882 SCM_DEFINE (scm_char_set_unfold_x
, "char-set-unfold!", 5, 0, 0,
883 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base_cs
),
884 "This is a fundamental constructor for character sets.\n"
886 "@item @var{g} is used to generate a series of ``seed'' values\n"
887 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
888 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
889 "@item @var{p} tells us when to stop -- when it returns true\n"
890 "when applied to one of the seed values.\n"
891 "@item @var{f} maps each seed value to a character. These\n"
892 "characters are added to the base character set @var{base_cs} to\n"
893 "form the result; @var{base_cs} defaults to the empty set.\n"
895 #define FUNC_NAME s_scm_char_set_unfold_x
899 SCM_VALIDATE_PROC (1, p
);
900 SCM_VALIDATE_PROC (2, f
);
901 SCM_VALIDATE_PROC (3, g
);
902 SCM_VALIDATE_SMOB (5, base_cs
, charset
);
904 tmp
= scm_call_1 (p
, seed
);
905 while (scm_is_false (tmp
))
907 SCM ch
= scm_call_1 (f
, seed
);
909 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
910 SCM_CHARSET_SET (base_cs
, SCM_CHAR (ch
));
912 seed
= scm_call_1 (g
, seed
);
913 tmp
= scm_call_1 (p
, seed
);
920 SCM_DEFINE (scm_char_set_for_each
, "char-set-for-each", 2, 0, 0,
922 "Apply @var{proc} to every character in the character set\n"
923 "@var{cs}. The return value is not specified.")
924 #define FUNC_NAME s_scm_char_set_for_each
926 scm_t_char_set
*cs_data
;
930 SCM_VALIDATE_PROC (1, proc
);
931 SCM_VALIDATE_SMOB (2, cs
, charset
);
933 cs_data
= SCM_CHARSET_DATA (cs
);
935 if (cs_data
->len
== 0)
936 return SCM_UNSPECIFIED
;
938 for (k
= 0; k
< cs_data
->len
; k
++)
939 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
941 scm_call_1 (proc
, SCM_MAKE_CHAR (n
));
944 return SCM_UNSPECIFIED
;
950 SCM_DEFINE (scm_char_set_map
, "char-set-map", 2, 0, 0,
952 "Map the procedure @var{proc} over every character in @var{cs}.\n"
953 "@var{proc} must be a character -> character procedure.")
954 #define FUNC_NAME s_scm_char_set_map
958 scm_t_char_set
*cs_data
;
961 SCM_VALIDATE_PROC (1, proc
);
962 SCM_VALIDATE_SMOB (2, cs
, charset
);
964 result
= make_char_set (FUNC_NAME
);
965 cs_data
= SCM_CHARSET_DATA (cs
);
967 if (cs_data
->len
== 0)
970 for (k
= 0; k
< cs_data
->len
; k
++)
971 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
973 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (n
));
975 SCM_MISC_ERROR ("procedure ~S returned non-char",
977 SCM_CHARSET_SET (result
, SCM_CHAR (ch
));
984 SCM_DEFINE (scm_char_set_copy
, "char-set-copy", 1, 0, 0,
986 "Return a newly allocated character set containing all\n"
987 "characters in @var{cs}.")
988 #define FUNC_NAME s_scm_char_set_copy
991 scm_t_char_set
*p1
, *p2
;
993 SCM_VALIDATE_SMOB (1, cs
, charset
);
994 ret
= make_char_set (FUNC_NAME
);
995 p1
= SCM_CHARSET_DATA (cs
);
996 p2
= SCM_CHARSET_DATA (ret
);
1003 p2
->ranges
= scm_gc_malloc (sizeof (scm_t_char_range
) * p1
->len
,
1005 memcpy (p2
->ranges
, p1
->ranges
, sizeof (scm_t_char_range
) * p1
->len
);
1014 SCM_DEFINE (scm_char_set
, "char-set", 0, 0, 1,
1016 "Return a character set containing all given characters.")
1017 #define FUNC_NAME s_scm_char_set
1022 SCM_VALIDATE_REST_ARGUMENT (rest
);
1023 cs
= make_char_set (FUNC_NAME
);
1024 while (!scm_is_null (rest
))
1028 SCM_VALIDATE_CHAR_COPY (argnum
, SCM_CAR (rest
), c
);
1030 rest
= SCM_CDR (rest
);
1031 SCM_CHARSET_SET (cs
, c
);
1038 SCM_DEFINE (scm_list_to_char_set
, "list->char-set", 1, 1, 0,
1039 (SCM list
, SCM base_cs
),
1040 "Convert the character list @var{list} to a character set. If\n"
1041 "the character set @var{base_cs} is given, the character in this\n"
1042 "set are also included in the result.")
1043 #define FUNC_NAME s_scm_list_to_char_set
1047 SCM_VALIDATE_LIST (1, list
);
1048 if (SCM_UNBNDP (base_cs
))
1049 cs
= make_char_set (FUNC_NAME
);
1052 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
1053 cs
= scm_char_set_copy (base_cs
);
1055 while (!scm_is_null (list
))
1057 SCM chr
= SCM_CAR (list
);
1060 SCM_VALIDATE_CHAR_COPY (0, chr
, c
);
1061 list
= SCM_CDR (list
);
1064 SCM_CHARSET_SET (cs
, c
);
1071 SCM_DEFINE (scm_list_to_char_set_x
, "list->char-set!", 2, 0, 0,
1072 (SCM list
, SCM base_cs
),
1073 "Convert the character list @var{list} to a character set. The\n"
1074 "characters are added to @var{base_cs} and @var{base_cs} is\n"
1076 #define FUNC_NAME s_scm_list_to_char_set_x
1078 SCM_VALIDATE_LIST (1, list
);
1079 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
1080 while (!scm_is_null (list
))
1082 SCM chr
= SCM_CAR (list
);
1085 SCM_VALIDATE_CHAR_COPY (0, chr
, c
);
1086 list
= SCM_CDR (list
);
1088 SCM_CHARSET_SET (base_cs
, c
);
1095 SCM_DEFINE (scm_string_to_char_set
, "string->char-set", 1, 1, 0,
1096 (SCM str
, SCM base_cs
),
1097 "Convert the string @var{str} to a character set. If the\n"
1098 "character set @var{base_cs} is given, the characters in this\n"
1099 "set are also included in the result.")
1100 #define FUNC_NAME s_scm_string_to_char_set
1105 SCM_VALIDATE_STRING (1, str
);
1106 if (SCM_UNBNDP (base_cs
))
1107 cs
= make_char_set (FUNC_NAME
);
1110 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
1111 cs
= scm_char_set_copy (base_cs
);
1113 len
= scm_i_string_length (str
);
1116 scm_t_wchar c
= scm_i_string_ref (str
, k
++);
1117 SCM_CHARSET_SET (cs
, c
);
1119 scm_remember_upto_here_1 (str
);
1125 SCM_DEFINE (scm_string_to_char_set_x
, "string->char-set!", 2, 0, 0,
1126 (SCM str
, SCM base_cs
),
1127 "Convert the string @var{str} to a character set. The\n"
1128 "characters from the string are added to @var{base_cs}, and\n"
1129 "@var{base_cs} is returned.")
1130 #define FUNC_NAME s_scm_string_to_char_set_x
1134 SCM_VALIDATE_STRING (1, str
);
1135 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
1136 len
= scm_i_string_length (str
);
1139 scm_t_wchar c
= scm_i_string_ref (str
, k
++);
1140 SCM_CHARSET_SET (base_cs
, c
);
1142 scm_remember_upto_here_1 (str
);
1148 SCM_DEFINE (scm_char_set_filter
, "char-set-filter", 2, 1, 0,
1149 (SCM pred
, SCM cs
, SCM base_cs
),
1150 "Return a character set containing every character from @var{cs}\n"
1151 "so that it satisfies @var{pred}. If provided, the characters\n"
1152 "from @var{base_cs} are added to the result.")
1153 #define FUNC_NAME s_scm_char_set_filter
1160 SCM_VALIDATE_PROC (1, pred
);
1161 SCM_VALIDATE_SMOB (2, cs
, charset
);
1162 if (!SCM_UNBNDP (base_cs
))
1164 SCM_VALIDATE_SMOB (3, base_cs
, charset
);
1165 ret
= scm_char_set_copy (base_cs
);
1168 ret
= make_char_set (FUNC_NAME
);
1170 p
= SCM_CHARSET_DATA (cs
);
1175 for (k
= 0; k
< p
->len
; k
++)
1176 for (n
= p
->ranges
[k
].lo
; n
<= p
->ranges
[k
].hi
; n
++)
1178 SCM res
= scm_call_1 (pred
, SCM_MAKE_CHAR (n
));
1180 if (scm_is_true (res
))
1181 SCM_CHARSET_SET (ret
, n
);
1189 SCM_DEFINE (scm_char_set_filter_x
, "char-set-filter!", 3, 0, 0,
1190 (SCM pred
, SCM cs
, SCM base_cs
),
1191 "Return a character set containing every character from @var{cs}\n"
1192 "so that it satisfies @var{pred}. The characters are added to\n"
1193 "@var{base_cs} and @var{base_cs} is returned.")
1194 #define FUNC_NAME s_scm_char_set_filter_x
1200 SCM_VALIDATE_PROC (1, pred
);
1201 SCM_VALIDATE_SMOB (2, cs
, charset
);
1202 SCM_VALIDATE_SMOB (3, base_cs
, charset
);
1203 p
= SCM_CHARSET_DATA (cs
);
1207 for (k
= 0; k
< p
->len
; k
++)
1208 for (n
= p
->ranges
[k
].lo
; n
<= p
->ranges
[k
].hi
; n
++)
1210 SCM res
= scm_call_1 (pred
, SCM_MAKE_CHAR (k
));
1212 if (scm_is_true (res
))
1213 SCM_CHARSET_SET (base_cs
, n
);
1221 SCM_DEFINE (scm_ucs_range_to_char_set
, "ucs-range->char-set", 2, 2, 0,
1222 (SCM lower
, SCM upper
, SCM error
, SCM base_cs
),
1223 "Return a character set containing all characters whose\n"
1224 "character codes lie in the half-open range\n"
1225 "[@var{lower},@var{upper}).\n"
1227 "If @var{error} is a true value, an error is signalled if the\n"
1228 "specified range contains characters which are not contained in\n"
1229 "the implemented character range. If @var{error} is @code{#f},\n"
1230 "these characters are silently left out of the resultung\n"
1233 "The characters in @var{base_cs} are added to the result, if\n"
1235 #define FUNC_NAME s_scm_ucs_range_to_char_set
1238 size_t clower
, cupper
;
1240 clower
= scm_to_size_t (lower
);
1241 cupper
= scm_to_size_t (upper
);
1242 SCM_ASSERT_RANGE (2, upper
, cupper
>= clower
);
1243 if (!SCM_UNBNDP (error
))
1245 if (scm_is_true (error
))
1247 SCM_ASSERT_RANGE (1, lower
, SCM_IS_UNICODE_CHAR (clower
));
1248 SCM_ASSERT_RANGE (2, upper
, SCM_IS_UNICODE_CHAR (cupper
));
1251 if (clower
> 0x10FFFF)
1253 if (cupper
> 0x10FFFF)
1255 if (SCM_UNBNDP (base_cs
))
1256 cs
= make_char_set (FUNC_NAME
);
1259 SCM_VALIDATE_SMOB (4, base_cs
, charset
);
1260 cs
= scm_char_set_copy (base_cs
);
1262 /* It not be difficult to write a more optimized version of the
1264 while (clower
< cupper
)
1266 SCM_CHARSET_SET (cs
, clower
);
1274 SCM_DEFINE (scm_ucs_range_to_char_set_x
, "ucs-range->char-set!", 4, 0, 0,
1275 (SCM lower
, SCM upper
, SCM error
, SCM base_cs
),
1276 "Return a character set containing all characters whose\n"
1277 "character codes lie in the half-open range\n"
1278 "[@var{lower},@var{upper}).\n"
1280 "If @var{error} is a true value, an error is signalled if the\n"
1281 "specified range contains characters which are not contained in\n"
1282 "the implemented character range. If @var{error} is @code{#f},\n"
1283 "these characters are silently left out of the resultung\n"
1286 "The characters are added to @var{base_cs} and @var{base_cs} is\n"
1288 #define FUNC_NAME s_scm_ucs_range_to_char_set_x
1290 size_t clower
, cupper
;
1292 clower
= scm_to_size_t (lower
);
1293 cupper
= scm_to_size_t (upper
);
1294 SCM_ASSERT_RANGE (2, upper
, cupper
>= clower
);
1295 if (scm_is_true (error
))
1297 SCM_ASSERT_RANGE (1, lower
, SCM_IS_UNICODE_CHAR (clower
));
1298 SCM_ASSERT_RANGE (2, upper
, SCM_IS_UNICODE_CHAR (cupper
));
1300 if (clower
> SCM_CODEPOINT_MAX
)
1301 clower
= SCM_CODEPOINT_MAX
;
1302 if (cupper
> SCM_CODEPOINT_MAX
)
1303 cupper
= SCM_CODEPOINT_MAX
;
1305 while (clower
< cupper
)
1307 if (SCM_IS_UNICODE_CHAR (clower
))
1308 SCM_CHARSET_SET (base_cs
, clower
);
1315 SCM_DEFINE (scm_to_char_set
, "->char-set", 1, 0, 0,
1317 "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.")
1318 #define FUNC_NAME s_scm_to_char_set
1320 if (scm_is_string (x
))
1321 return scm_string_to_char_set (x
, SCM_UNDEFINED
);
1322 else if (SCM_CHARP (x
))
1323 return scm_char_set (scm_list_1 (x
));
1324 else if (SCM_SMOB_PREDICATE (scm_tc16_charset
, x
))
1327 scm_wrong_type_arg (NULL
, 0, x
);
1331 SCM_DEFINE (scm_char_set_size
, "char-set-size", 1, 0, 0,
1333 "Return the number of elements in character set @var{cs}.")
1334 #define FUNC_NAME s_scm_char_set_size
1337 scm_t_char_set
*cs_data
;
1339 SCM_VALIDATE_SMOB (1, cs
, charset
);
1340 cs_data
= SCM_CHARSET_DATA (cs
);
1342 if (cs_data
->len
== 0)
1343 return scm_from_int (0);
1345 for (k
= 0; k
< cs_data
->len
; k
++)
1346 count
+= cs_data
->ranges
[k
].hi
- cs_data
->ranges
[k
].lo
+ 1;
1348 return scm_from_int (count
);
1354 SCM_DEFINE (scm_char_set_count
, "char-set-count", 2, 0, 0,
1356 "Return the number of the elements int the character set\n"
1357 "@var{cs} which satisfy the predicate @var{pred}.")
1358 #define FUNC_NAME s_scm_char_set_count
1362 scm_t_char_set
*cs_data
;
1364 SCM_VALIDATE_PROC (1, pred
);
1365 SCM_VALIDATE_SMOB (2, cs
, charset
);
1366 cs_data
= SCM_CHARSET_DATA (cs
);
1367 if (cs_data
->len
== 0)
1368 return scm_from_int (0);
1370 for (k
= 0; k
< cs_data
->len
; k
++)
1371 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
1373 SCM res
= scm_call_1 (pred
, SCM_MAKE_CHAR (n
));
1374 if (scm_is_true (res
))
1377 return SCM_I_MAKINUM (count
);
1382 SCM_DEFINE (scm_char_set_to_list
, "char-set->list", 1, 0, 0,
1384 "Return a list containing the elements of the character set\n"
1386 #define FUNC_NAME s_scm_char_set_to_list
1390 SCM result
= SCM_EOL
;
1393 SCM_VALIDATE_SMOB (1, cs
, charset
);
1394 p
= SCM_CHARSET_DATA (cs
);
1398 for (k
= p
->len
- 1; k
>= 0; k
--)
1399 for (n
= p
->ranges
[k
].hi
; n
>= p
->ranges
[k
].lo
; n
--)
1400 result
= scm_cons (SCM_MAKE_CHAR (n
), result
);
1407 SCM_DEFINE (scm_char_set_to_string
, "char-set->string", 1, 0, 0,
1409 "Return a string containing the elements of the character set\n"
1410 "@var{cs}. The order in which the characters are placed in the\n"
1411 "string is not defined.")
1412 #define FUNC_NAME s_scm_char_set_to_string
1420 scm_t_char_set
*cs_data
;
1424 SCM_VALIDATE_SMOB (1, cs
, charset
);
1425 cs_data
= SCM_CHARSET_DATA (cs
);
1426 if (cs_data
->len
== 0)
1429 if (cs_data
->ranges
[cs_data
->len
- 1].hi
> 255)
1432 count
= scm_to_int (scm_char_set_size (cs
));
1434 result
= scm_i_make_wide_string (count
, &wbuf
);
1436 result
= scm_i_make_string (count
, &buf
);
1438 for (k
= 0; k
< cs_data
->len
; k
++)
1439 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
1452 SCM_DEFINE (scm_char_set_contains_p
, "char-set-contains?", 2, 0, 0,
1454 "Return @code{#t} iff the character @var{ch} is contained in the\n"
1455 "character set @var{cs}.")
1456 #define FUNC_NAME s_scm_char_set_contains_p
1458 SCM_VALIDATE_SMOB (1, cs
, charset
);
1459 SCM_VALIDATE_CHAR (2, ch
);
1460 return scm_from_bool (SCM_CHARSET_GET (cs
, SCM_CHAR (ch
)));
1465 SCM_DEFINE (scm_char_set_every
, "char-set-every", 2, 0, 0,
1467 "Return a true value if every character in the character set\n"
1468 "@var{cs} satisfies the predicate @var{pred}.")
1469 #define FUNC_NAME s_scm_char_set_every
1473 SCM res
= SCM_BOOL_T
;
1474 scm_t_char_set
*cs_data
;
1476 SCM_VALIDATE_PROC (1, pred
);
1477 SCM_VALIDATE_SMOB (2, cs
, charset
);
1479 cs_data
= SCM_CHARSET_DATA (cs
);
1480 if (cs_data
->len
== 0)
1483 for (k
= 0; k
< cs_data
->len
; k
++)
1484 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
1486 res
= scm_call_1 (pred
, SCM_MAKE_CHAR (n
));
1487 if (scm_is_false (res
))
1496 SCM_DEFINE (scm_char_set_any
, "char-set-any", 2, 0, 0,
1498 "Return a true value if any character in the character set\n"
1499 "@var{cs} satisfies the predicate @var{pred}.")
1500 #define FUNC_NAME s_scm_char_set_any
1504 scm_t_char_set
*cs_data
;
1506 SCM_VALIDATE_PROC (1, pred
);
1507 SCM_VALIDATE_SMOB (2, cs
, charset
);
1509 cs_data
= (scm_t_char_set
*) cs
;
1511 for (k
= 0; k
< cs_data
->len
; k
++)
1512 for (n
= cs_data
->ranges
[k
].lo
; n
<= cs_data
->ranges
[k
].hi
; n
++)
1514 SCM res
= scm_call_1 (pred
, SCM_MAKE_CHAR (n
));
1515 if (scm_is_true (res
))
1523 SCM_DEFINE (scm_char_set_adjoin
, "char-set-adjoin", 1, 0, 1,
1525 "Add all character arguments to the first argument, which must\n"
1526 "be a character set.")
1527 #define FUNC_NAME s_scm_char_set_adjoin
1529 SCM_VALIDATE_SMOB (1, cs
, charset
);
1530 SCM_VALIDATE_REST_ARGUMENT (rest
);
1531 cs
= scm_char_set_copy (cs
);
1533 while (!scm_is_null (rest
))
1535 SCM chr
= SCM_CAR (rest
);
1538 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
1539 rest
= SCM_CDR (rest
);
1541 SCM_CHARSET_SET (cs
, c
);
1548 SCM_DEFINE (scm_char_set_delete
, "char-set-delete", 1, 0, 1,
1550 "Delete all character arguments from the first argument, which\n"
1551 "must be a character set.")
1552 #define FUNC_NAME s_scm_char_set_delete
1554 SCM_VALIDATE_SMOB (1, cs
, charset
);
1555 SCM_VALIDATE_REST_ARGUMENT (rest
);
1556 cs
= scm_char_set_copy (cs
);
1558 while (!scm_is_null (rest
))
1560 SCM chr
= SCM_CAR (rest
);
1563 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
1564 rest
= SCM_CDR (rest
);
1566 SCM_CHARSET_UNSET (cs
, c
);
1573 SCM_DEFINE (scm_char_set_adjoin_x
, "char-set-adjoin!", 1, 0, 1,
1575 "Add all character arguments to the first argument, which must\n"
1576 "be a character set.")
1577 #define FUNC_NAME s_scm_char_set_adjoin_x
1579 SCM_VALIDATE_SMOB (1, cs
, charset
);
1580 SCM_VALIDATE_REST_ARGUMENT (rest
);
1582 while (!scm_is_null (rest
))
1584 SCM chr
= SCM_CAR (rest
);
1587 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
1588 rest
= SCM_CDR (rest
);
1590 SCM_CHARSET_SET (cs
, c
);
1597 SCM_DEFINE (scm_char_set_delete_x
, "char-set-delete!", 1, 0, 1,
1599 "Delete all character arguments from the first argument, which\n"
1600 "must be a character set.")
1601 #define FUNC_NAME s_scm_char_set_delete_x
1603 SCM_VALIDATE_SMOB (1, cs
, charset
);
1604 SCM_VALIDATE_REST_ARGUMENT (rest
);
1606 while (!scm_is_null (rest
))
1608 SCM chr
= SCM_CAR (rest
);
1611 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
1612 rest
= SCM_CDR (rest
);
1614 SCM_CHARSET_UNSET (cs
, c
);
1621 SCM_DEFINE (scm_char_set_complement
, "char-set-complement", 1, 0, 0,
1622 (SCM cs
), "Return the complement of the character set @var{cs}.")
1623 #define FUNC_NAME s_scm_char_set_complement
1626 scm_t_char_set
*p
, *q
;
1628 SCM_VALIDATE_SMOB (1, cs
, charset
);
1630 res
= make_char_set (FUNC_NAME
);
1631 p
= SCM_CHARSET_DATA (res
);
1632 q
= SCM_CHARSET_DATA (cs
);
1634 charsets_complement (p
, q
);
1641 SCM_DEFINE (scm_char_set_union
, "char-set-union", 0, 0, 1,
1643 "Return the union of all argument character sets.")
1644 #define FUNC_NAME s_scm_char_set_union
1650 SCM_VALIDATE_REST_ARGUMENT (rest
);
1652 res
= make_char_set (FUNC_NAME
);
1653 p
= SCM_CHARSET_DATA (res
);
1654 while (!scm_is_null (rest
))
1656 SCM cs
= SCM_CAR (rest
);
1657 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1659 rest
= SCM_CDR (rest
);
1662 charsets_union (p
, (scm_t_char_set
*) SCM_SMOB_DATA (cs
));
1669 SCM_DEFINE (scm_char_set_intersection
, "char-set-intersection", 0, 0, 1,
1671 "Return the intersection of all argument character sets.")
1672 #define FUNC_NAME s_scm_char_set_intersection
1676 SCM_VALIDATE_REST_ARGUMENT (rest
);
1678 if (scm_is_null (rest
))
1679 res
= make_char_set (FUNC_NAME
);
1685 res
= scm_char_set_copy (SCM_CAR (rest
));
1686 p
= SCM_CHARSET_DATA (res
);
1687 rest
= SCM_CDR (rest
);
1689 while (scm_is_pair (rest
))
1691 SCM cs
= SCM_CAR (rest
);
1692 scm_t_char_set
*cs_data
;
1694 SCM_VALIDATE_SMOB (argnum
, cs
, charset
);
1696 cs_data
= SCM_CHARSET_DATA (cs
);
1697 rest
= SCM_CDR (rest
);
1698 charsets_intersection (p
, cs_data
);
1707 SCM_DEFINE (scm_char_set_difference
, "char-set-difference", 1, 0, 1,
1708 (SCM cs1
, SCM rest
),
1709 "Return the difference of all argument character sets.")
1710 #define FUNC_NAME s_scm_char_set_difference
1714 scm_t_char_set
*p
, *q
;
1716 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1717 SCM_VALIDATE_REST_ARGUMENT (rest
);
1719 res
= scm_char_set_copy (cs1
);
1720 p
= SCM_CHARSET_DATA (res
);
1721 compl = make_char_set (FUNC_NAME
);
1722 q
= SCM_CHARSET_DATA (compl);
1723 while (!scm_is_null (rest
))
1725 SCM cs
= SCM_CAR (rest
);
1726 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1728 rest
= SCM_CDR (rest
);
1730 charsets_complement (q
, SCM_CHARSET_DATA (cs
));
1731 charsets_intersection (p
, q
);
1738 SCM_DEFINE (scm_char_set_xor
, "char-set-xor", 0, 0, 1,
1740 "Return the exclusive-or of all argument character sets.")
1741 #define FUNC_NAME s_scm_char_set_xor
1745 SCM_VALIDATE_REST_ARGUMENT (rest
);
1747 if (scm_is_null (rest
))
1748 res
= make_char_set (FUNC_NAME
);
1754 res
= scm_char_set_copy (SCM_CAR (rest
));
1755 p
= SCM_CHARSET_DATA (res
);
1756 rest
= SCM_CDR (rest
);
1758 while (scm_is_pair (rest
))
1760 SCM cs
= SCM_CAR (rest
);
1761 scm_t_char_set
*cs_data
;
1763 SCM_VALIDATE_SMOB (argnum
, cs
, charset
);
1765 cs_data
= SCM_CHARSET_DATA (cs
);
1766 rest
= SCM_CDR (rest
);
1768 charsets_xor (p
, cs_data
);
1776 SCM_DEFINE (scm_char_set_diff_plus_intersection
, "char-set-diff+intersection", 1, 0, 1,
1777 (SCM cs1
, SCM rest
),
1778 "Return the difference and the intersection of all argument\n"
1780 #define FUNC_NAME s_scm_char_set_diff_plus_intersection
1784 scm_t_char_set
*p
, *q
;
1786 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1787 SCM_VALIDATE_REST_ARGUMENT (rest
);
1789 res1
= scm_char_set_copy (cs1
);
1790 res2
= make_char_set (FUNC_NAME
);
1791 p
= SCM_CHARSET_DATA (res1
);
1792 q
= SCM_CHARSET_DATA (res2
);
1793 while (!scm_is_null (rest
))
1795 SCM cs
= SCM_CAR (rest
);
1798 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1800 r
= SCM_CHARSET_DATA (cs
);
1802 charsets_union (q
, r
);
1803 charsets_intersection (p
, r
);
1804 rest
= SCM_CDR (rest
);
1806 return scm_values (scm_list_2 (res1
, res2
));
1811 SCM_DEFINE (scm_char_set_complement_x
, "char-set-complement!", 1, 0, 0,
1812 (SCM cs
), "Return the complement of the character set @var{cs}.")
1813 #define FUNC_NAME s_scm_char_set_complement_x
1815 SCM_VALIDATE_SMOB (1, cs
, charset
);
1816 cs
= scm_char_set_complement (cs
);
1823 SCM_DEFINE (scm_char_set_union_x
, "char-set-union!", 1, 0, 1,
1824 (SCM cs1
, SCM rest
),
1825 "Return the union of all argument character sets.")
1826 #define FUNC_NAME s_scm_char_set_union_x
1828 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1829 SCM_VALIDATE_REST_ARGUMENT (rest
);
1831 cs1
= scm_char_set_union (scm_cons (cs1
, rest
));
1838 SCM_DEFINE (scm_char_set_intersection_x
, "char-set-intersection!", 1, 0, 1,
1839 (SCM cs1
, SCM rest
),
1840 "Return the intersection of all argument character sets.")
1841 #define FUNC_NAME s_scm_char_set_intersection_x
1843 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1844 SCM_VALIDATE_REST_ARGUMENT (rest
);
1846 cs1
= scm_char_set_intersection (scm_cons (cs1
, rest
));
1853 SCM_DEFINE (scm_char_set_difference_x
, "char-set-difference!", 1, 0, 1,
1854 (SCM cs1
, SCM rest
),
1855 "Return the difference of all argument character sets.")
1856 #define FUNC_NAME s_scm_char_set_difference_x
1858 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1859 SCM_VALIDATE_REST_ARGUMENT (rest
);
1861 cs1
= scm_char_set_difference (cs1
, rest
);
1868 SCM_DEFINE (scm_char_set_xor_x
, "char-set-xor!", 1, 0, 1,
1869 (SCM cs1
, SCM rest
),
1870 "Return the exclusive-or of all argument character sets.")
1871 #define FUNC_NAME s_scm_char_set_xor_x
1873 /* a side-effecting variant should presumably give consistent results:
1874 (define a (char-set #\a))
1875 (char-set-xor a a a) -> char set #\a
1876 (char-set-xor! a a a) -> char set #\a
1878 return scm_char_set_xor (scm_cons (cs1
, rest
));
1884 SCM_DEFINE (scm_char_set_diff_plus_intersection_x
,
1885 "char-set-diff+intersection!", 2, 0, 1, (SCM cs1
, SCM cs2
,
1887 "Return the difference and the intersection of all argument\n"
1889 #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
1891 SCM diff
, intersect
;
1893 diff
= scm_char_set_difference (cs1
, scm_cons (cs2
, rest
));
1895 scm_char_set_intersection (scm_cons (cs1
, scm_cons (cs2
, rest
)));
1898 return scm_values (scm_list_2 (cs1
, cs2
));
1904 /* Standard character sets. */
1906 SCM scm_char_set_lower_case
;
1907 SCM scm_char_set_upper_case
;
1908 SCM scm_char_set_title_case
;
1909 SCM scm_char_set_letter
;
1910 SCM scm_char_set_digit
;
1911 SCM scm_char_set_letter_and_digit
;
1912 SCM scm_char_set_graphic
;
1913 SCM scm_char_set_printing
;
1914 SCM scm_char_set_whitespace
;
1915 SCM scm_char_set_iso_control
;
1916 SCM scm_char_set_punctuation
;
1917 SCM scm_char_set_symbol
;
1918 SCM scm_char_set_hex_digit
;
1919 SCM scm_char_set_blank
;
1920 SCM scm_char_set_ascii
;
1921 SCM scm_char_set_empty
;
1922 SCM scm_char_set_full
;
1925 /* Create an empty character set and return it after binding it to NAME. */
1927 define_charset (const char *name
, const scm_t_char_set
*p
)
1931 SCM_NEWSMOB (cs
, scm_tc16_charset
, p
);
1932 scm_c_define (name
, cs
);
1933 return scm_permanent_object (cs
);
1936 #ifdef SCM_CHARSET_DEBUG
1937 SCM_DEFINE (scm_debug_char_set
, "debug-char-set", 1, 0, 0,
1939 "Print out the internal C structure of @var{charset}.\n")
1940 #define FUNC_NAME s_debug_char_set
1943 scm_t_char_set
*cs
= SCM_CHARSET_DATA (charset
);
1944 fprintf (stderr
, "cs %p\n", cs
);
1945 fprintf (stderr
, "len %d\n", cs
->len
);
1946 fprintf (stderr
, "arr %p\n", cs
->ranges
);
1947 for (i
= 0; i
< cs
->len
; i
++)
1949 if (cs
->ranges
[i
].lo
== cs
->ranges
[i
].hi
)
1950 fprintf (stderr
, "%04x\n", cs
->ranges
[i
].lo
);
1952 fprintf (stderr
, "%04x..%04x\t[%d]\n",
1954 cs
->ranges
[i
].hi
, cs
->ranges
[i
].hi
- cs
->ranges
[i
].lo
+ 1);
1957 return SCM_UNSPECIFIED
;
1966 scm_init_srfi_14 (void)
1968 scm_tc16_charset
= scm_make_smob_type ("character-set", 0);
1969 scm_set_smob_free (scm_tc16_charset
, charset_free
);
1970 scm_set_smob_print (scm_tc16_charset
, charset_print
);
1972 scm_tc16_charset_cursor
= scm_make_smob_type ("char-set-cursor", 0);
1973 scm_set_smob_free (scm_tc16_charset_cursor
, charset_cursor_free
);
1974 scm_set_smob_print (scm_tc16_charset_cursor
, charset_cursor_print
);
1976 scm_char_set_upper_case
=
1977 define_charset ("char-set:upper-case", &cs_upper_case
);
1978 scm_char_set_lower_case
=
1979 define_charset ("char-set:lower-case", &cs_lower_case
);
1980 scm_char_set_title_case
=
1981 define_charset ("char-set:title-case", &cs_title_case
);
1982 scm_char_set_letter
= define_charset ("char-set:letter", &cs_letter
);
1983 scm_char_set_digit
= define_charset ("char-set:digit", &cs_digit
);
1984 scm_char_set_letter_and_digit
=
1985 define_charset ("char-set:letter+digit", &cs_letter_plus_digit
);
1986 scm_char_set_graphic
= define_charset ("char-set:graphic", &cs_graphic
);
1987 scm_char_set_printing
= define_charset ("char-set:printing", &cs_printing
);
1988 scm_char_set_whitespace
=
1989 define_charset ("char-set:whitespace", &cs_whitespace
);
1990 scm_char_set_iso_control
=
1991 define_charset ("char-set:iso-control", &cs_iso_control
);
1992 scm_char_set_punctuation
=
1993 define_charset ("char-set:punctuation", &cs_punctuation
);
1994 scm_char_set_symbol
= define_charset ("char-set:symbol", &cs_symbol
);
1995 scm_char_set_hex_digit
=
1996 define_charset ("char-set:hex-digit", &cs_hex_digit
);
1997 scm_char_set_blank
= define_charset ("char-set:blank", &cs_blank
);
1998 scm_char_set_ascii
= define_charset ("char-set:ascii", &cs_ascii
);
1999 scm_char_set_empty
= define_charset ("char-set:empty", &cs_empty
);
2000 scm_char_set_full
= define_charset ("char-set:full", &cs_full
);
2002 #include "libguile/srfi-14.x"
2005 /* End of srfi-14.c. */