diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-08-28 19:01:19 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-08-28 19:16:46 +0200 |
commit | 7af531508c5931261ff8957708642cac67bf86a5 (patch) | |
tree | bd36d27d9f7a11d954093d4121ccb9e645f5c59f /libguile/srfi-14.c | |
parent | f86f3b5b113b4cb383c531150b13bef9b2789221 (diff) | |
parent | ce3ed0125fcfb9ad09da815f133a2320102d164c (diff) | |
download | guile-7af531508c5931261ff8957708642cac67bf86a5.tar.gz |
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts:
libguile/Makefile.am
libguile/bytevectors.c
libguile/gc-card.c
libguile/gc-mark.c
libguile/programs.c
libguile/srcprop.c
libguile/srfi-14.c
libguile/symbols.c
libguile/threads.c
libguile/unif.c
libguile/vm.c
Diffstat (limited to 'libguile/srfi-14.c')
-rw-r--r-- | libguile/srfi-14.c | 1477 |
1 files changed, 928 insertions, 549 deletions
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 0d614f6d9..7c0013193 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -24,59 +24,511 @@ #include <string.h> -#include <ctype.h> +#include <unictype.h> #include "libguile.h" #include "libguile/srfi-14.h" +#include "libguile/strings.h" +/* Include the pre-computed standard charset data. */ +#include "libguile/srfi-14.i.c" -#define SCM_CHARSET_SET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ - (1L << ((idx) % SCM_BITS_PER_LONG))) +#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset)) -#define SCM_CHARSET_UNSET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &= \ - (~(1L << ((idx) % SCM_BITS_PER_LONG)))) - -#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) -#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) +#define SCM_CHARSET_SET(cs, idx) \ + scm_i_charset_set (SCM_CHARSET_DATA (cs), idx) +#define SCM_CHARSET_UNSET(cs, idx) \ + scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx) /* Smob type code for character sets. */ int scm_tc16_charset = 0; +int scm_tc16_charset_cursor = 0; + +/* True if N exists in charset CS. */ +int +scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + + i = 0; + while (i < cs->len) + { + if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi) + return 1; + i++; + } + + return 0; +} + +/* Put N into charset CS. */ +void +scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + size_t len; + + len = cs->len; + + i = 0; + while (i < len) + { + /* Already in this range */ + if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi) + { + return; + } + + if (n == cs->ranges[i].lo - 1) + { + /* This char is one below the current range. */ + if (i > 0 && cs->ranges[i - 1].hi + 1 == n) + { + /* It is also one above the previous range, so combine them. */ + cs->ranges[i - 1].hi = cs->ranges[i].hi; + if (i < len - 1) + memmove (cs->ranges + i, cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else + { + /* Expand the range down by one. */ + cs->ranges[i].lo = n; + return; + } + } + else if (n == cs->ranges[i].hi + 1) + { + /* This char is one above the current range. */ + if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n) + { + /* It is also one below the next range, so combine them. */ + cs->ranges[i].hi = cs->ranges[i + 1].hi; + if (i < len - 2) + memmove (cs->ranges + (i + 1), cs->ranges + (i + 2), + sizeof (scm_t_char_range) * (len - i - 2)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else + { + /* Expand the range up by one. */ + cs->ranges[i].hi = n; + return; + } + } + else if (n < cs->ranges[i].lo - 1) + { + /* This is a new range below the current one. */ + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + memmove (cs->ranges + (i + 1), cs->ranges + i, + sizeof (scm_t_char_range) * (len - i)); + cs->ranges[i].lo = n; + cs->ranges[i].hi = n; + cs->len = len + 1; + return; + } + + i++; + } + + /* This is a new range above all previous ranges. */ + if (len == 0) + { + cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set"); + } + else + { + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + } + cs->ranges[len].lo = n; + cs->ranges[len].hi = n; + cs->len = len + 1; + + return; +} + +/* If N is in charset CS, remove it. */ +void +scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + size_t len; + + len = cs->len; + + i = 0; + while (i < len) + { + if (n < cs->ranges[i].lo) + /* Not in this set. */ + return; + + if (n == cs->ranges[i].lo && n == cs->ranges[i].hi) + { + /* Remove this one-character range. */ + if (len == 1) + { + scm_gc_free (cs->ranges, + sizeof (scm_t_char_range) * cs->len, + "character-set"); + cs->ranges = NULL; + cs->len = 0; + return; + } + else if (i < len - 1) + { + memmove (cs->ranges + i, cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else if (i == len - 1) + { + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + } + else if (n == cs->ranges[i].lo) + { + /* Shrink this range from the left. */ + cs->ranges[i].lo = n + 1; + return; + } + else if (n == cs->ranges[i].hi) + { + /* Shrink this range from the right. */ + cs->ranges[i].hi = n - 1; + return; + } + else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi) + { + /* Split this range into two pieces. */ + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + if (i < len - 1) + memmove (cs->ranges + (i + 2), cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges[i + 1].hi = cs->ranges[i].hi; + cs->ranges[i + 1].lo = n + 1; + cs->ranges[i].hi = n - 1; + cs->len = len + 1; + return; + } + + i++; + } + + /* This value is above all ranges, so do nothing here. */ + return; +} + +static int +charsets_equal (scm_t_char_set *a, scm_t_char_set *b) +{ + if (a->len != b->len) + return 0; + + if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0) + return 0; + + return 1; +} + +/* Return true if every character in A is also in B. */ +static int +charsets_leq (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0, j = 0; + scm_t_wchar alo, ahi; + + if (a->len == 0) + return 1; + if (b->len == 0) + return 0; + while (i < a->len) + { + alo = a->ranges[i].lo; + ahi = a->ranges[i].hi; + while (b->ranges[j].hi < alo) + { + if (j < b->len - 1) + j++; + else + return 0; + } + if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi) + return 0; + i++; + } + + return 1; +} + +/* Merge B into A. */ +static void +charsets_union (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + + if (b->len == 0) + return; + + if (a->len == 0) + { + a->len = b->len; + a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len, + "character-set"); + memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len); + return; + } + + /* This needs optimization. */ + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + scm_i_charset_set (a, n); + + i++; + } + + return; +} + +/* Remove elements not both in A and B from A. */ +static void +charsets_intersection (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + scm_t_char_set *c; + + if (a->len == 0) + return; + + if (b->len == 0) + { + scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len, + "character-set"); + a->len = 0; + return; + } + + c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set)); + c->len = 0; + c->ranges = NULL; + + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + if (scm_i_charset_get (a, n)) + scm_i_charset_set (c, n); + i++; + } + scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len, + "character-set"); + + a->len = c->len; + if (c->len != 0) + a->ranges = c->ranges; + else + a->ranges = NULL; + free (c); + return; +} + +/* Make P the compelement of Q. */ +static void +charsets_complement (scm_t_char_set *p, scm_t_char_set *q) +{ + int k, idx; + + if (q->len == 0) + { + /* Fill with all valid codepoints. */ + p->len = 2; + p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2, + "character-set"); + p->ranges[0].lo = 0; + p->ranges[0].hi = 0xd7ff; + p->ranges[1].lo = 0xe000; + p->ranges[1].hi = SCM_CODEPOINT_MAX; + return; + } + + if (p->len > 0) + scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len, + "character-set"); + + p->len = 0; + if (q->ranges[0].lo > 0) + p->len++; + if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX) + p->len++; + p->len += q->len - 1; + p->ranges = + (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len, + "character-set"); + idx = 0; + if (q->ranges[0].lo > 0) + { + p->ranges[idx].lo = 0; + p->ranges[idx++].hi = q->ranges[0].lo - 1; + } + for (k = 1; k < q->len; k++) + { + p->ranges[idx].lo = q->ranges[k - 1].hi + 1; + p->ranges[idx++].hi = q->ranges[k].lo - 1; + } + if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX) + { + p->ranges[idx].lo = q->ranges[q->len - 1].hi + 1; + p->ranges[idx].hi = SCM_CODEPOINT_MAX; + } + return; +} + +/* Replace A with elements only found in one of A or B. */ +static void +charsets_xor (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + + if (b->len == 0) + { + return; + } + if (a->len == 0) + { + a->ranges = + (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * + b->len, "character-set"); + a->len = b->len; + memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len); + return; + } + + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + { + if (scm_i_charset_get (a, n)) + scm_i_charset_unset (a, n); + else + scm_i_charset_set (a, n); + } + + i++; + } + return; +} /* Smob print hook for character sets. */ static int charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) { - int i; + size_t i; int first = 1; + scm_t_char_set *p; + const size_t max_ranges_to_print = 50; + + p = SCM_CHARSET_DATA (charset); scm_puts ("#<charset {", port); - for (i = 0; i < SCM_CHARSET_SIZE; i++) - if (SCM_CHARSET_GET (charset, i)) - { - if (first) - first = 0; - else - scm_puts (" ", port); - scm_write (SCM_MAKE_CHAR (i), port); - } + for (i = 0; i < p->len; i++) + { + if (first) + first = 0; + else + scm_puts (" ", port); + scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port); + if (p->ranges[i].lo != p->ranges[i].hi) + { + scm_puts ("..", port); + scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port); + } + if (i >= max_ranges_to_print) + { + /* Too many to print here. Quit early. */ + scm_puts (" ...", port); + break; + } + } scm_puts ("}>", port); return 1; } +/* Smob print hook for character sets cursors. */ +static int +charset_cursor_print (SCM cursor, SCM port, + scm_print_state *pstate SCM_UNUSED) +{ + scm_t_char_set_cursor *cur; + + cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + + scm_puts ("#<charset-cursor ", port); + if (cur->range == (size_t) (-1)) + scm_puts ("(empty)", port); + else + { + scm_write (scm_from_size_t (cur->range), port); + scm_puts (":", port); + scm_write (scm_from_int32 (cur->n), port); + } + scm_puts (">", port); + return 1; +} /* Create a new, empty character set. */ static SCM -make_char_set (const char * func_name) +make_char_set (const char *func_name) { - long * p; + scm_t_char_set *p; - p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); - memset (p, 0, BYTES_PER_CHARSET); + p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set"); + memset (p, 0, sizeof (scm_t_char_set)); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -98,22 +550,22 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, #define FUNC_NAME s_scm_char_set_eq { int argnum = 1; - long *cs1_data = NULL; + scm_t_char_set *cs1_data = NULL; SCM_VALIDATE_REST_ARGUMENT (char_sets); while (!scm_is_null (char_sets)) { SCM csi = SCM_CAR (char_sets); - long *csi_data; + scm_t_char_set *csi_data; SCM_VALIDATE_SMOB (argnum, csi, charset); argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); + csi_data = SCM_CHARSET_DATA (csi); if (cs1_data == NULL) - cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) - return SCM_BOOL_F; + 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; @@ -128,28 +580,23 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, #define FUNC_NAME s_scm_char_set_leq { int argnum = 1; - long *prev_data = NULL; + scm_t_char_set *prev_data = NULL; SCM_VALIDATE_REST_ARGUMENT (char_sets); while (!scm_is_null (char_sets)) { SCM csi = SCM_CAR (char_sets); - long *csi_data; + scm_t_char_set *csi_data; SCM_VALIDATE_SMOB (argnum, csi, charset); argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); + csi_data = SCM_CHARSET_DATA (csi); if (prev_data) - { - int k; - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - if ((prev_data[k] & csi_data[k]) != prev_data[k]) - return SCM_BOOL_F; - } - } + { + if (!charsets_leq (prev_data, csi_data)) + return SCM_BOOL_F; + } prev_data = csi_data; char_sets = SCM_CDR (char_sets); } @@ -167,9 +614,10 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, { const unsigned long default_bnd = 871; unsigned long bnd; - long * p; + scm_t_char_set *p; unsigned long val = 0; int k; + scm_t_wchar c; SCM_VALIDATE_SMOB (1, cs, charset); @@ -179,14 +627,14 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, { bnd = scm_to_ulong (bound); if (bnd == 0) - bnd = default_bnd; + bnd = default_bnd; } - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) + p = SCM_CHARSET_DATA (cs); + for (k = 0; k < p->len; k++) { - if (p[k] != 0) - val = p[k] + (val << 1); + for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++) + val = c + (val << 1); } return scm_from_ulong (val % bnd); } @@ -194,89 +642,150 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, - (SCM cs), - "Return a cursor into the character set @var{cs}.") + (SCM cs), "Return a cursor into the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_cursor { - int idx; + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; SCM_VALIDATE_SMOB (1, cs, charset); - for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) + cs_data = SCM_CHARSET_DATA (cs); + cur_data = + (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor), + "charset-cursor"); + if (cs_data->len == 0) { - if (SCM_CHARSET_GET (cs, idx)) - break; + cur_data->range = (size_t) (-1); + cur_data->n = 0; } - return SCM_I_MAKINUM (idx); + else + { + cur_data->range = 0; + cur_data->n = cs_data->ranges[0].lo; + } + SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data); } #undef FUNC_NAME SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, - (SCM cs, SCM cursor), - "Return the character at the current cursor position\n" - "@var{cursor} in the character set @var{cs}. It is an error to\n" - "pass a cursor for which @code{end-of-char-set?} returns true.") + (SCM cs, SCM cursor), + "Return the character at the current cursor position\n" + "@var{cursor} in the character set @var{cs}. It is an error to\n" + "pass a cursor for which @code{end-of-char-set?} returns true.") #define FUNC_NAME s_scm_char_set_ref { - size_t ccursor = scm_to_size_t (cursor); + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; + size_t i; + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_SMOB (2, cursor, charset_cursor); - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + cs_data = SCM_CHARSET_DATA (cs); + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + + /* Validate that this cursor is still true. */ + i = cur_data->range; + if (i == (size_t) (-1) + || i >= cs_data->len + || cur_data->n < cs_data->ranges[i].lo + || cur_data->n > cs_data->ranges[i].hi) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - return SCM_MAKE_CHAR (ccursor); + return SCM_MAKE_CHAR (cur_data->n); } #undef FUNC_NAME SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, - (SCM cs, SCM cursor), - "Advance the character set cursor @var{cursor} to the next\n" - "character in the character set @var{cs}. It is an error if the\n" - "cursor given satisfies @code{end-of-char-set?}.") + (SCM cs, SCM cursor), + "Advance the character set cursor @var{cursor} to the next\n" + "character in the character set @var{cs}. It is an error if the\n" + "cursor given satisfies @code{end-of-char-set?}.") #define FUNC_NAME s_scm_char_set_cursor_next { - size_t ccursor = scm_to_size_t (cursor); + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; + size_t i; + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_SMOB (2, cursor, charset_cursor); + + cs_data = SCM_CHARSET_DATA (cs); + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + /* Validate that this cursor is still true. */ + i = cur_data->range; + if (i == (size_t) (-1) + || i >= cs_data->len + || cur_data->n < cs_data->ranges[i].lo + || cur_data->n > cs_data->ranges[i].hi) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) + /* Increment the cursor. */ + if (cur_data->n == cs_data->ranges[i].hi) { - if (SCM_CHARSET_GET (cs, ccursor)) - break; + if (i + 1 < cs_data->len) + { + cur_data->range = i + 1; + cur_data->n = cs_data->ranges[i + 1].lo; + } + else + { + /* This is the end of the road. */ + cur_data->range = (size_t) (-1); + cur_data->n = 0; + } } - return SCM_I_MAKINUM (ccursor); + else + { + cur_data->n = cur_data->n + 1; + } + + return cursor; } #undef FUNC_NAME SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, - (SCM cursor), - "Return @code{#t} if @var{cursor} has reached the end of a\n" - "character set, @code{#f} otherwise.") + (SCM cursor), + "Return @code{#t} if @var{cursor} has reached the end of a\n" + "character set, @code{#f} otherwise.") #define FUNC_NAME s_scm_end_of_char_set_p { - size_t ccursor = scm_to_size_t (cursor); - return scm_from_bool (ccursor >= SCM_CHARSET_SIZE); + scm_t_char_set_cursor *cur_data; + SCM_VALIDATE_SMOB (1, cursor, charset_cursor); + + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + if (cur_data->range == (size_t) (-1)) + return SCM_BOOL_T; + + return SCM_BOOL_F; } #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}.") + (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 { + scm_t_char_set *cs_data; int k; + scm_t_wchar n; SCM_VALIDATE_PROC (1, kons); SCM_VALIDATE_SMOB (3, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return knil; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); + knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil); } return knil; } @@ -366,19 +875,29 @@ SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, 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.") + (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 { + scm_t_char_set *cs_data; int k; + scm_t_wchar n; SCM_VALIDATE_PROC (1, proc); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - scm_call_1 (proc, SCM_MAKE_CHAR (k)); + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return SCM_UNSPECIFIED; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) + { + scm_call_1 (proc, SCM_MAKE_CHAR (n)); + } + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -392,18 +911,26 @@ SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, { SCM result; int k; + scm_t_char_set *cs_data; + scm_t_wchar n; SCM_VALIDATE_PROC (1, proc); SCM_VALIDATE_SMOB (2, cs, charset); result = make_char_set (FUNC_NAME); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return result; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - SCM_CHARSET_SET (result, SCM_CHAR (ch)); + 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)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); } return result; } @@ -417,15 +944,23 @@ SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, #define FUNC_NAME s_scm_char_set_copy { SCM ret; - long * p1, * p2; - int k; + scm_t_char_set *p1, *p2; SCM_VALIDATE_SMOB (1, cs, charset); ret = make_char_set (FUNC_NAME); - p1 = (long *) SCM_SMOB_DATA (cs); - p2 = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p2[k] = p1[k]; + p1 = SCM_CHARSET_DATA (cs); + p2 = SCM_CHARSET_DATA (ret); + p2->len = p1->len; + + if (p1->len == 0) + p2->ranges = NULL; + else + { + p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len, + "character-set"); + memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len); + } + return ret; } #undef FUNC_NAME @@ -437,20 +972,18 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, #define FUNC_NAME s_scm_char_set { SCM cs; - long * p; int argnum = 1; SCM_VALIDATE_REST_ARGUMENT (rest); cs = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); argnum++; rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -465,7 +998,6 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, #define FUNC_NAME s_scm_list_to_char_set { SCM cs; - long * p; SCM_VALIDATE_LIST (1, list); if (SCM_UNBNDP (base_cs)) @@ -475,16 +1007,16 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, SCM_VALIDATE_SMOB (2, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (list)) { SCM chr = SCM_CAR (list); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + + SCM_CHARSET_SET (cs, c); } return cs; } @@ -492,26 +1024,23 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, 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.") + (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 { - long * p; - SCM_VALIDATE_LIST (1, list); SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); while (!scm_is_null (list)) { SCM chr = SCM_CAR (list); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (base_cs, c); } return base_cs; } @@ -526,8 +1055,6 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, #define FUNC_NAME s_scm_string_to_char_set { SCM cs; - long * p; - const char * s; size_t k = 0, len; SCM_VALIDATE_STRING (1, str); @@ -538,13 +1065,11 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, SCM_VALIDATE_SMOB (2, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); - s = scm_i_string_chars (str); len = scm_i_string_length (str); while (k < len) { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + scm_t_wchar c = scm_i_string_ref (str, k++); + SCM_CHARSET_SET (cs, c); } scm_remember_upto_here_1 (str); return cs; @@ -553,25 +1078,21 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, 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.") + (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 { - long * p; - const char * s; size_t k = 0, len; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - s = scm_i_string_chars (str); len = scm_i_string_length (str); while (k < len) { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + scm_t_wchar c = scm_i_string_ref (str, k++); + SCM_CHARSET_SET (base_cs, c); } scm_remember_upto_here_1 (str); return base_cs; @@ -588,7 +1109,8 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, { SCM ret; int k; - long * p; + scm_t_wchar n; + scm_t_char_set *p; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); @@ -599,17 +1121,20 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, } else ret = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } + p = SCM_CHARSET_DATA (cs); + + if (p->len == 0) + return ret; + + for (k = 0; k < p->len; k++) + for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + + if (scm_is_true (res)) + SCM_CHARSET_SET (ret, n); + } return ret; } #undef FUNC_NAME @@ -623,22 +1148,24 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, #define FUNC_NAME s_scm_char_set_filter_x { int k; - long * p; + scm_t_wchar n; + scm_t_char_set *p; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); SCM_VALIDATE_SMOB (3, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + p = SCM_CHARSET_DATA (cs); + if (p->len == 0) + return base_cs; - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } + for (k = 0; k < p->len; k++) + for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + + if (scm_is_true (res)) + SCM_CHARSET_SET (base_cs, n); + } return base_cs; } #undef FUNC_NAME @@ -662,7 +1189,6 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, { SCM cs; size_t clower, cupper; - long * p; clower = scm_to_size_t (lower); cupper = scm_to_size_t (upper); @@ -670,15 +1196,15 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, if (!SCM_UNBNDP (error)) { if (scm_is_true (error)) - { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); - } + { + SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower)); + SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper)); + } } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; + if (clower > 0x10FFFF) + clower = 0x10FFFF; + if (cupper > 0x10FFFF) + cupper = 0x10FFFF; if (SCM_UNBNDP (base_cs)) cs = make_char_set (FUNC_NAME); else @@ -686,10 +1212,11 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, SCM_VALIDATE_SMOB (4, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); + /* It not be difficult to write a more optimized version of the + following. */ while (clower < cupper) { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, clower); clower++; } return cs; @@ -714,24 +1241,24 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, #define FUNC_NAME s_scm_ucs_range_to_char_set_x { size_t clower, cupper; - long * p; clower = scm_to_size_t (lower); cupper = scm_to_size_t (upper); SCM_ASSERT_RANGE (2, upper, cupper >= clower); if (scm_is_true (error)) { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower)); + SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper)); } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; - p = (long *) SCM_SMOB_DATA (base_cs); + if (clower > SCM_CODEPOINT_MAX) + clower = SCM_CODEPOINT_MAX; + if (cupper > SCM_CODEPOINT_MAX) + cupper = SCM_CODEPOINT_MAX; + while (clower < cupper) { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + if (SCM_IS_UNICODE_CHAR (clower)) + SCM_CHARSET_SET (base_cs, clower); clower++; } return base_cs; @@ -760,12 +1287,18 @@ SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, #define FUNC_NAME s_scm_char_set_size { int k, count = 0; + scm_t_char_set *cs_data; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - return SCM_I_MAKINUM (count); + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return scm_from_int (0); + + for (k = 0; k < cs_data->len; k++) + count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1; + + return scm_from_int (count); } #undef FUNC_NAME @@ -777,16 +1310,21 @@ SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, #define FUNC_NAME s_scm_char_set_count { int k, count = 0; + scm_t_wchar n; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return scm_from_int (0); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - count++; + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_true (res)) + count++; } return SCM_I_MAKINUM (count); } @@ -800,12 +1338,18 @@ SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, #define FUNC_NAME s_scm_char_set_to_list { int k; + scm_t_wchar n; SCM result = SCM_EOL; + scm_t_char_set *p; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = SCM_CHARSET_SIZE; k > 0; k--) - if (SCM_CHARSET_GET (cs, k - 1)) - result = scm_cons (SCM_MAKE_CHAR (k - 1), result); + p = SCM_CHARSET_DATA (cs); + if (p->len == 0) + return SCM_EOL; + + for (k = p->len - 1; k >= 0; k--) + for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--) + result = scm_cons (SCM_MAKE_CHAR (n), result); return result; } #undef FUNC_NAME @@ -821,17 +1365,35 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, int k; int count = 0; int idx = 0; + int wide = 0; SCM result; - char * p; + scm_t_wchar n; + scm_t_char_set *cs_data; + char *buf; + scm_t_wchar *wbuf; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - result = scm_i_make_string (count, &p); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - p[idx++] = k; + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return scm_nullstr; + + if (cs_data->ranges[cs_data->len - 1].hi > 255) + wide = 1; + + count = scm_to_int (scm_char_set_size (cs)); + if (wide) + result = scm_i_make_wide_string (count, &wbuf); + else + result = scm_i_make_string (count, &buf); + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) + { + if (wide) + wbuf[idx++] = n; + else + buf[idx++] = n; + } return result; } #undef FUNC_NAME @@ -857,19 +1419,25 @@ SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, #define FUNC_NAME s_scm_char_set_every { int k; + scm_t_wchar n; SCM res = SCM_BOOL_T; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return SCM_BOOL_T; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_false (res)) - return res; + res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_false (res)) + return res; } - return res; + return SCM_BOOL_T; } #undef FUNC_NAME @@ -881,16 +1449,20 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, #define FUNC_NAME s_scm_char_set_any { int k; + scm_t_wchar n; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = (scm_t_char_set *) cs; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - return res; + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_true (res)) + return res; } return SCM_BOOL_F; } @@ -898,27 +1470,24 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, 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.") + (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 { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); cs = scm_char_set_copy (cs); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -926,27 +1495,24 @@ SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, 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.") + (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 { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); cs = scm_char_set_copy (cs); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + SCM_CHARSET_UNSET (cs, c); } return cs; } @@ -954,26 +1520,23 @@ SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, 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.") + (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 { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -981,26 +1544,23 @@ SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, 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.") + (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 { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + SCM_CHARSET_UNSET (cs, c); } return cs; } @@ -1008,21 +1568,19 @@ SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") + (SCM cs), "Return the complement of the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_complement { - int k; SCM res; - long * p, * q; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs, charset); res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); - q = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~q[k]; + p = SCM_CHARSET_DATA (res); + q = SCM_CHARSET_DATA (cs); + + charsets_complement (p, q); return res; } #undef FUNC_NAME @@ -1035,22 +1593,21 @@ SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, { int c = 1; SCM res; - long * p; + scm_t_char_set *p; SCM_VALIDATE_REST_ARGUMENT (rest); res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); SCM_VALIDATE_SMOB (c, cs, charset); c++; rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + + charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs)); } return res; } @@ -1070,26 +1627,24 @@ SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, res = make_char_set (FUNC_NAME); else { - long *p; + scm_t_char_set *p; int argnum = 2; res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); rest = SCM_CDR (rest); while (scm_is_pair (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - long *cs_data; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= cs_data[k]; - } + { + SCM cs = SCM_CAR (rest); + scm_t_char_set *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = SCM_CHARSET_DATA (cs); + rest = SCM_CDR (rest); + charsets_intersection (p, cs_data); + } } return res; @@ -1103,24 +1658,25 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, #define FUNC_NAME s_scm_char_set_difference { int c = 2; - SCM res; - long * p; + SCM res, compl; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); res = scm_char_set_copy (cs1); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); + compl = make_char_set (FUNC_NAME); + q = SCM_CHARSET_DATA (compl); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); SCM_VALIDATE_SMOB (c, cs, charset); c++; rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + charsets_complement (q, SCM_CHARSET_DATA (cs)); + charsets_intersection (p, q); } return res; } @@ -1141,26 +1697,24 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, else { int argnum = 2; - long * p; + scm_t_char_set *p; res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); rest = SCM_CDR (rest); while (scm_is_pair (rest)) - { - SCM cs = SCM_CAR (rest); - long *cs_data; - int k; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= cs_data[k]; - } + { + SCM cs = SCM_CAR (rest); + scm_t_char_set *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = SCM_CHARSET_DATA (cs); + rest = SCM_CDR (rest); + + charsets_xor (p, cs_data); + } } return res; } @@ -1175,30 +1729,26 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 { int c = 2; SCM res1, res2; - long * p, * q; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); res1 = scm_char_set_copy (cs1); res2 = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res1); - q = (long *) SCM_SMOB_DATA (res2); + p = SCM_CHARSET_DATA (res1); + q = SCM_CHARSET_DATA (res2); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); - long *r; + scm_t_char_set *r; SCM_VALIDATE_SMOB (c, cs, charset); c++; - r = (long *) SCM_SMOB_DATA (cs); + r = SCM_CHARSET_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } + charsets_union (q, r); + charsets_intersection (p, r); rest = SCM_CDR (rest); } return scm_values (scm_list_2 (res1, res2)); @@ -1207,101 +1757,53 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") + (SCM cs), "Return the complement of the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_complement_x { - int k; - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~p[k]; + 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.") + (SCM cs1, SCM rest), + "Return the union of all argument character sets.") #define FUNC_NAME s_scm_char_set_union_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; - } + 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.") + (SCM cs1, SCM rest), + "Return the intersection of all argument character sets.") #define FUNC_NAME s_scm_char_set_intersection_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; - } + 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.") + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") #define FUNC_NAME s_scm_char_set_difference_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - } + cs1 = scm_char_set_difference (cs1, rest); return cs1; } #undef FUNC_NAME @@ -1316,86 +1818,32 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, (define a (char-set #\a)) (char-set-xor a a a) -> char set #\a (char-set-xor! a a a) -> char set #\a - */ + */ return scm_char_set_xor (scm_cons (cs1, rest)); - -#if 0 - /* this would give (char-set-xor! a a a) -> empty char set. */ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -#endif } #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.") +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 { - int c = 3; - long * p, * q; - int k; + SCM diff, intersect; - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_SMOB (2, cs2, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - q = (long *) SCM_SMOB_DATA (cs2); - if (p == q) - { - /* (char-set-diff+intersection! a a ...): can't share storage, - but we know the answer without checking for further - arguments. */ - return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); - } - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - long t = p[k]; - - p[k] &= ~q[k]; - q[k] = t & q[k]; - } - while (!scm_is_null (rest)) - { - SCM cs = SCM_CAR (rest); - long *r; - - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - r = (long *) SCM_SMOB_DATA (cs); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } - rest = SCM_CDR (rest); - } + 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 (scm_list_2 (cs1, cs2)); } #undef FUNC_NAME + /* Standard character sets. */ SCM scm_char_set_lower_case; @@ -1419,146 +1867,77 @@ SCM scm_char_set_full; /* Create an empty character set and return it after binding it to NAME. */ static inline SCM -define_charset (const char *name) +define_charset (const char *name, const scm_t_char_set *p) { - SCM cs = make_char_set (NULL); + SCM cs; + + SCM_NEWSMOB (cs, scm_tc16_charset, p); scm_c_define (name, cs); return scm_permanent_object (cs); } -/* Membership predicates for the various char sets. - - XXX: The `punctuation' and `symbol' char sets have no direct equivalent in - <ctype.h>. Thus, the predicates below yield correct results for ASCII, - but they do not provide the result described by the SRFI for Latin-1. The - correct Latin-1 result could only be obtained by hard-coding the - characters listed by the SRFI, but the problem would remain for other - 8-bit charsets. - - Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should - be part of `char-set:blank'. However, glibc's current (2006/09) Latin-1 - locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it - `blank' so it ends up in `char-set:punctuation'. */ -#ifdef HAVE_ISBLANK -# define CSET_BLANK_PRED(c) (isblank (c)) -#else -# define CSET_BLANK_PRED(c) \ - (((c) == ' ') || ((c) == '\t')) -#endif - -#define CSET_SYMBOL_PRED(c) \ - (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL)) -#define CSET_PUNCT_PRED(c) \ - ((ispunct (c)) && (!CSET_SYMBOL_PRED (c))) - -#define CSET_LOWER_PRED(c) (islower (c)) -#define CSET_UPPER_PRED(c) (isupper (c)) -#define CSET_LETTER_PRED(c) (isalpha (c)) -#define CSET_DIGIT_PRED(c) (isdigit (c)) -#define CSET_WHITESPACE_PRED(c) (isspace (c)) -#define CSET_CONTROL_PRED(c) (iscntrl (c)) -#define CSET_HEX_DIGIT_PRED(c) (isxdigit (c)) -#define CSET_ASCII_PRED(c) (isascii (c)) - -/* Some char sets are explicitly defined by the SRFI as a union of other char - sets so we try to follow this closely. */ - -#define CSET_LETTER_AND_DIGIT_PRED(c) \ - (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c)) - -#define CSET_GRAPHIC_PRED(c) \ - (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c) \ - || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c)) - -#define CSET_PRINTING_PRED(c) \ - (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c)) - -/* False and true predicates. */ -#define CSET_TRUE_PRED(c) (1) -#define CSET_FALSE_PRED(c) (0) - - -/* Compute the contents of all the standard character sets. Computation may - need to be re-done at `setlocale'-time because some char sets (e.g., - `char-set:letter') need to reflect the character set supported by Guile. - - For instance, at startup time, the "C" locale is used, thus Guile supports - only ASCII; therefore, `char-set:letter' only contains English letters. - The user can change this by invoking `setlocale' and specifying a locale - with an 8-bit charset, thereby augmenting some of the SRFI-14 standard - character sets. - - This works because some of the predicates used below to construct - character sets (e.g., `isalpha(3)') are locale-dependent (so - charset-dependent, though generally not language-dependent). For details, - please see the `guile-devel' mailing list archive of September 2006. */ -void -scm_srfi_14_compute_char_sets (void) +#ifdef SCM_CHARSET_DEBUG +SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0, + (SCM charset), + "Print out the internal C structure of @var{charset}.\n") +#define FUNC_NAME s_scm_debug_char_set { -#define UPDATE_CSET(c, cset, pred) \ - do \ - { \ - if (pred (c)) \ - SCM_CHARSET_SET ((cset), (c)); \ - else \ - SCM_CHARSET_UNSET ((cset), (c)); \ - } \ - while (0) - - register int ch; - - for (ch = 0; ch < 256; ch++) + int i; + scm_t_char_set *cs = SCM_CHARSET_DATA (charset); + fprintf (stderr, "cs %p\n", cs); + fprintf (stderr, "len %d\n", cs->len); + fprintf (stderr, "arr %p\n", cs->ranges); + for (i = 0; i < cs->len; i++) { - UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED); - UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED); - UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED); - UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED); - UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_letter_and_digit, - CSET_LETTER_AND_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED); - UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED); - UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED); - UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED); - UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED); - UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED); - UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED); - UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED); - UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED); - UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED); + if (cs->ranges[i].lo == cs->ranges[i].hi) + fprintf (stderr, "%04x\n", cs->ranges[i].lo); + else + fprintf (stderr, "%04x..%04x\t[%d]\n", + cs->ranges[i].lo, + cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1); } - -#undef UPDATE_CSET + printf ("\n"); + return SCM_UNSPECIFIED; } - +#undef FUNC_NAME +#endif /* SCM_CHARSET_DEBUG */ + + void scm_init_srfi_14 (void) { - scm_tc16_charset = scm_make_smob_type ("character-set", - BYTES_PER_CHARSET); + scm_tc16_charset = scm_make_smob_type ("character-set", 0); scm_set_smob_print (scm_tc16_charset, charset_print); - scm_char_set_upper_case = define_charset ("char-set:upper-case"); - scm_char_set_lower_case = define_charset ("char-set:lower-case"); - scm_char_set_title_case = define_charset ("char-set:title-case"); - scm_char_set_letter = define_charset ("char-set:letter"); - scm_char_set_digit = define_charset ("char-set:digit"); - scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit"); - scm_char_set_graphic = define_charset ("char-set:graphic"); - scm_char_set_printing = define_charset ("char-set:printing"); - scm_char_set_whitespace = define_charset ("char-set:whitespace"); - scm_char_set_iso_control = define_charset ("char-set:iso-control"); - scm_char_set_punctuation = define_charset ("char-set:punctuation"); - scm_char_set_symbol = define_charset ("char-set:symbol"); - scm_char_set_hex_digit = define_charset ("char-set:hex-digit"); - scm_char_set_blank = define_charset ("char-set:blank"); - scm_char_set_ascii = define_charset ("char-set:ascii"); - scm_char_set_empty = define_charset ("char-set:empty"); - scm_char_set_full = define_charset ("char-set:full"); - - scm_srfi_14_compute_char_sets (); + scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0); + scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print); + + scm_char_set_upper_case = + define_charset ("char-set:upper-case", &cs_upper_case); + scm_char_set_lower_case = + define_charset ("char-set:lower-case", &cs_lower_case); + scm_char_set_title_case = + define_charset ("char-set:title-case", &cs_title_case); + scm_char_set_letter = define_charset ("char-set:letter", &cs_letter); + scm_char_set_digit = define_charset ("char-set:digit", &cs_digit); + scm_char_set_letter_and_digit = + define_charset ("char-set:letter+digit", &cs_letter_plus_digit); + scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic); + scm_char_set_printing = define_charset ("char-set:printing", &cs_printing); + scm_char_set_whitespace = + define_charset ("char-set:whitespace", &cs_whitespace); + scm_char_set_iso_control = + define_charset ("char-set:iso-control", &cs_iso_control); + scm_char_set_punctuation = + define_charset ("char-set:punctuation", &cs_punctuation); + scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol); + scm_char_set_hex_digit = + define_charset ("char-set:hex-digit", &cs_hex_digit); + scm_char_set_blank = define_charset ("char-set:blank", &cs_blank); + scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii); + scm_char_set_empty = define_charset ("char-set:empty", &cs_empty); + scm_char_set_full = define_charset ("char-set:full", &cs_full); #include "libguile/srfi-14.x" } |