1 /* srfi-14.c --- SRFI-14 procedures for Guile
3 * Copyright (C) 2001 Free Software Foundation, Inc.
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License as
7 * published by the Free Software Foundation; either version 2, or (at
8 * your option) any later version.
10 * This program 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 * General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this software; see the file COPYING. If not, write to
17 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 * Boston, MA 02111-1307 USA
20 * As a special exception, the Free Software Foundation gives
21 * permission for additional uses of the text contained in its release
24 * The exception is that, if you link the GUILE library with other
25 * files to produce an executable, this does not by itself cause the
26 * resulting executable to be covered by the GNU General Public
27 * License. Your use of that executable is in no way restricted on
28 * account of linking the GUILE library code into it.
30 * This exception does not however invalidate any other reasons why
31 * the executable file might be covered by the GNU General Public
34 * This exception applies only to the code released by the Free
35 * Software Foundation under the name GUILE. If you copy code from
36 * other Free Software Foundation releases into a copy of GUILE, as
37 * the General Public License permits, the exception does not apply to
38 * the code that you add in this way. To avoid misleading anyone as
39 * to the status of such modified files, you must delete this
40 * exception notice from them.
42 * If you write modifications of your own for GUILE, it is your choice
43 * whether to permit this exception to apply to your modifications.
44 * If you do not wish that, delete this exception notice. */
53 #define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / sizeof (long)] |= (1 << ((idx) % sizeof (long))))
55 SCM
scm_char_set_copy (SCM cs
);
57 /* Smob type code for character sets. */
58 int scm_tc16_charset
= 0;
61 /* Smob print hook for character sets. */
63 charset_print (SCM charset
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
68 scm_puts ("#<charset {", port
);
69 for (i
= 0; i
< SCM_CHARSET_SIZE
; i
++)
70 if (SCM_CHARSET_GET (charset
, i
))
76 scm_write (SCM_MAKE_CHAR (i
), port
);
78 scm_puts ("}>", port
);
83 /* Smob free hook for character sets. */
85 charset_free (SCM charset
)
87 return scm_smob_free (charset
);
91 /* Create a new, empty character set. */
93 make_char_set (const char * func_name
)
97 p
= scm_must_malloc (SCM_CHARSET_SIZE
, func_name
);
98 memset (p
, 0, SCM_CHARSET_SIZE
);
99 SCM_RETURN_NEWSMOB (scm_tc16_charset
, p
);
103 SCM_DEFINE (scm_char_set_p
, "char-set?", 1, 0, 0,
105 "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
107 #define FUNC_NAME s_scm_char_set_p
109 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_charset
, obj
));
114 SCM_DEFINE (scm_char_set_eq
, "char-set=", 1, 0, 1,
116 "Return @code{#t} if all given character sets are equal.")
117 #define FUNC_NAME s_scm_char_set_eq
121 SCM_VALIDATE_SMOB (1, cs1
, charset
);
122 SCM_VALIDATE_REST_ARGUMENT (csr
);
124 while (!SCM_NULLP (csr
))
127 SCM cs2
= SCM_CAR (csr
);
130 SCM_VALIDATE_SMOB (argnum
++, cs2
, charset
);
131 p1
= (long *) SCM_SMOB_DATA (cs1
);
132 p2
= (long *) SCM_SMOB_DATA (cs2
);
133 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
147 SCM_DEFINE (scm_char_set_leq
, "char-set<=", 1, 0, 1,
149 "Return @code{#t} if every character set @var{cs}i is a subset\n"
150 "of character set @var{cs}i+1.")
151 #define FUNC_NAME s_scm_char_set_leq
155 SCM_VALIDATE_SMOB (1, cs1
, charset
);
156 SCM_VALIDATE_REST_ARGUMENT (csr
);
158 while (!SCM_NULLP (csr
))
161 SCM cs2
= SCM_CAR (csr
);
164 SCM_VALIDATE_SMOB (argnum
++, cs2
, charset
);
165 p1
= (long *) SCM_SMOB_DATA (cs1
);
166 p2
= (long *) SCM_SMOB_DATA (cs2
);
167 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
169 if ((p1
[k
] & p2
[k
]) != p1
[k
])
181 SCM_DEFINE (scm_char_set_hash
, "char-set-hash", 1, 1, 0,
183 "Compute a hash value for the character set @var{cs}. If\n"
184 "@var{bound} is given and not @code{#f}, it restricts the\n"
185 "returned value to the range 0 @dots{} @var{bound - 1}.")
186 #define FUNC_NAME s_scm_char_set_hash
193 SCM_VALIDATE_SMOB (1, cs
, charset
);
194 if (SCM_UNBNDP (bound
) || SCM_FALSEP (bound
))
197 SCM_VALIDATE_INUM_COPY (2, bound
, bnd
);
199 p
= (long *) SCM_SMOB_DATA (cs
);
200 for (k
= 0; k
< SCM_CHARSET_SIZE
- 1; k
++)
204 return SCM_MAKINUM (val
% bnd
);
209 SCM_DEFINE (scm_char_set_cursor
, "char-set-cursor", 1, 0, 0,
211 "Return a cursor into the character set @var{cs}.")
212 #define FUNC_NAME s_scm_char_set_cursor
216 SCM_VALIDATE_SMOB (1, cs
, charset
);
217 for (idx
= 0; idx
< SCM_CHARSET_SIZE
; idx
++)
219 if (SCM_CHARSET_GET (cs
, idx
))
222 return SCM_MAKINUM (idx
);
227 SCM_DEFINE (scm_char_set_ref
, "char-set-ref", 2, 0, 0,
228 (SCM cs
, SCM cursor
),
229 "Return the character at the current cursor position\n"
230 "@var{cursor} in the character set @var{cs}. It is an error to\n"
231 "pass a cursor for which @code{end-of-char-set?} returns true.")
232 #define FUNC_NAME s_scm_char_set_ref
236 SCM_VALIDATE_SMOB (1, cs
, charset
);
237 SCM_VALIDATE_INUM_COPY (2, cursor
, ccursor
);
239 if (ccursor
>= SCM_CHARSET_SIZE
|| !SCM_CHARSET_GET (cs
, ccursor
))
240 SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor
));
241 return SCM_MAKE_CHAR (ccursor
);
246 SCM_DEFINE (scm_char_set_cursor_next
, "char-set-cursor-next", 2, 0, 0,
247 (SCM cs
, SCM cursor
),
248 "Advance the character set cursor @var{cursor} to the next\n"
249 "character in the character set @var{cs}. It is an error if the\n"
250 "cursor given satisfies @code{end-of-char-set?}.")
251 #define FUNC_NAME s_scm_char_set_cursor_next
255 SCM_VALIDATE_SMOB (1, cs
, charset
);
256 SCM_VALIDATE_INUM_COPY (2, cursor
, ccursor
);
258 if (ccursor
>= SCM_CHARSET_SIZE
|| !SCM_CHARSET_GET (cs
, ccursor
))
259 SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor
));
260 for (ccursor
++; ccursor
< SCM_CHARSET_SIZE
; ccursor
++)
262 if (SCM_CHARSET_GET (cs
, ccursor
))
265 return SCM_MAKINUM (ccursor
);
270 SCM_DEFINE (scm_end_of_char_set_p
, "end-of-char-set?", 1, 0, 0,
272 "Return @code{#t} if @var{cursor} has reached the end of a\n"
273 "character set, @code{#f} otherwise.")
274 #define FUNC_NAME s_scm_end_of_char_set_p
278 SCM_VALIDATE_INUM_COPY (1, cursor
, ccursor
);
279 return SCM_BOOL (ccursor
>= SCM_CHARSET_SIZE
);
284 SCM_DEFINE (scm_char_set_fold
, "char-set-fold", 3, 0, 0,
285 (SCM kons
, SCM knil
, SCM cs
),
286 "Fold the procedure @var{kons} over the character set @var{cs},\n"
287 "initializing it with @var{knil}.")
288 #define FUNC_NAME s_scm_char_set_fold
292 SCM_VALIDATE_PROC (1, kons
);
293 SCM_VALIDATE_SMOB (3, cs
, charset
);
295 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
296 if (SCM_CHARSET_GET (cs
, k
))
298 knil
= scm_apply (kons
, SCM_LIST2 (SCM_MAKE_CHAR (k
), (knil
)),
305 SCM_DEFINE (scm_char_set_unfold
, "char-set-unfold", 4, 1, 0,
306 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base_cs
),
307 "This is a fundamental constructor for character sets.\n"
309 "@item @var{g} is used to generate a series of ``seed'' values \n"
310 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
311 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
312 "@item @var{p} tells us when to stop -- when it returns true\n"
313 "when applied to one of the seed values. \n"
314 "@item @var{f} maps each seed value to a character. These\n"
315 "characters are added to the base character set @var{base_cs} to\n"
316 "form the result; @var{base_cs} defaults to the empty set.\n"
318 #define FUNC_NAME s_scm_char_set_unfold
322 SCM_VALIDATE_PROC (1, p
);
323 SCM_VALIDATE_PROC (2, f
);
324 SCM_VALIDATE_PROC (3, g
);
325 if (!SCM_UNBNDP (base_cs
))
327 SCM_VALIDATE_SMOB (5, base_cs
, charset
);
328 result
= scm_char_set_copy (base_cs
);
331 result
= make_char_set (FUNC_NAME
);
333 tmp
= scm_apply (p
, seed
, scm_listofnull
);
334 while (SCM_FALSEP (tmp
))
336 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
338 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
339 SCM_CHARSET_SET (result
, SCM_CHAR (ch
));
341 seed
= scm_apply (g
, seed
, scm_listofnull
);
342 tmp
= scm_apply (p
, seed
, scm_listofnull
);
349 SCM_DEFINE (scm_char_set_unfold_x
, "char-set-unfold!", 5, 0, 0,
350 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base_cs
),
351 "This is a fundamental constructor for character sets.\n"
353 "@item @var{g} is used to generate a series of ``seed'' values\n"
354 "from the initial seed: @var{seed}, (@var{g} @var{seed}), \n"
355 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
356 "@item @var{p} tells us when to stop -- when it returns true\n"
357 "when applied to one of the seed values. \n"
358 "@item @var{f} maps each seed value to a character. These\n"
359 "characters are added to the base character set @var{base_cs} to\n"
360 "form the result; @var{base_cs} defaults to the empty set.\n"
362 #define FUNC_NAME s_scm_char_set_unfold_x
366 SCM_VALIDATE_PROC (1, p
);
367 SCM_VALIDATE_PROC (2, f
);
368 SCM_VALIDATE_PROC (3, g
);
369 SCM_VALIDATE_SMOB (5, base_cs
, charset
);
371 tmp
= scm_apply (p
, seed
, scm_listofnull
);
372 while (SCM_FALSEP (tmp
))
374 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
376 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
377 SCM_CHARSET_SET (base_cs
, SCM_CHAR (ch
));
379 seed
= scm_apply (g
, seed
, scm_listofnull
);
380 tmp
= scm_apply (p
, seed
, scm_listofnull
);
387 SCM_DEFINE (scm_char_set_for_each
, "char-set-for-each", 2, 0, 0,
389 "Apply @var{proc} to every character in the character set\n"
390 "@var{cs}. The return value is not specified.")
391 #define FUNC_NAME s_scm_char_set_for_each
395 SCM_VALIDATE_PROC (1, proc
);
396 SCM_VALIDATE_SMOB (2, cs
, charset
);
398 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
399 if (SCM_CHARSET_GET (cs
, k
))
400 scm_apply (proc
, SCM_MAKE_CHAR (k
), scm_listofnull
);
401 return SCM_UNSPECIFIED
;
406 SCM_DEFINE (scm_char_set_map
, "char-set-map", 2, 0, 0,
408 "Map the procedure @var{proc} over every character in @var{cs}.\n"
409 "@var{proc} must be a character -> character procedure.")
410 #define FUNC_NAME s_scm_char_set_map
415 SCM_VALIDATE_PROC (1, proc
);
416 SCM_VALIDATE_SMOB (2, cs
, charset
);
418 result
= make_char_set (FUNC_NAME
);
419 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
420 if (SCM_CHARSET_GET (cs
, k
))
422 SCM ch
= scm_apply (proc
, SCM_MAKE_CHAR (k
), scm_listofnull
);
424 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
425 SCM_CHARSET_SET (cs
, SCM_CHAR (ch
));
432 SCM_DEFINE (scm_char_set_copy
, "char-set-copy", 1, 0, 0,
434 "Return a newly allocated character set containing all\n"
435 "characters in @var{cs}.")
436 #define FUNC_NAME s_scm_char_set_copy
442 SCM_VALIDATE_SMOB (1, cs
, charset
);
443 ret
= make_char_set (FUNC_NAME
);
444 p1
= (long *) SCM_SMOB_DATA (cs
);
445 p2
= (long *) SCM_SMOB_DATA (ret
);
446 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
453 SCM_DEFINE (scm_char_set
, "char-set", 0, 0, 1,
455 "Return a character set containing all given characters.")
456 #define FUNC_NAME s_scm_char_set
461 SCM_VALIDATE_REST_ARGUMENT (rest
);
463 cs
= make_char_set (FUNC_NAME
);
464 p
= (long *) SCM_SMOB_DATA (cs
);
465 while (!SCM_NULLP (ls
))
467 SCM chr
= SCM_CAR (ls
);
470 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
473 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
480 SCM_DEFINE (scm_list_to_char_set
, "list->char-set", 1, 1, 0,
481 (SCM list
, SCM base_cs
),
482 "Convert the character list @var{list} to a character set. If\n"
483 "the character set @var{base_cs} is given, the character in this\n"
484 "set are also included in the result.")
485 #define FUNC_NAME s_scm_list_to_char_set
490 SCM_VALIDATE_LIST (1, list
);
491 if (SCM_UNBNDP (base_cs
))
492 cs
= make_char_set (FUNC_NAME
);
495 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
496 cs
= scm_char_set_copy (base_cs
);
498 p
= (long *) SCM_SMOB_DATA (cs
);
499 while (!SCM_NULLP (list
))
501 SCM chr
= SCM_CAR (list
);
504 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
505 list
= SCM_CDR (list
);
507 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
514 SCM_DEFINE (scm_list_to_char_set_x
, "list->char-set!", 2, 0, 0,
515 (SCM list
, SCM base_cs
),
516 "Convert the character list @var{list} to a character set. The\n"
517 "characters are added to @var{base_cs} and @var{base_cs} is\n"
519 #define FUNC_NAME s_scm_list_to_char_set
523 SCM_VALIDATE_LIST (1, list
);
524 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
525 p
= (long *) SCM_SMOB_DATA (base_cs
);
526 while (!SCM_NULLP (list
))
528 SCM chr
= SCM_CAR (list
);
531 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
532 list
= SCM_CDR (list
);
534 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
541 SCM_DEFINE (scm_string_to_char_set
, "string->char-set", 1, 1, 0,
542 (SCM str
, SCM base_cs
),
543 "Convert the string @var{str} to a character set. If the\n"
544 "character set @var{base_cs} is given, the characters in this\n"
545 "set are also included in the result.")
546 #define FUNC_NAME s_scm_string_to_char_set
553 SCM_VALIDATE_STRING (1, str
);
554 if (SCM_UNBNDP (base_cs
))
555 cs
= make_char_set (FUNC_NAME
);
558 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
559 cs
= scm_char_set_copy (base_cs
);
561 p
= (long *) SCM_SMOB_DATA (cs
);
562 s
= SCM_STRING_CHARS (str
);
563 while (k
< SCM_STRING_LENGTH (str
))
566 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
573 SCM_DEFINE (scm_string_to_char_set_x
, "string->char-set!", 2, 0, 0,
574 (SCM str
, SCM base_cs
),
575 "Convert the string @var{str} to a character set. The\n"
576 "characters from the string are added to @var{base_cs}, and\n"
577 "@var{base_cs} is returned.")
578 #define FUNC_NAME s_scm_string_to_char_set_x
584 SCM_VALIDATE_STRING (1, str
);
585 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
586 p
= (long *) SCM_SMOB_DATA (base_cs
);
587 s
= SCM_STRING_CHARS (str
);
588 while (k
< SCM_STRING_LENGTH (str
))
591 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
598 SCM_DEFINE (scm_char_set_filter
, "char-set-filter", 2, 1, 0,
599 (SCM pred
, SCM cs
, SCM base_cs
),
600 "Return a character set containing every character from @var{cs}\n"
601 "so that it satisfies @var{pred}. If provided, the characters\n"
602 "from @var{base_cs} are added to the result.")
603 #define FUNC_NAME s_scm_char_set_filter
609 SCM_VALIDATE_PROC (1, pred
);
610 SCM_VALIDATE_SMOB (2, cs
, charset
);
611 if (!SCM_UNBNDP (base_cs
))
613 SCM_VALIDATE_SMOB (3, base_cs
, charset
);
614 ret
= scm_char_set_copy (base_cs
);
617 ret
= make_char_set (FUNC_NAME
);
618 p
= (long *) SCM_SMOB_DATA (ret
);
619 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
621 if (SCM_CHARSET_GET (cs
, k
))
623 SCM res
= scm_apply (pred
, SCM_MAKE_CHAR (k
), scm_listofnull
);
625 if (!SCM_FALSEP (res
))
626 p
[k
/ sizeof (long)] |= 1 << (k
% sizeof (long));
634 SCM_DEFINE (scm_char_set_filter_x
, "char-set-filter!", 3, 0, 0,
635 (SCM pred
, SCM cs
, SCM base_cs
),
636 "Return a character set containing every character from @var{cs}\n"
637 "so that it satisfies @var{pred}. The characters are added to\n"
638 "@var{base_cs} and @var{base_cs} is returned.")
639 #define FUNC_NAME s_scm_char_set_filter_x
644 SCM_VALIDATE_PROC (1, pred
);
645 SCM_VALIDATE_SMOB (2, cs
, charset
);
646 SCM_VALIDATE_SMOB (3, base_cs
, charset
);
647 p
= (long *) SCM_SMOB_DATA (base_cs
);
648 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
650 if (SCM_CHARSET_GET (cs
, k
))
652 SCM res
= scm_apply (pred
, SCM_MAKE_CHAR (k
), scm_listofnull
);
654 if (!SCM_FALSEP (res
))
655 p
[k
/ sizeof (long)] |= 1 << (k
% sizeof (long));
663 SCM_DEFINE (scm_ucs_range_to_char_set
, "ucs-range->char-set", 2, 2, 0,
664 (SCM lower
, SCM upper
, SCM error
, SCM base_cs
),
665 "Return a character set containing all characters whose\n"
666 "character codes lie in the half-open range\n"
667 "[@var{lower},@var{upper}).\n"
669 "If @var{error} is a true value, an error is signalled if the\n"
670 "specified range contains characters which are not contained in\n"
671 "the implemented character range. If @var{error} is @code{#f},\n"
672 "these characters are silently left out of the resultung\n"
675 "The characters in @var{base_cs} are added to the result, if\n"
677 #define FUNC_NAME s_scm_ucs_range_to_char_set
683 SCM_VALIDATE_INUM_COPY (1, lower
, clower
);
684 SCM_VALIDATE_INUM_COPY (2, upper
, cupper
);
685 SCM_ASSERT_RANGE (1, lower
, clower
>= 0);
686 SCM_ASSERT_RANGE (2, upper
, cupper
>= 0 && cupper
>= clower
);
687 if (!SCM_UNBNDP (error
))
689 if (!SCM_FALSEP (error
))
691 SCM_ASSERT_RANGE (1, lower
, clower
<= SCM_CHARSET_SIZE
);
692 SCM_ASSERT_RANGE (2, upper
, cupper
<= SCM_CHARSET_SIZE
);
695 if (clower
> SCM_CHARSET_SIZE
)
696 clower
= SCM_CHARSET_SIZE
;
697 if (cupper
> SCM_CHARSET_SIZE
)
698 cupper
= SCM_CHARSET_SIZE
;
699 if (SCM_UNBNDP (base_cs
))
700 cs
= make_char_set (FUNC_NAME
);
703 SCM_VALIDATE_SMOB (2, base_cs
, charset
);
704 cs
= scm_char_set_copy (base_cs
);
706 p
= (long *) SCM_SMOB_DATA (cs
);
707 while (clower
< cupper
)
709 p
[clower
/ sizeof (long)] |= 1 << (clower
% sizeof (long));
717 SCM_DEFINE (scm_ucs_range_to_char_set_x
, "ucs-range->char-set!", 4, 0, 0,
718 (SCM lower
, SCM upper
, SCM error
, SCM base_cs
),
719 "Return a character set containing all characters whose\n"
720 "character codes lie in the half-open range\n"
721 "[@var{lower},@var{upper}).\n"
723 "If @var{error} is a true value, an error is signalled if the\n"
724 "specified range contains characters which are not contained in\n"
725 "the implemented character range. If @var{error} is @code{#f},\n"
726 "these characters are silently left out of the resultung\n"
729 "The characters are added to @var{base_cs} and @var{base_cs} is\n"
731 #define FUNC_NAME s_scm_ucs_range_to_char_set_x
736 SCM_VALIDATE_INUM_COPY (1, lower
, clower
);
737 SCM_VALIDATE_INUM_COPY (2, upper
, cupper
);
738 SCM_ASSERT_RANGE (1, lower
, clower
>= 0);
739 SCM_ASSERT_RANGE (2, upper
, cupper
>= 0 && cupper
>= clower
);
740 if (!SCM_FALSEP (error
))
742 SCM_ASSERT_RANGE (1, lower
, clower
<= SCM_CHARSET_SIZE
);
743 SCM_ASSERT_RANGE (2, upper
, cupper
<= SCM_CHARSET_SIZE
);
745 if (clower
> SCM_CHARSET_SIZE
)
746 clower
= SCM_CHARSET_SIZE
;
747 if (cupper
> SCM_CHARSET_SIZE
)
748 cupper
= SCM_CHARSET_SIZE
;
749 p
= (long *) SCM_SMOB_DATA (base_cs
);
750 while (clower
< cupper
)
752 p
[clower
/ sizeof (long)] |= 1 << (clower
% sizeof (long));
760 SCM_DEFINE (scm_char_set_size
, "char-set-size", 1, 0, 0,
762 "Return the number of elements in character set @var{cs}.")
763 #define FUNC_NAME s_scm_char_set_size
767 SCM_VALIDATE_SMOB (1, cs
, charset
);
768 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
769 if (SCM_CHARSET_GET (cs
, k
))
771 return SCM_MAKINUM (count
);
776 SCM_DEFINE (scm_char_set_count
, "char-set-count", 2, 0, 0,
778 "Return the number of the elements int the character set\n"
779 "@var{cs} which satisfy the predicate @var{pred}.")
780 #define FUNC_NAME s_scm_char_set_count
784 SCM_VALIDATE_PROC (1, pred
);
785 SCM_VALIDATE_SMOB (2, cs
, charset
);
787 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
788 if (SCM_CHARSET_GET (cs
, k
))
790 SCM res
= scm_apply (pred
, SCM_MAKE_CHAR (k
), scm_listofnull
);
791 if (!SCM_FALSEP (res
))
794 return SCM_MAKINUM (count
);
799 SCM_DEFINE (scm_char_set_to_list
, "char-set->list", 1, 0, 0,
801 "Return a list containing the elements of the character set\n"
803 #define FUNC_NAME s_scm_char_set_to_list
806 SCM result
= SCM_EOL
;
808 SCM_VALIDATE_SMOB (1, cs
, charset
);
809 for (k
= SCM_CHARSET_SIZE
; k
> 0; k
--)
810 if (SCM_CHARSET_GET (cs
, k
- 1))
811 result
= scm_cons (SCM_MAKE_CHAR (k
- 1), result
);
817 SCM_DEFINE (scm_char_set_to_string
, "char-set->string", 1, 0, 0,
819 "Return a string containing the elements of the character set\n"
820 "@var{cs}. The order in which the characters are placed in the\n"
821 "string is not defined.")
822 #define FUNC_NAME s_scm_char_set_to_string
830 SCM_VALIDATE_SMOB (1, cs
, charset
);
831 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
832 if (SCM_CHARSET_GET (cs
, k
))
834 result
= scm_allocate_string (count
);
835 p
= SCM_STRING_CHARS (result
);
836 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
837 if (SCM_CHARSET_GET (cs
, k
))
844 SCM_DEFINE (scm_char_set_contains_p
, "char-set-contains?", 2, 0, 0,
846 "Return @code{#t} iff the character @var{ch} is contained in the\n"
847 "character set @var{cs}.")
848 #define FUNC_NAME s_scm_char_set_contains_p
850 SCM_VALIDATE_SMOB (1, cs
, charset
);
851 SCM_VALIDATE_CHAR (2, ch
);
852 return SCM_BOOL (SCM_CHARSET_GET (cs
, SCM_CHAR (ch
)));
857 SCM_DEFINE (scm_char_set_every
, "char-set-every", 2, 0, 0,
859 "Return a true value if every character in the character set\n"
860 "@var{cs} satisfies the predicate @var{pred}.")
861 #define FUNC_NAME s_scm_char_set_every
864 SCM res
= SCM_BOOL_T
;
866 SCM_VALIDATE_PROC (1, pred
);
867 SCM_VALIDATE_SMOB (2, cs
, charset
);
869 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
870 if (SCM_CHARSET_GET (cs
, k
))
872 res
= scm_apply (pred
, SCM_MAKE_CHAR (k
), scm_listofnull
);
873 if (SCM_FALSEP (res
))
881 SCM_DEFINE (scm_char_set_any
, "char-set-any", 2, 0, 0,
883 "Return a true value if any character in the character set\n"
884 "@var{cs} satisfies the predicate @var{pred}.")
885 #define FUNC_NAME s_scm_char_set_any
889 SCM_VALIDATE_PROC (1, pred
);
890 SCM_VALIDATE_SMOB (2, cs
, charset
);
892 for (k
= 0; k
< SCM_CHARSET_SIZE
; k
++)
893 if (SCM_CHARSET_GET (cs
, k
))
895 SCM res
= scm_apply (pred
, SCM_MAKE_CHAR (k
), scm_listofnull
);
896 if (!SCM_FALSEP (res
))
904 SCM_DEFINE (scm_char_set_adjoin
, "char-set-adjoin", 1, 0, 1,
906 "Add all character arguments to the first argument, which must\n"
907 "be a character set.")
908 #define FUNC_NAME s_scm_char_set_adjoin
912 SCM_VALIDATE_SMOB (1, cs
, charset
);
913 SCM_VALIDATE_REST_ARGUMENT (rest
);
914 cs
= scm_char_set_copy (cs
);
916 p
= (long *) SCM_SMOB_DATA (cs
);
917 while (!SCM_NULLP (rest
))
919 SCM chr
= SCM_CAR (rest
);
922 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
923 rest
= SCM_CDR (rest
);
925 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
931 SCM_DEFINE (scm_char_set_delete
, "char-set-delete", 1, 0, 1,
933 "Delete all character arguments from the first argument, which\n"
934 "must be a character set.")
935 #define FUNC_NAME s_scm_char_set_delete
939 SCM_VALIDATE_SMOB (1, cs
, charset
);
940 SCM_VALIDATE_REST_ARGUMENT (rest
);
941 cs
= scm_char_set_copy (cs
);
943 p
= (long *) SCM_SMOB_DATA (cs
);
944 while (!SCM_NULLP (rest
))
946 SCM chr
= SCM_CAR (rest
);
949 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
950 rest
= SCM_CDR (rest
);
952 p
[c
/ sizeof (long)] &= ~(1 << (c
% sizeof (long)));
958 SCM_DEFINE (scm_char_set_adjoin_x
, "char-set-adjoin!", 1, 0, 1,
960 "Add all character arguments to the first argument, which must\n"
961 "be a character set.")
962 #define FUNC_NAME s_scm_char_set_adjoin_x
966 SCM_VALIDATE_SMOB (1, cs
, charset
);
967 SCM_VALIDATE_REST_ARGUMENT (rest
);
969 p
= (long *) SCM_SMOB_DATA (cs
);
970 while (!SCM_NULLP (rest
))
972 SCM chr
= SCM_CAR (rest
);
975 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
976 rest
= SCM_CDR (rest
);
978 p
[c
/ sizeof (long)] |= 1 << (c
% sizeof (long));
984 SCM_DEFINE (scm_char_set_delete_x
, "char-set-delete!", 1, 0, 1,
986 "Delete all character arguments from the first argument, which\n"
987 "must be a character set.")
988 #define FUNC_NAME s_scm_char_set_delete_x
992 SCM_VALIDATE_SMOB (1, cs
, charset
);
993 SCM_VALIDATE_REST_ARGUMENT (rest
);
995 p
= (long *) SCM_SMOB_DATA (cs
);
996 while (!SCM_NULLP (rest
))
998 SCM chr
= SCM_CAR (rest
);
1001 SCM_VALIDATE_CHAR_COPY (1, chr
, c
);
1002 rest
= SCM_CDR (rest
);
1004 p
[c
/ sizeof (long)] &= ~(1 << (c
% sizeof (long)));
1011 SCM_DEFINE (scm_char_set_complement
, "char-set-complement", 1, 0, 0,
1013 "Return the complement of the character set @var{cs}.")
1014 #define FUNC_NAME s_scm_char_set_complement
1020 SCM_VALIDATE_SMOB (1, cs
, charset
);
1022 res
= make_char_set (FUNC_NAME
);
1023 p
= (long *) SCM_SMOB_DATA (res
);
1024 q
= (long *) SCM_SMOB_DATA (cs
);
1025 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1032 SCM_DEFINE (scm_char_set_union
, "char-set-union", 0, 0, 1,
1034 "Return the union of all argument character sets.")
1035 #define FUNC_NAME s_scm_char_set_union
1041 SCM_VALIDATE_REST_ARGUMENT (rest
);
1043 res
= make_char_set (FUNC_NAME
);
1044 p
= (long *) SCM_SMOB_DATA (res
);
1045 while (!SCM_NULLP (rest
))
1048 SCM cs
= SCM_CAR (rest
);
1049 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1051 rest
= SCM_CDR (rest
);
1053 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1054 p
[k
] |= ((long *) SCM_SMOB_DATA (cs
))[k
];
1061 SCM_DEFINE (scm_char_set_intersection
, "char-set-intersection", 1, 0, 1,
1062 (SCM cs1
, SCM rest
),
1063 "Return the intersection of all argument character sets.")
1064 #define FUNC_NAME s_scm_char_set_intersection
1070 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1071 SCM_VALIDATE_REST_ARGUMENT (rest
);
1073 res
= scm_char_set_copy (cs1
);
1074 p
= (long *) SCM_SMOB_DATA (res
);
1075 while (!SCM_NULLP (rest
))
1078 SCM cs
= SCM_CAR (rest
);
1079 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1081 rest
= SCM_CDR (rest
);
1083 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1084 p
[k
] &= ((long *) SCM_SMOB_DATA (cs
))[k
];
1091 SCM_DEFINE (scm_char_set_difference
, "char-set-difference", 1, 0, 1,
1092 (SCM cs1
, SCM rest
),
1093 "Return the difference of all argument character sets.")
1094 #define FUNC_NAME s_scm_char_set_difference
1100 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1101 SCM_VALIDATE_REST_ARGUMENT (rest
);
1103 res
= scm_char_set_copy (cs1
);
1104 p
= (long *) SCM_SMOB_DATA (res
);
1105 while (!SCM_NULLP (rest
))
1108 SCM cs
= SCM_CAR (rest
);
1109 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1111 rest
= SCM_CDR (rest
);
1113 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1114 p
[k
] &= ~((long *) SCM_SMOB_DATA (cs
))[k
];
1121 SCM_DEFINE (scm_char_set_xor
, "char-set-xor", 1, 0, 1,
1122 (SCM cs1
, SCM rest
),
1123 "Return the exclusive--or of all argument character sets.")
1124 #define FUNC_NAME s_scm_char_set_xor
1130 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1131 SCM_VALIDATE_REST_ARGUMENT (rest
);
1133 res
= scm_char_set_copy (cs1
);
1134 p
= (long *) SCM_SMOB_DATA (res
);
1135 while (!SCM_NULLP (rest
))
1138 SCM cs
= SCM_CAR (rest
);
1139 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1141 rest
= SCM_CDR (rest
);
1143 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1144 p
[k
] ^= ((long *) SCM_SMOB_DATA (cs
))[k
];
1151 SCM_DEFINE (scm_char_set_diff_plus_intersection
, "char-set-diff+intersection", 1, 0, 1,
1152 (SCM cs1
, SCM rest
),
1153 "Return the difference and the intersection of all argument\n"
1155 #define FUNC_NAME s_scm_char_set_diff_plus_intersection
1161 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1162 SCM_VALIDATE_REST_ARGUMENT (rest
);
1164 res1
= scm_char_set_copy (cs1
);
1165 res2
= scm_char_set_copy (cs1
);
1166 p
= (long *) SCM_SMOB_DATA (res1
);
1167 q
= (long *) SCM_SMOB_DATA (res2
);
1168 while (!SCM_NULLP (rest
))
1171 SCM cs
= SCM_CAR (rest
);
1172 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1174 rest
= SCM_CDR (rest
);
1176 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1178 p
[k
] &= ~((long *) SCM_SMOB_DATA (cs
))[k
];
1179 q
[k
] &= ((long *) SCM_SMOB_DATA (cs
))[k
];
1182 return scm_values (SCM_LIST2 (res1
, res2
));
1187 SCM_DEFINE (scm_char_set_complement_x
, "char-set-complement!", 1, 0, 0,
1189 "Return the complement of the character set @var{cs}.")
1190 #define FUNC_NAME s_scm_char_set_complement_x
1195 SCM_VALIDATE_SMOB (1, cs
, charset
);
1196 p
= (long *) SCM_SMOB_DATA (cs
);
1197 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1204 SCM_DEFINE (scm_char_set_union_x
, "char-set-union!", 1, 0, 1,
1205 (SCM cs1
, SCM rest
),
1206 "Return the union of all argument character sets.")
1207 #define FUNC_NAME s_scm_char_set_union_x
1212 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1213 SCM_VALIDATE_REST_ARGUMENT (rest
);
1215 p
= (long *) SCM_SMOB_DATA (cs1
);
1216 while (!SCM_NULLP (rest
))
1219 SCM cs
= SCM_CAR (rest
);
1220 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1222 rest
= SCM_CDR (rest
);
1224 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1225 p
[k
] |= ((long *) SCM_SMOB_DATA (cs
))[k
];
1232 SCM_DEFINE (scm_char_set_intersection_x
, "char-set-intersection!", 1, 0, 1,
1233 (SCM cs1
, SCM rest
),
1234 "Return the intersection of all argument character sets.")
1235 #define FUNC_NAME s_scm_char_set_intersection_x
1240 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1241 SCM_VALIDATE_REST_ARGUMENT (rest
);
1243 p
= (long *) SCM_SMOB_DATA (cs1
);
1244 while (!SCM_NULLP (rest
))
1247 SCM cs
= SCM_CAR (rest
);
1248 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1250 rest
= SCM_CDR (rest
);
1252 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1253 p
[k
] &= ((long *) SCM_SMOB_DATA (cs
))[k
];
1260 SCM_DEFINE (scm_char_set_difference_x
, "char-set-difference!", 1, 0, 1,
1261 (SCM cs1
, SCM rest
),
1262 "Return the difference of all argument character sets.")
1263 #define FUNC_NAME s_scm_char_set_difference_x
1268 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1269 SCM_VALIDATE_REST_ARGUMENT (rest
);
1271 p
= (long *) SCM_SMOB_DATA (cs1
);
1272 while (!SCM_NULLP (rest
))
1275 SCM cs
= SCM_CAR (rest
);
1276 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1278 rest
= SCM_CDR (rest
);
1280 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1281 p
[k
] &= ~((long *) SCM_SMOB_DATA (cs
))[k
];
1288 SCM_DEFINE (scm_char_set_xor_x
, "char-set-xor!", 1, 0, 1,
1289 (SCM cs1
, SCM rest
),
1290 "Return the exclusive--or of all argument character sets.")
1291 #define FUNC_NAME s_scm_char_set_xor_x
1296 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1297 SCM_VALIDATE_REST_ARGUMENT (rest
);
1299 p
= (long *) SCM_SMOB_DATA (cs1
);
1300 while (!SCM_NULLP (rest
))
1303 SCM cs
= SCM_CAR (rest
);
1304 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1306 rest
= SCM_CDR (rest
);
1308 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1309 p
[k
] ^= ((long *) SCM_SMOB_DATA (cs
))[k
];
1316 SCM_DEFINE (scm_char_set_diff_plus_intersection_x
, "char-set-diff+intersection!", 1, 0, 1,
1317 (SCM cs1
, SCM rest
),
1318 "Return the difference and the intersection of all argument character sets.")
1319 #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
1325 SCM_VALIDATE_SMOB (1, cs1
, charset
);
1326 SCM_VALIDATE_REST_ARGUMENT (rest
);
1328 res2
= scm_char_set_copy (cs1
);
1329 p
= (long *) SCM_SMOB_DATA (cs1
);
1330 q
= (long *) SCM_SMOB_DATA (res2
);
1331 while (!SCM_NULLP (rest
))
1334 SCM cs
= SCM_CAR (rest
);
1335 SCM_VALIDATE_SMOB (c
, cs
, charset
);
1337 rest
= SCM_CDR (rest
);
1339 for (k
= 0; k
< SCM_CHARSET_SIZE
/ sizeof (long); k
++)
1341 p
[k
] &= ~((long *) SCM_SMOB_DATA (cs
))[k
];
1342 q
[k
] &= ((long *) SCM_SMOB_DATA (cs
))[k
];
1345 return scm_values (SCM_LIST2 (cs1
, res2
));
1351 scm_c_init_srfi_14 (void)
1353 static int initialized
= 0;
1357 scm_tc16_charset
= scm_make_smob_type ("character-set",
1358 SCM_CHARSET_SIZE
* sizeof (long));
1359 scm_set_smob_free (scm_tc16_charset
, charset_free
);
1360 scm_set_smob_print (scm_tc16_charset
, charset_print
);
1366 scm_init_srfi_14 (void)
1368 scm_c_init_srfi_14 ();
1369 #ifndef SCM_MAGIC_SNARFER
1370 #include "srfi/srfi-14.x"