mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-01 07:20:20 +02:00
Code Activity
guile/libguile/srfi-14.c
Andy Wingo 552960b3e2 Move struct scm_thread definition to private header 
Allows us to inline the "struct scm_dynamic_state", avoiding an untagged
traced allocation.

* libguile/threads-internal.h: New file.
* libguile/Makefile.am (noinst_HEADERS): Add new file.

Adapt all users, notably of SCM_I_CURRENT_THREAD and scm_i_misc_mutex.
2025-06-25 12:55:18 +02:00

1979 lines
54 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* Copyright 2001,2004,2006-2007,2009,2011,2018-2019,2022,2025
Free Software Foundation, Inc.
This file is part of Guile.
Guile is free software: you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Guile is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.
You should have received a copy of the GNU Lesser General Public
License along with Guile. If not, see
<https://www.gnu.org/licenses/>. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <stdio.h>
#include <string.h>
#include <unictype.h>
#include "boolean.h"
#include "bytevectors-internal.h"
#include "chars.h"
#include "eval.h"
#include "extensions.h"
#include "gsubr.h"
#include "list.h"
#include "modules.h"
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
#include "procs.h"
#include "strings-internal.h"
#include "symbols.h"
#include "threads-internal.h"
#include "values.h"
#include "version.h"
#include "srfi-14.h"
typedef struct scm_char_range
{
scm_t_wchar lo;
scm_t_wchar hi;
} scm_t_char_range;
/* Include the pre-computed standard charset data. */
#include "srfi-14.i.c"
/* We call this "charset" instead of "char_set" to avoid confusion with
"set" as a verb. */
struct scm_charset
{
scm_t_bits tag_and_flags;
struct scm_bytevector *ranges;
};
static inline struct scm_charset*
scm_to_charset (SCM scm)
{
if (!scm_is_char_set (scm)) abort();
return (struct scm_charset *) SCM_UNPACK_POINTER (scm);
}
static inline SCM
scm_from_charset (struct scm_charset *s)
{
return SCM_PACK_POINTER (s);
}
static inline scm_t_char_range*
char_ranges (struct scm_bytevector *bv)
{
return (scm_t_char_range *) scm_bytevector_contents (bv);
}
static inline size_t
char_ranges_len (struct scm_bytevector *bv)
{
return bv->length / sizeof (scm_t_char_range);
}
static inline size_t
charset_len (struct scm_charset *s)
{
return char_ranges_len (s->ranges);
}
static inline scm_t_char_range*
charset_range (struct scm_charset *s, size_t i)
{
return char_ranges (s->ranges) + i;
}
static inline scm_t_wchar
charset_range_lo (struct scm_charset *s, size_t i)
{
return charset_range (s, i)->lo;
}
static inline scm_t_wchar
charset_range_hi (struct scm_charset *s, size_t i)
{
return charset_range (s, i)->hi;
}
static inline void
charset_range_set_lo (struct scm_charset *s, size_t i, scm_t_wchar ch)
{
charset_range (s, i)->lo = ch;
}
static inline void
charset_range_set_hi (struct scm_charset *s, size_t i, scm_t_wchar ch)
{
charset_range (s, i)->hi = ch;
}
static inline int
charset_range_contains (struct scm_charset *s, size_t idx, scm_t_wchar c)
{
scm_t_char_range *range = charset_range (s, idx);
return range->lo <= c && c <= range->hi;
}
static const scm_t_bits SCM_CHARSET_F_IMMUTABLE = 1 << 16;
static inline int
charset_is_immutable (SCM charset)
{
return scm_to_charset (charset)->tag_and_flags & SCM_CHARSET_F_IMMUTABLE;
}
#define SCM_VALIDATE_CHARSET(pos, x) \
do { \
SCM_ASSERT_TYPE (SCM_CHARSETP (x), x, pos, FUNC_NAME, "charset"); \
} while (0)
#define SCM_VALIDATE_MUTABLE_CHARSET(pos, x) \
do { \
SCM_ASSERT_TYPE (SCM_CHARSETP (x) && !charset_is_immutable (x), \
x, pos, FUNC_NAME, "mutable charset"); \
} while (0)
static const scm_t_char_range cs_full_ranges[] = {
{0x0000, SCM_CODEPOINT_SURROGATE_START - 1},
{SCM_CODEPOINT_SURROGATE_END + 1, SCM_CODEPOINT_MAX}
};
static const size_t cs_full_len = 2;
#define SCM_CHARSET_GET(cs,idx) charset_get (scm_to_charset (cs), idx)
#define SCM_CHARSET_SET(cs, idx) charset_set (scm_to_charset (cs), idx)
#define SCM_CHARSET_UNSET(cs, idx) charset_unset (scm_to_charset (cs), idx)
static struct scm_bytevector *empty_charset_ranges;
static struct scm_charset *
make_charset (struct scm_bytevector *ranges)
{
struct scm_charset *p = scm_allocate_tagged (SCM_I_CURRENT_THREAD,
sizeof (struct scm_charset));
p->tag_and_flags = scm_tc16_charset;
p->ranges = ranges;
return p;
}
static struct scm_charset *
make_static_charset (size_t len, const scm_t_char_range *ranges)
{
size_t u32_count = len * sizeof (*ranges) / sizeof(uint32_t);
SCM bv = scm_c_take_typed_bytevector ((signed char*) ranges, u32_count,
SCM_ARRAY_ELEMENT_TYPE_U32,
SCM_BOOL_F);
struct scm_charset *ret = make_charset (scm_to_bytevector (bv));
ret->tag_and_flags |= SCM_CHARSET_F_IMMUTABLE;
return ret;
}
static struct scm_bytevector *
make_ranges (size_t n)
{
return n
? scm_i_make_typed_bytevector (n * 2, SCM_ARRAY_ELEMENT_TYPE_U32)
: empty_charset_ranges;
}
static void
copy_ranges (scm_t_char_range *dst, scm_t_char_range *src, size_t count)
{
if (count)
memcpy (dst, src, count * sizeof(*dst));
}
static struct scm_bytevector *
clone_ranges (struct scm_bytevector *ranges)
{
size_t len = char_ranges_len (ranges);
struct scm_bytevector *ret = make_ranges (len);
copy_ranges (char_ranges (ret), char_ranges (ranges), len);
return ret;
}
static struct scm_charset*
clone_charset (struct scm_charset *src)
{
return make_charset (clone_ranges (src->ranges));
}
/* True if N exists in charset CS. */
static int
charset_get (struct scm_charset *cs, scm_t_wchar n)
{
size_t i;
i = 0;
while (i < charset_len (cs))
{
if (charset_range_contains (cs, i, n))
return 1;
i++;
}
return 0;
}
static struct scm_bytevector *
char_ranges_insert (struct scm_bytevector *ranges, size_t idx,
scm_t_wchar lo, scm_t_wchar hi)
{
size_t len = char_ranges_len (ranges);
struct scm_bytevector *new_ranges = make_ranges (len + 1);
struct scm_char_range inserted = { lo, hi };
copy_ranges (char_ranges (new_ranges), char_ranges (ranges), idx);
char_ranges (new_ranges)[idx] = inserted;
copy_ranges (char_ranges (new_ranges) + idx + 1,
char_ranges (ranges) + idx,
len - idx);
return new_ranges;
}
static struct scm_bytevector *
char_ranges_delete (struct scm_bytevector *ranges, size_t idx)
{
size_t len = char_ranges_len (ranges);
struct scm_bytevector *new_ranges = make_ranges (len - 1);
copy_ranges (char_ranges (new_ranges), char_ranges (ranges), idx);
copy_ranges (char_ranges (new_ranges) + idx,
char_ranges (ranges) + idx + 1,
len - idx - 1);
return new_ranges;
}
/* Put N into charset CS. */
static void
charset_set (struct scm_charset *cs, scm_t_wchar n)
{
size_t i;
size_t len;
len = charset_len (cs);
i = 0;
while (i < len)
{
/* Already in this range */
if (charset_range_contains (cs, i, n))
{
return;
}
if (n == charset_range_lo (cs, i) - 1)
{
/* This char is one below the current range. */
if (i > 0 && charset_range_hi (cs, i - 1) + 1 == n)
{
/* It is also one above the previous range. */
/* This is an impossible condition: in the previous
iteration, the test for 'one above the current range'
should already have inserted the character here. */
abort ();
}
else
{
/* Expand the range down by one. */
charset_range_set_lo (cs, i, n);
return;
}
}
else if (n == charset_range_hi (cs, i) + 1)
{
/* This char is one above the current range. */
if (i < len - 1 && charset_range_lo (cs, i + 1) - 1 == n)
{
/* It is also one below the next range, so combine them. */
charset_range_set_hi (cs, i, charset_range_hi (cs, i + 1));
cs->ranges = char_ranges_delete (cs->ranges, i + 1);
return;
}
else
{
/* Expand the range up by one. */
charset_range_set_hi (cs, i, n);
return;
}
}
else if (n < charset_range_lo (cs, i) - 1)
{
/* This is a new range below the current one. */
cs->ranges = char_ranges_insert (cs->ranges, i, n, n);
return;
}
i++;
}
/* This is a new range above all previous ranges. */
cs->ranges = char_ranges_insert (cs->ranges, len, n, n);
return;
}
/* Put LO to HI inclusive into charset CS. */
static void
charset_set_range (struct scm_charset *cs, scm_t_wchar lo, scm_t_wchar hi)
{
size_t i;
i = 0;
while (i < charset_len (cs))
{
/* Already in this range */
if (charset_range_lo (cs, i) <= lo && charset_range_hi (cs, i) >= hi)
return;
/* cur: +---+
new: +---+
*/
if (charset_range_lo (cs, i) - 1 > hi)
{
/* Add a new range below the current one. */
cs->ranges = char_ranges_insert (cs->ranges, i, lo, hi);
return;
}
/* cur: +---+ or +---+ or +---+
new: +---+ +---+ +---+
*/
if (charset_range_lo (cs, i) > lo
&& (charset_range_lo (cs, i) - 1 <= hi && charset_range_hi (cs, i) >= hi))
{
charset_range_set_lo (cs, i, lo);
return;
}
/* cur: +---+ or +---+ or +---+
new: +---+ +---+ +---+
*/
else if (charset_range_hi (cs, i) + 1 >= lo && charset_range_hi (cs, i) < hi)
{
if (charset_range_lo (cs, i) > lo)
charset_range_set_lo (cs, i, lo);
if (charset_range_hi (cs, i) < hi)
charset_range_set_hi (cs, i, hi);
while (i < charset_len (cs) - 1)
{
/* cur: --+ +---+
new: -----+
*/
if (charset_range_lo (cs, i + 1) - 1 > hi)
break;
/* cur: --+ +---+ or --+ +---+ or --+ +--+
new: -----+ ------+ ---------+
*/
/* Combine this range with the previous one. */
if (charset_range_hi (cs, i + 1) > hi)
charset_range_set_hi (cs, i, charset_range_hi (cs, i + 1));
cs->ranges = char_ranges_delete (cs->ranges, i + 1);
}
return;
}
i ++;
}
/* This is a new range above all previous ranges. */
cs->ranges = char_ranges_insert (cs->ranges, charset_len (cs), lo, hi);
return;
}
/* If N is in charset CS, remove it. */
static void
charset_unset (struct scm_charset *cs, scm_t_wchar n)
{
size_t i;
size_t len;
len = charset_len (cs);
i = 0;
while (i < len)
{
if (n < charset_range_lo (cs, i))
/* Not in this set. */
return;
if (n == charset_range_lo (cs, i) && n == charset_range_hi (cs, i))
{
/* Remove this one-character range. */
cs->ranges = char_ranges_delete (cs->ranges, i);
return;
}
else if (n == charset_range_lo (cs, i))
{
/* Shrink this range from the left. */
charset_range_set_lo (cs, i, n + 1);
return;
}
else if (n == charset_range_hi (cs, i))
{
/* Shrink this range from the right. */
charset_range_set_hi (cs, i, n - 1);
return;
}
else if (n > charset_range_lo (cs, i) && n < charset_range_hi (cs, i))
{
/* Split this range into two pieces. */
cs->ranges = char_ranges_insert (cs->ranges, i + 1,
n + 1, charset_range_hi (cs, i));
charset_range_set_hi (cs, i, n - 1);
return;
}
i++;
}
/* This value is above all ranges, so do nothing here. */
return;
}
static int
charsets_equal (struct scm_charset *a, struct scm_charset *b)
{
return scm_is_true (scm_bytevector_eq_p (scm_from_bytevector (a->ranges),
scm_from_bytevector (b->ranges)));
}
/* Return true if every character in A is also in B. */
static int
charsets_leq (struct scm_charset *a, struct scm_charset *b)
{
size_t i = 0, j = 0;
scm_t_wchar alo, ahi;
if (charset_len (a) == 0)
return 1;
if (charset_len (b) == 0)
return 0;
while (i < charset_len (a))
{
alo = charset_range_lo (a, i);
ahi = charset_range_hi (a, i);
while (charset_range_hi (b, j) < alo)
{
if (j < charset_len (b) - 1)
j++;
else
return 0;
}
if (alo < charset_range_lo (b, j) || ahi > charset_range_hi (b, j))
return 0;
i++;
}
return 1;
}
/* Merge B into A. */
static void
charsets_union (struct scm_charset *a, struct scm_charset *b)
{
size_t i = 0;
scm_t_wchar blo, bhi;
if (charset_len (a) == 0)
{
a->ranges = clone_ranges (b->ranges);
return;
}
while (i < charset_len (b))
{
blo = charset_range_lo (b, i);
bhi = charset_range_hi (b, i);
charset_set_range (a, blo, bhi);
i++;
}
return;
}
/* Remove elements not both in A and B from A. */
static void
charsets_intersection (struct scm_charset *a, struct scm_charset *b)
{
scm_t_wchar blo, bhi, n;
if (charset_len (a) == 0)
return;
if (charset_len (b) == 0)
{
a->ranges = empty_charset_ranges;
return;
}
struct scm_charset *c = make_charset (empty_charset_ranges);
size_t i = 0;
while (i < charset_len (b))
{
blo = charset_range_lo (b, i);
bhi = charset_range_hi (b, i);
for (n = blo; n <= bhi; n++)
if (charset_get (a, n))
charset_set (c, n);
i++;
}
a->ranges = c->ranges;
}
#define SCM_ADD_RANGE(low, high) \
do { \
charset_range_set_lo (p, idx,low); \
charset_range_set_hi (p, idx++, high); \
} while (0)
#define SCM_ADD_RANGE_SKIP_SURROGATES(low, high) \
do { \
charset_range_set_lo (p, idx, low); \
charset_range_set_hi (p, idx++, SCM_CODEPOINT_SURROGATE_START - 1); \
charset_range_set_lo (p, idx, SCM_CODEPOINT_SURROGATE_END + 1); \
charset_range_set_hi (p, idx++, high); \
} while (0)
/* Make P the compelement of Q. */
static void
charsets_complement (struct scm_charset *p, struct scm_charset *q)
{
int k, idx;
idx = 0;
if (charset_len (q) == 0)
{
/* Fill with all valid codepoints. */
p->ranges = make_ranges (2);
SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
return;
}
/* Count the number of ranges needed for the output. */
size_t len = charset_len (q);
if (charset_range_lo (q, 0) > 0)
len++;
if (charset_range_hi (q, charset_len (q) - 1) < SCM_CODEPOINT_MAX)
len++;
p->ranges = make_ranges (len);
if (charset_range_lo (q, 0) > 0)
{
if (charset_range_lo (q, 0) > SCM_CODEPOINT_SURROGATE_END)
SCM_ADD_RANGE_SKIP_SURROGATES (0, charset_range_lo (q, 0) - 1);
else
SCM_ADD_RANGE (0, charset_range_lo (q, 0) - 1);
}
for (k = 1; k < charset_len (q); k++)
{
if (charset_range_hi (q, k - 1) < SCM_CODEPOINT_SURROGATE_START
&& charset_range_lo (q, k) - 1 > SCM_CODEPOINT_SURROGATE_END)
SCM_ADD_RANGE_SKIP_SURROGATES (charset_range_hi (q, k - 1) + 1, charset_range_lo (q, k) - 1);
else
SCM_ADD_RANGE (charset_range_hi (q, k - 1) + 1, charset_range_lo (q, k) - 1);
}
if (charset_range_hi (q, charset_len (q) - 1) < SCM_CODEPOINT_MAX)
{
if (charset_range_hi (q, charset_len (q) - 1) < SCM_CODEPOINT_SURROGATE_START)
SCM_ADD_RANGE_SKIP_SURROGATES (charset_range_hi (q, charset_len (q) - 1) + 1, SCM_CODEPOINT_MAX);
else
SCM_ADD_RANGE (charset_range_hi (q, charset_len (q) - 1) + 1, SCM_CODEPOINT_MAX);
}
return;
}
#undef SCM_ADD_RANGE
#undef SCM_ADD_RANGE_SKIP_SURROGATES
/* Replace A with elements only found in one of A or B. */
static void
charsets_xor (struct scm_charset *a, struct scm_charset *b)
{
size_t i = 0;
scm_t_wchar blo, bhi, n;
if (charset_len (b) == 0)
return;
if (charset_len (a) == 0)
{
a->ranges = clone_ranges (b->ranges);
return;
}
while (i < charset_len (b))
{
blo = charset_range_lo (b, i);
bhi = charset_range_hi (b, i);
for (n = blo; n <= bhi; n++)
{
if (charset_get (a, n))
charset_unset (a, n);
else
charset_set (a, n);
}
i++;
}
return;
}
int
scm_i_print_char_set (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
{
size_t i;
int first = 1;
struct scm_charset *p;
const size_t max_ranges_to_print = 50;
p = scm_to_charset (charset);
scm_puts ("#<charset {", port);
for (i = 0; i < charset_len (p); i++)
{
if (first)
first = 0;
else
scm_puts (" ", port);
scm_write (SCM_MAKE_CHAR (charset_range_lo (p, i)), port);
if (charset_range_lo (p, i) != charset_range_hi (p, i))
{
scm_puts ("..", port);
scm_write (SCM_MAKE_CHAR (charset_range_hi (p, i)), port);
}
if (i >= max_ranges_to_print)
{
/* Too many to print here. Quit early. */
scm_puts (" ...", port);
break;
}
}
scm_puts ("}>", port);
return 1;
}
SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
"otherwise.")
#define FUNC_NAME s_scm_char_set_p
{
return scm_from_bool (scm_is_char_set (obj));
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_charset_mutable_p, "charset-mutable?", 1, 0, 0,
(SCM cs),
"Return @code{#t} if the character set @var{cs} is mutable,\n"
"@code{#f} otherwise.")
#define FUNC_NAME s_scm_char_set_p
{
SCM_VALIDATE_CHARSET (1, cs);
return scm_from_bool (!charset_is_immutable (cs));
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_charset_ranges, "charset-ranges", 1, 0, 0,
(SCM cs),
"Return the {lo, hi} packed sorted array of inclusive\n"
"ranges of the character set @var{cs}, as a u32vector.")
#define FUNC_NAME s_scm_char_set_p
{
SCM_VALIDATE_CHARSET (1, cs);
return scm_from_bytevector (scm_to_charset (cs)->ranges);
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_charset_set_ranges_x, "charset-set-ranges!", 2, 0, 0,
(SCM cs, SCM ranges),
"Replace the {lo, hi} packed sorted array of inclusive\n"
"ranges of the character set @var{cs} with the given\n"
"u32vector.")
#define FUNC_NAME s_scm_char_set_p
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
SCM_VALIDATE_BYTEVECTOR (2, ranges);
struct scm_bytevector *bv = scm_to_bytevector (ranges);
SCM_ASSERT_TYPE
((bv->length % sizeof (scm_t_char_range)) == 0
&& scm_bytevector_element_type (bv) == SCM_ARRAY_ELEMENT_TYPE_U32,
ranges, 2, FUNC_NAME, "char ranges");
scm_to_charset (cs)->ranges = bv;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
int
scm_i_char_sets_equal (SCM a, SCM b)
{
return charsets_equal (scm_to_charset (a), scm_to_charset (b));
}
SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
(SCM char_sets),
"Return @code{#t} if all given character sets are equal.")
#define FUNC_NAME s_scm_char_set_eq
{
int argnum = 1;
struct scm_charset *cs1_data = NULL;
SCM_VALIDATE_REST_ARGUMENT (char_sets);
while (!scm_is_null (char_sets))
{
SCM csi = SCM_CAR (char_sets);
struct scm_charset *csi_data;
SCM_VALIDATE_CHARSET (argnum, csi);
argnum++;
csi_data = scm_to_charset (csi);
if (cs1_data == NULL)
cs1_data = csi_data;
else if (!charsets_equal (cs1_data, csi_data))
return SCM_BOOL_F;
char_sets = SCM_CDR (char_sets);
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
(SCM char_sets),
"Return @code{#t} if every character set @var{char_set}i is a subset\n"
"of character set @var{char_set}i+1.")
#define FUNC_NAME s_scm_char_set_leq
{
int argnum = 1;
struct scm_charset *prev_data = NULL;
SCM_VALIDATE_REST_ARGUMENT (char_sets);
while (!scm_is_null (char_sets))
{
SCM csi = SCM_CAR (char_sets);
struct scm_charset *csi_data;
SCM_VALIDATE_CHARSET (argnum, csi);
argnum++;
csi_data = scm_to_charset (csi);
if (prev_data)
{
if (!charsets_leq (prev_data, csi_data))
return SCM_BOOL_F;
}
prev_data = csi_data;
char_sets = SCM_CDR (char_sets);
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
(SCM cs, SCM bound),
"Compute a hash value for the character set @var{cs}. If\n"
"@var{bound} is given and non-zero, it restricts the\n"
"returned value to the range 0 @dots{} @var{bound} - 1.")
#define FUNC_NAME s_scm_char_set_hash
{
const unsigned long default_bnd = 871;
unsigned long bnd;
struct scm_charset *p;
unsigned long val = 0;
int k;
scm_t_wchar c;
SCM_VALIDATE_CHARSET (1, cs);
if (SCM_UNBNDP (bound))
bnd = default_bnd;
else
{
bnd = scm_to_ulong (bound);
if (bnd == 0)
bnd = default_bnd;
}
p = scm_to_charset (cs);
for (k = 0; k < charset_len (p); k++)
{
for (c = charset_range_lo (p, k); c <= charset_range_hi (p, k); c++)
val = c + (val << 1);
}
return scm_from_ulong (val % bnd);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
(SCM kons, SCM knil, SCM cs),
"Fold the procedure @var{kons} over the character set @var{cs},\n"
"initializing it with @var{knil}.")
#define FUNC_NAME s_scm_char_set_fold
{
struct scm_charset *cs_data;
int k;
scm_t_wchar n;
SCM_VALIDATE_PROC (1, kons);
SCM_VALIDATE_CHARSET (3, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return knil;
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
}
return knil;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
(SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
"This is a fundamental constructor for character sets.\n"
"@itemize @bullet\n"
"@item @var{g} is used to generate a series of ``seed'' values\n"
"from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
"(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
"when applied to one of the seed values.\n"
"@item @var{f} maps each seed value to a character. These\n"
"characters are added to the base character set @var{base_cs} to\n"
"form the result; @var{base_cs} defaults to the empty set.\n"
"@end itemize")
#define FUNC_NAME s_scm_char_set_unfold
{
SCM tmp;
struct scm_charset *result;
SCM_VALIDATE_PROC (1, p);
SCM_VALIDATE_PROC (2, f);
SCM_VALIDATE_PROC (3, g);
if (!SCM_UNBNDP (base_cs))
{
SCM_VALIDATE_CHARSET (5, base_cs);
result = scm_to_charset (scm_char_set_copy (base_cs));
}
else
result = make_charset (empty_charset_ranges);
tmp = scm_call_1 (p, seed);
while (scm_is_false (tmp))
{
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
charset_set (result, SCM_CHAR (ch));
seed = scm_call_1 (g, seed);
tmp = scm_call_1 (p, seed);
}
return scm_from_charset (result);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
(SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
"This is a fundamental constructor for character sets.\n"
"@itemize @bullet\n"
"@item @var{g} is used to generate a series of ``seed'' values\n"
"from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
"(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
"when applied to one of the seed values.\n"
"@item @var{f} maps each seed value to a character. These\n"
"characters are added to the base character set @var{base_cs} to\n"
"form the result; @var{base_cs} defaults to the empty set.\n"
"@end itemize")
#define FUNC_NAME s_scm_char_set_unfold_x
{
SCM tmp;
SCM_VALIDATE_PROC (1, p);
SCM_VALIDATE_PROC (2, f);
SCM_VALIDATE_PROC (3, g);
SCM_VALIDATE_MUTABLE_CHARSET (5, base_cs);
tmp = scm_call_1 (p, seed);
while (scm_is_false (tmp))
{
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
seed = scm_call_1 (g, seed);
tmp = scm_call_1 (p, seed);
}
return base_cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
(SCM proc, SCM cs),
"Apply @var{proc} to every character in the character set\n"
"@var{cs}. The return value is not specified.")
#define FUNC_NAME s_scm_char_set_for_each
{
struct scm_charset *cs_data;
int k;
scm_t_wchar n;
SCM_VALIDATE_PROC (1, proc);
SCM_VALIDATE_CHARSET (2, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return SCM_UNSPECIFIED;
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
scm_call_1 (proc, SCM_MAKE_CHAR (n));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
(SCM proc, SCM cs),
"Map the procedure @var{proc} over every character in @var{cs}.\n"
"@var{proc} must be a character -> character procedure.")
#define FUNC_NAME s_scm_char_set_map
{
int k;
scm_t_wchar n;
SCM_VALIDATE_PROC (1, proc);
SCM_VALIDATE_CHARSET (2, cs);
struct scm_charset *result = make_charset (empty_charset_ranges);
struct scm_charset *cs_data = scm_to_charset (cs);
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char",
scm_list_1 (proc));
charset_set (result, SCM_CHAR (ch));
}
return scm_from_charset (result);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
(SCM cs),
"Return a newly allocated character set containing all\n"
"characters in @var{cs}.")
#define FUNC_NAME s_scm_char_set_copy
{
SCM_VALIDATE_CHARSET (1, cs);
return scm_from_charset (clone_charset (scm_to_charset (cs)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
(SCM rest),
"Return a character set containing all given characters.")
#define FUNC_NAME s_scm_char_set
{
int argnum = 1;
SCM_VALIDATE_REST_ARGUMENT (rest);
struct scm_charset *cs = make_charset (empty_charset_ranges);
while (!scm_is_null (rest))
{
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
argnum++;
rest = SCM_CDR (rest);
charset_set (cs, c);
}
return scm_from_charset (cs);
}
#undef FUNC_NAME
SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
(SCM list, SCM base_cs),
"Convert the character list @var{list} to a character set. If\n"
"the character set @var{base_cs} is given, the character in this\n"
"set are also included in the result.")
#define FUNC_NAME s_scm_list_to_char_set
{
SCM_VALIDATE_LIST (1, list);
struct scm_charset *cs;
if (SCM_UNBNDP (base_cs))
cs = make_charset (empty_charset_ranges);
else
{
SCM_VALIDATE_CHARSET (2, base_cs);
cs = clone_charset (scm_to_charset (base_cs));
}
while (!scm_is_null (list))
{
SCM chr = SCM_CAR (list);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
charset_set (cs, c);
}
return scm_from_charset (cs);
}
#undef FUNC_NAME
SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
(SCM list, SCM base_cs),
"Convert the character list @var{list} to a character set. The\n"
"characters are added to @var{base_cs} and @var{base_cs} is\n"
"returned.")
#define FUNC_NAME s_scm_list_to_char_set_x
{
SCM_VALIDATE_LIST (1, list);
SCM_VALIDATE_MUTABLE_CHARSET (2, base_cs);
struct scm_charset *cs = scm_to_charset (base_cs);
while (!scm_is_null (list))
{
SCM chr = SCM_CAR (list);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
charset_set (cs, c);
}
return base_cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
(SCM str, SCM base_cs),
"Convert the string @var{str} to a character set. If the\n"
"character set @var{base_cs} is given, the characters in this\n"
"set are also included in the result.")
#define FUNC_NAME s_scm_string_to_char_set
{
size_t k = 0, len;
SCM_VALIDATE_STRING (1, str);
struct scm_charset *cs;
if (SCM_UNBNDP (base_cs))
cs = make_charset (empty_charset_ranges);
else
{
SCM_VALIDATE_CHARSET (2, base_cs);
cs = clone_charset (scm_to_charset (base_cs));
}
len = scm_i_string_length (str);
while (k < len)
{
scm_t_wchar c = scm_i_string_ref (str, k++);
charset_set (cs, c);
}
scm_remember_upto_here_1 (str);
return scm_from_charset (cs);
}
#undef FUNC_NAME
SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
(SCM str, SCM base_cs),
"Convert the string @var{str} to a character set. The\n"
"characters from the string are added to @var{base_cs}, and\n"
"@var{base_cs} is returned.")
#define FUNC_NAME s_scm_string_to_char_set_x
{
size_t k = 0, len;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_MUTABLE_CHARSET (2, base_cs);
struct scm_charset *cs = scm_to_charset (base_cs);
len = scm_i_string_length (str);
while (k < len)
{
scm_t_wchar c = scm_i_string_ref (str, k++);
charset_set (cs, c);
}
scm_remember_upto_here_1 (str);
return base_cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
(SCM pred, SCM cs, SCM base_cs),
"Return a character set containing every character from @var{cs}\n"
"so that it satisfies @var{pred}. If provided, the characters\n"
"from @var{base_cs} are added to the result.")
#define FUNC_NAME s_scm_char_set_filter
{
struct scm_charset *ret;
int k;
scm_t_wchar n;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_CHARSET (2, cs);
if (!SCM_UNBNDP (base_cs))
{
SCM_VALIDATE_CHARSET (3, base_cs);
ret = clone_charset (scm_to_charset (base_cs));
}
else
ret = make_charset (empty_charset_ranges);
struct scm_charset *p = scm_to_charset (cs);
for (k = 0; k < charset_len (p); k++)
for (n = charset_range_lo (p, k); n <= charset_range_hi (p, k); n++)
{
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
charset_set (ret, n);
}
return scm_from_charset (ret);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
(SCM pred, SCM cs, SCM base_cs),
"Return a character set containing every character from @var{cs}\n"
"so that it satisfies @var{pred}. The characters are added to\n"
"@var{base_cs} and @var{base_cs} is returned.")
#define FUNC_NAME s_scm_char_set_filter_x
{
int k;
scm_t_wchar n;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_CHARSET (2, cs);
SCM_VALIDATE_MUTABLE_CHARSET (3, base_cs);
struct scm_charset *src = scm_to_charset (cs);
struct scm_charset *dst = scm_to_charset (base_cs);
for (k = 0; k < charset_len (src); k++)
for (n = charset_range_lo (src, k); n <= charset_range_hi (src, k); n++)
{
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
charset_set (dst, n);
}
return base_cs;
}
#undef FUNC_NAME
/* Return a character set containing all the characters from [LOWER,UPPER),
giving range errors if ERROR, adding chars from BASE_CS, and recycling
BASE_CS if REUSE is true. */
static SCM
scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
SCM error, SCM base_cs, int reuse)
{
size_t clower, cupper;
clower = scm_to_size_t (lower);
cupper = scm_to_size_t (upper) - 1;
SCM_ASSERT_RANGE (2, upper, cupper >= clower);
if (!SCM_UNBNDP (error))
{
if (scm_is_true (error))
{
SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
if (clower < SCM_CODEPOINT_SURROGATE_START
&& cupper > SCM_CODEPOINT_SURROGATE_END)
scm_error(scm_out_of_range_key,
FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
scm_list_2 (lower, upper), scm_list_1 (upper));
}
}
struct scm_charset *cs;
if (SCM_UNBNDP (base_cs))
cs = make_charset (empty_charset_ranges);
else
{
if (reuse)
{
SCM_VALIDATE_MUTABLE_CHARSET (3, base_cs);
cs = scm_to_charset (base_cs);
}
else
{
SCM_VALIDATE_CHARSET (3, base_cs);
cs = clone_charset (scm_to_charset (base_cs));
}
}
if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
&& (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
return scm_from_charset (cs);
if (clower > SCM_CODEPOINT_MAX)
clower = SCM_CODEPOINT_MAX;
if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
clower = SCM_CODEPOINT_SURROGATE_END + 1;
if (cupper > SCM_CODEPOINT_MAX)
cupper = SCM_CODEPOINT_MAX;
if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
cupper = SCM_CODEPOINT_SURROGATE_START - 1;
if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
{
charset_set_range (cs, clower, SCM_CODEPOINT_SURROGATE_START - 1);
charset_set_range (cs, SCM_CODEPOINT_SURROGATE_END + 1, cupper);
}
else
charset_set_range (cs, clower, cupper);
return scm_from_charset (cs);
}
SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
(SCM lower, SCM upper, SCM error, SCM base_cs),
"Return a character set containing all characters whose\n"
"character codes lie in the half-open range\n"
"[@var{lower},@var{upper}).\n"
"\n"
"If @var{error} is a true value, an error is signaled if the\n"
"specified range contains characters which are not valid\n"
"Unicode code points. If @var{error} is @code{#f},\n"
"these characters are silently left out of the resulting\n"
"character set.\n"
"\n"
"The characters in @var{base_cs} are added to the result, if\n"
"given.")
#define FUNC_NAME s_scm_ucs_range_to_char_set
{
return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
error, base_cs, 0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
(SCM lower, SCM upper, SCM error, SCM base_cs),
"Return a character set containing all characters whose\n"
"character codes lie in the half-open range\n"
"[@var{lower},@var{upper}).\n"
"\n"
"If @var{error} is a true value, an error is signaled if the\n"
"specified range contains characters which are not contained in\n"
"the implemented character range. If @var{error} is @code{#f},\n"
"these characters are silently left out of the resulting\n"
"character set.\n"
"\n"
"The characters are added to @var{base_cs} and @var{base_cs} is\n"
"returned.")
#define FUNC_NAME s_scm_ucs_range_to_char_set_x
{
SCM_VALIDATE_CHARSET (4, base_cs);
return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
error, base_cs, 1);
}
#undef FUNC_NAME
SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
(SCM x),
"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.")
#define FUNC_NAME s_scm_to_charset
{
if (scm_is_string (x))
return scm_string_to_char_set (x, SCM_UNDEFINED);
else if (SCM_CHARP (x))
return scm_char_set (scm_list_1 (x));
else if (scm_is_char_set (x))
return x;
else
scm_wrong_type_arg (NULL, 0, x);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
(SCM cs),
"Return the number of elements in character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_size
{
int k, count = 0;
struct scm_charset *cs_data;
SCM_VALIDATE_CHARSET (1, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return scm_from_int (0);
for (k = 0; k < charset_len (cs_data); k++)
count += charset_range_hi (cs_data, k) - charset_range_lo (cs_data, k) + 1;
return scm_from_int (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
(SCM pred, SCM cs),
"Return the number of the elements int the character set\n"
"@var{cs} which satisfy the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_count
{
int k, count = 0;
scm_t_wchar n;
struct scm_charset *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_CHARSET (2, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return scm_from_int (0);
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
count++;
}
return SCM_I_MAKINUM (count);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
(SCM cs),
"Return a list containing the elements of the character set\n"
"@var{cs}.")
#define FUNC_NAME s_scm_char_set_to_list
{
int k;
scm_t_wchar n;
SCM result = SCM_EOL;
struct scm_charset *p;
SCM_VALIDATE_CHARSET (1, cs);
p = scm_to_charset (cs);
if (charset_len (p) == 0)
return SCM_EOL;
for (k = charset_len (p) - 1; k >= 0; k--)
for (n = charset_range_hi (p, k); n >= charset_range_lo (p, k); n--)
result = scm_cons (SCM_MAKE_CHAR (n), result);
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
(SCM cs),
"Return a string containing the elements of the character set\n"
"@var{cs}. The order in which the characters are placed in the\n"
"string is not defined.")
#define FUNC_NAME s_scm_char_set_to_string
{
int k;
int count = 0;
int idx = 0;
int wide = 0;
SCM result;
scm_t_wchar n;
struct scm_charset *cs_data;
char *buf;
scm_t_wchar *wbuf;
SCM_VALIDATE_CHARSET (1, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return scm_nullstr;
if (charset_range_hi (cs_data, charset_len (cs_data) - 1) > 255)
wide = 1;
count = scm_to_int (scm_char_set_size (cs));
if (wide)
result = scm_i_make_wide_string (count, &wbuf, 0);
else
result = scm_i_make_string (count, &buf, 0);
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
if (wide)
wbuf[idx++] = n;
else
buf[idx++] = n;
}
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
(SCM cs, SCM ch),
"Return @code{#t} iff the character @var{ch} is contained in the\n"
"character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_contains_p
{
SCM_VALIDATE_CHARSET (1, cs);
SCM_VALIDATE_CHAR (2, ch);
return scm_from_bool (charset_get (scm_to_charset (cs), SCM_CHAR (ch)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
(SCM pred, SCM cs),
"Return a true value if every character in the character set\n"
"@var{cs} satisfies the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_every
{
int k;
scm_t_wchar n;
SCM res = SCM_BOOL_T;
struct scm_charset *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_CHARSET (2, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return SCM_BOOL_T;
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_false (res))
return res;
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
(SCM pred, SCM cs),
"Return a true value if any character in the character set\n"
"@var{cs} satisfies the predicate @var{pred}.")
#define FUNC_NAME s_scm_char_set_any
{
int k;
scm_t_wchar n;
struct scm_charset *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_CHARSET (2, cs);
cs_data = scm_to_charset (cs);
if (charset_len (cs_data) == 0)
return SCM_BOOL_T;
for (k = 0; k < charset_len (cs_data); k++)
for (n = charset_range_lo (cs_data, k); n <= charset_range_hi (cs_data, k); n++)
{
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
return res;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
(SCM cs, SCM rest),
"Add all character arguments to the first argument, which must\n"
"be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin
{
SCM_VALIDATE_CHARSET (1, cs);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs = scm_char_set_copy (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
SCM_CHARSET_SET (cs, c);
}
return cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
(SCM cs, SCM rest),
"Delete all character arguments from the first argument, which\n"
"must be a character set.")
#define FUNC_NAME s_scm_char_set_delete
{
SCM_VALIDATE_CHARSET (1, cs);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs = scm_char_set_copy (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
SCM_CHARSET_UNSET (cs, c);
}
return cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
(SCM cs, SCM rest),
"Add all character arguments to the first argument, which must\n"
"be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
SCM_VALIDATE_REST_ARGUMENT (rest);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
SCM_CHARSET_SET (cs, c);
}
return cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
(SCM cs, SCM rest),
"Delete all character arguments from the first argument, which\n"
"must be a character set.")
#define FUNC_NAME s_scm_char_set_delete_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
SCM_VALIDATE_REST_ARGUMENT (rest);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
SCM_CHARSET_UNSET (cs, c);
}
return cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
(SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement
{
struct scm_charset *p, *q;
SCM_VALIDATE_CHARSET (1, cs);
p = make_charset (empty_charset_ranges);
q = scm_to_charset (cs);
charsets_complement (p, q);
return scm_from_charset (p);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
(SCM rest),
"Return the union of all argument character sets.")
#define FUNC_NAME s_scm_char_set_union
{
SCM_VALIDATE_REST_ARGUMENT (rest);
struct scm_charset *p = make_charset (empty_charset_ranges);
int argnum = 1;
while (!scm_is_null (rest))
{
SCM cs = SCM_CAR (rest);
SCM_VALIDATE_CHARSET (argnum, cs);
argnum++;
rest = SCM_CDR (rest);
charsets_union (p, scm_to_charset (cs));
}
return scm_from_charset (p);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
(SCM rest),
"Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection
{
SCM_VALIDATE_REST_ARGUMENT (rest);
if (scm_is_null (rest))
return scm_from_charset (make_charset (empty_charset_ranges));
int argnum = 2;
struct scm_charset *res = clone_charset (scm_to_charset (SCM_CAR (rest)));
rest = SCM_CDR (rest);
while (scm_is_pair (rest))
{
SCM cs = SCM_CAR (rest);
rest = SCM_CDR (rest);
SCM_VALIDATE_CHARSET (argnum, cs);
argnum++;
charsets_intersection (res, scm_to_charset (cs));
}
return scm_from_charset (res);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the difference of all argument character sets.")
#define FUNC_NAME s_scm_char_set_difference
{
int c = 2;
struct scm_charset *p, *q;
SCM_VALIDATE_CHARSET (1, cs1);
SCM_VALIDATE_REST_ARGUMENT (rest);
p = clone_charset (scm_to_charset (cs1));
q = make_charset (empty_charset_ranges);
while (!scm_is_null (rest))
{
SCM cs = SCM_CAR (rest);
rest = SCM_CDR (rest);
SCM_VALIDATE_CHARSET (c, cs);
c++;
charsets_complement (q, scm_to_charset (cs));
charsets_intersection (p, q);
}
return scm_from_charset (p);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
(SCM rest),
"Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor
{
SCM_VALIDATE_REST_ARGUMENT (rest);
struct scm_charset *p = make_charset (empty_charset_ranges);
int argnum = 1;
while (scm_is_pair (rest))
{
SCM cs = SCM_CAR (rest);
rest = SCM_CDR (rest);
SCM_VALIDATE_CHARSET (argnum, cs);
argnum++;
charsets_xor (p, scm_to_charset (cs));
}
return scm_from_charset (p);
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the difference and the intersection of all argument\n"
"character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection
{
int c = 2;
struct scm_charset *p, *q;
SCM_VALIDATE_CHARSET (1, cs1);
SCM_VALIDATE_REST_ARGUMENT (rest);
p = clone_charset (scm_to_charset (cs1));
q = make_charset (empty_charset_ranges);
while (!scm_is_null (rest))
{
SCM cs = SCM_CAR (rest);
struct scm_charset *r;
SCM_VALIDATE_CHARSET (c, cs);
c++;
r = scm_to_charset (cs);
charsets_union (q, r);
charsets_intersection (p, r);
rest = SCM_CDR (rest);
}
return scm_values_2 (scm_from_charset (p), scm_from_charset (q));
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
(SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs);
cs = scm_char_set_complement (cs);
return cs;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the union of all argument character sets.")
#define FUNC_NAME s_scm_char_set_union_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs1 = scm_char_set_union (scm_cons (cs1, rest));
return cs1;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
return cs1;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the difference of all argument character sets.")
#define FUNC_NAME s_scm_char_set_difference_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs1 = scm_char_set_difference (cs1, rest);
return cs1;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
(SCM cs1, SCM rest),
"Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor_x
{
SCM_VALIDATE_MUTABLE_CHARSET (1, cs1);
/* a side-effecting variant should presumably give consistent results:
(define a (char-set #\a))
(char-set-xor a a a) -> char set #\a
(char-set-xor! a a a) -> char set #\a
*/
cs1 = scm_char_set_xor (scm_cons (cs1, rest));
return cs1;
}
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
"char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
SCM rest),
"Return the difference and the intersection of all argument\n"
"character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
{
SCM diff, intersect;
diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
intersect =
scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
cs1 = diff;
cs2 = intersect;
return scm_values_2 (cs1, cs2);
}
#undef FUNC_NAME
/* Create an empty character set and return it after binding it to NAME. */
static inline SCM
define_charset (size_t len, const scm_t_char_range *ranges)
{
return scm_from_charset (make_static_charset (len, ranges));
}
SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
"Returns an association list containing debugging information\n"
"for @var{charset}. The association list has the following entries."
"@table @code\n"
"@item char-set\n"
"The char-set itself.\n"
"@item len\n"
"The number of character ranges the char-set contains\n"
"@item ranges\n"
"A list of lists where each sublist a range of code points\n"
"and their associated characters"
"@end table")
#define FUNC_NAME s_scm_sys_char_set_dump
{
SCM e1, e2, e3;
SCM ranges = SCM_EOL, elt;
size_t i;
struct scm_charset *cs;
char codepoint_string_lo[13], codepoint_string_hi[13];
SCM_VALIDATE_CHARSET (1, charset);
cs = scm_to_charset (charset);
e1 = scm_cons (scm_from_latin1_symbol ("char-set"),
charset);
e2 = scm_cons (scm_from_latin1_symbol ("n"),
scm_from_size_t (charset_len (cs)));
for (i = 0; i < charset_len (cs); i++)
{
if (charset_range_lo (cs, i) > 0xFFFF)
sprintf (codepoint_string_lo, "U+%06x", charset_range_lo (cs, i));
else
sprintf (codepoint_string_lo, "U+%04x", charset_range_lo (cs, i));
if (charset_range_hi (cs, i) > 0xFFFF)
sprintf (codepoint_string_hi, "U+%06x", charset_range_hi (cs, i));
else
sprintf (codepoint_string_hi, "U+%04x", charset_range_hi (cs, i));
elt = scm_list_4 (SCM_MAKE_CHAR (charset_range_lo (cs, i)),
SCM_MAKE_CHAR (charset_range_hi (cs, i)),
scm_from_locale_string (codepoint_string_lo),
scm_from_locale_string (codepoint_string_hi));
ranges = scm_append (scm_list_2 (ranges,
scm_list_1 (elt)));
}
e3 = scm_cons (scm_from_latin1_symbol ("ranges"),
ranges);
return scm_list_3 (e1, e2, e3);
}
#undef FUNC_NAME
#define DECLARE_C_CHARSET(name, stem) \
SCM scm_char_set_##stem;
#define DEFINE_C_CHARSET(name, stem) \
scm_char_set_##stem = define_charset (cs_##stem##_len, cs_##stem##_ranges);
#define DEFINE_SCM_CHARSET(name, stem) \
scm_c_define ("char-set:" name, scm_char_set_##stem);
#define FOR_EACH_STANDARD_CHARSET(M) \
M ("upper-case", upper_case) \
M ("lower-case", lower_case) \
M ("title-case", title_case) \
M ("letter", letter) \
M ("digit", digit) \
M ("letter+digit", letter_and_digit) \
M ("graphic", graphic) \
M ("printing", printing) \
M ("whitespace", whitespace) \
M ("iso-control", iso_control) \
M ("punctuation", punctuation) \
M ("symbol", symbol) \
M ("hex-digit", hex_digit) \
M ("blank", blank) \
M ("ascii", ascii) \
M ("empty", empty) \
M ("designated", designated) \
M ("full", full)
FOR_EACH_STANDARD_CHARSET(DECLARE_C_CHARSET)
static void
scm_init_srfi_14 (void)
{
FOR_EACH_STANDARD_CHARSET (DEFINE_SCM_CHARSET);
#include "srfi-14.x"
}
void
scm_boot_srfi_14 (void)
{
empty_charset_ranges =
scm_i_make_typed_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_U32);
FOR_EACH_STANDARD_CHARSET (DEFINE_C_CHARSET);
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_srfi_14",
(scm_t_extension_init_func) scm_init_srfi_14,
NULL);
}
/* End of srfi-14.c. */
View git blame Copy permalink