X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/719bb8cd5db10aeb0dad1c16227d6b6abc40e8b6..8cb0d6d7fa9aaac316c29a64c541336b51b6f93d:/libguile/srfi-14.c diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 822673b92..af7c1d95b 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -1,6 +1,6 @@ /* srfi-14.c --- SRFI-14 procedures for Guile * - * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2007, 2009, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -621,32 +621,6 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } - -/* Smob free hook for character sets. */ -static size_t -charset_free (SCM charset) -{ - scm_t_char_set *cs; - size_t len = 0; - - cs = SCM_CHARSET_DATA (charset); - if (cs != NULL) - len = cs->len; - if (len > 0) - scm_gc_free (cs->ranges, sizeof (scm_t_char_range) * len, - "character-set"); - - cs->ranges = NULL; - cs->len = 0; - - scm_gc_free (cs, sizeof (scm_t_char_set), "character-set"); - - scm_remember_upto_here_1 (charset); - - return 0; -} - - /* Smob print hook for character sets cursors. */ static int charset_cursor_print (SCM cursor, SCM port, @@ -669,19 +643,6 @@ charset_cursor_print (SCM cursor, SCM port, return 1; } -/* Smob free hook for character sets. */ -static size_t -charset_cursor_free (SCM charset) -{ - scm_t_char_set_cursor *cur; - - cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (charset); - scm_gc_free (cur, sizeof (scm_t_char_set_cursor), "charset-cursor"); - scm_remember_upto_here_1 (charset); - - return 0; -} - /* Create a new, empty character set. */ static SCM @@ -737,8 +698,8 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, (SCM char_sets), - "Return @code{#t} if every character set @var{cs}i is a subset\n" - "of character set @var{cs}i+1.") + "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; @@ -771,7 +732,7 @@ 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}.") + "returned value to the range 0 @dots{} @var{bound} - 1.") #define FUNC_NAME s_scm_char_set_hash { const unsigned long default_bnd = 871; @@ -1364,7 +1325,7 @@ scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper, cs = make_char_set (FUNC_NAME); else { - SCM_VALIDATE_SMOB (4, base_cs, charset); + SCM_VALIDATE_SMOB (3, base_cs, charset); if (reuse) cs = base_cs; else @@ -1402,7 +1363,7 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, "If @var{error} is a true value, an error is signalled 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 resultung\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" @@ -1424,7 +1385,7 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, "If @var{error} is a true value, an error is signalled 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 resultung\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" @@ -1554,9 +1515,9 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, count = scm_to_int (scm_char_set_size (cs)); if (wide) - result = scm_i_make_wide_string (count, &wbuf); + result = scm_i_make_wide_string (count, &wbuf, 0); else - result = scm_i_make_string (count, &buf); + result = scm_i_make_string (count, &buf, 0); for (k = 0; k < cs_data->len; k++) for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) @@ -2049,34 +2010,62 @@ define_charset (const char *name, const scm_t_char_set *p) SCM_NEWSMOB (cs, scm_tc16_charset, p); scm_c_define (name, cs); - return scm_permanent_object (cs); + return cs; } -#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 -{ - 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); +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; + scm_t_char_set *cs; + char codepoint_string_lo[9], codepoint_string_hi[9]; + + SCM_VALIDATE_SMOB (1, charset, charset); + cs = SCM_CHARSET_DATA (charset); + + e1 = scm_cons (scm_from_latin1_symbol ("char-set"), + charset); + e2 = scm_cons (scm_from_latin1_symbol ("n"), + scm_from_size_t (cs->len)); + for (i = 0; i < cs->len; i++) { - if (cs->ranges[i].lo == cs->ranges[i].hi) - fprintf (stderr, "%04x\n", cs->ranges[i].lo); + if (cs->ranges[i].lo > 0xFFFF) + sprintf (codepoint_string_lo, "U+%06x", 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); + sprintf (codepoint_string_lo, "U+%04x", cs->ranges[i].lo); + if (cs->ranges[i].hi > 0xFFFF) + sprintf (codepoint_string_hi, "U+%06x", cs->ranges[i].hi); + else + sprintf (codepoint_string_hi, "U+%04x", cs->ranges[i].hi); + + elt = scm_list_4 (SCM_MAKE_CHAR (cs->ranges[i].lo), + SCM_MAKE_CHAR (cs->ranges[i].hi), + 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))); } - printf ("\n"); - return SCM_UNSPECIFIED; + e3 = scm_cons (scm_from_latin1_symbol ("ranges"), + ranges); + + return scm_list_3 (e1, e2, e3); } #undef FUNC_NAME -#endif /* SCM_CHARSET_DEBUG */ + @@ -2084,11 +2073,9 @@ void scm_init_srfi_14 (void) { scm_tc16_charset = scm_make_smob_type ("character-set", 0); - scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0); - scm_set_smob_free (scm_tc16_charset_cursor, charset_cursor_free); scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print); scm_char_set_upper_case =