diff options
Diffstat (limited to 'libguile/strings.c')
-rw-r--r-- | libguile/strings.c | 2470 |
1 files changed, 2470 insertions, 0 deletions
diff --git a/libguile/strings.c b/libguile/strings.c new file mode 100644 index 000000000..a0a1555f5 --- /dev/null +++ b/libguile/strings.c @@ -0,0 +1,2470 @@ +/* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2016,2018 + 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 <alloca.h> +#include <string.h> +#include <stdio.h> +#include <ctype.h> +#include <errno.h> +#include <uninorm.h> +#include <unistr.h> +#include <uniconv.h> +#include <c-strcase.h> + +#include "chars.h" +#include "deprecation.h" +#include "error.h" +#include "generalized-vectors.h" +#include "gsubr.h" +#include "numbers.h" +#include "pairs.h" +#include "ports-internal.h" +#include "ports.h" +#include "private-options.h" +#include "striconveh.h" +#include "symbols.h" +#include "threads.h" + +#include "strings.h" + + + + +/* {Strings} + */ + +SCM_SYMBOL (sym_UTF_8, "UTF-8"); +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); +SCM_SYMBOL (sym_error, "error"); + +/* A stringbuf is a linear buffer of characters. Every string has a + stringbuf. Strings may reference just a slice of a stringbuf; that's + often the case for strings made by the "substring" function. + + Stringbufs may hold either 8-bit characters or 32-bit characters. In + either case the characters are Unicode codepoints. "Narrow" + stringbufs thus have the ISO-8859-1 (Latin-1) encoding, and "wide" + stringbufs have the UTF-32 (UCS-4) encoding. + + By default, stringbufs are immutable. This enables an O(1) + "substring" operation with no synchronization. A string-set! will + first ensure that the string's stringbuf is mutable, copying the + stringbuf if necessary. This is therefore a copy-on-write + representation. However, taking a substring of a mutable stringbuf + is an O(n) operation as it has to create a new immutable stringbuf. + There are also mutation-sharing substrings as well. */ + +/* The size in words of the stringbuf header (type tag + size). */ +#define STRINGBUF_HEADER_SIZE 2U + +#define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM)) + +#define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE +#define STRINGBUF_F_MUTABLE SCM_I_STRINGBUF_F_MUTABLE + +#define STRINGBUF_TAG scm_tc7_stringbuf +#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE) +#define STRINGBUF_MUTABLE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_MUTABLE) + + +#define STRINGBUF_SET_MUTABLE(buf) \ + SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_MUTABLE) + +#define STRINGBUF_CONTENTS(buf) ((void *) \ + SCM_CELL_OBJECT_LOC (buf, \ + STRINGBUF_HEADER_SIZE)) +#define STRINGBUF_CHARS(buf) ((unsigned char *) STRINGBUF_CONTENTS (buf)) +#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CONTENTS (buf)) + +#define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf)) + +#ifdef SCM_STRING_LENGTH_HISTOGRAM +static size_t lenhist[1001]; +#endif + +/* Make a stringbuf with space for LEN 8-bit Latin-1-encoded + characters. */ +static SCM +make_stringbuf (size_t len) +{ + /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and + scm_i_symbol_chars, all stringbufs are null-terminated. Once + SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code + has been changed for scm_i_symbol_chars, this null-termination + can be dropped. + */ + + SCM buf; + +#ifdef SCM_STRING_LENGTH_HISTOGRAM + if (len < 1000) + lenhist[len]++; + else + lenhist[1000]++; +#endif + + buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1, + "string")); + + SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG); + SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len); + + STRINGBUF_CHARS (buf)[len] = 0; + + return buf; +} + +/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded + characters. */ +static SCM +make_wide_stringbuf (size_t len) +{ + SCM buf; + size_t raw_len; + +#ifdef SCM_STRING_LENGTH_HISTOGRAM + if (len < 1000) + lenhist[len]++; + else + lenhist[1000]++; +#endif + + raw_len = (len + 1) * sizeof (scm_t_wchar); + buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len, + "string")); + + SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE); + SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len); + + STRINGBUF_WIDE_CHARS (buf)[len] = 0; + + return buf; +} + +/* Return a UCS-4-encoded stringbuf containing the (possibly Latin-1-encoded) + characters from BUF. */ +static SCM +wide_stringbuf (SCM buf) +{ + SCM new_buf; + + if (STRINGBUF_WIDE (buf)) + new_buf = buf; + else + { + size_t i, len; + scm_t_wchar *mem; + + len = STRINGBUF_LENGTH (buf); + + new_buf = make_wide_stringbuf (len); + + mem = STRINGBUF_WIDE_CHARS (new_buf); + for (i = 0; i < len; i++) + mem[i] = (scm_t_wchar) STRINGBUF_CHARS (buf)[i]; + mem[len] = 0; + } + + return new_buf; +} + +/* Return a Latin-1-encoded stringbuf containing the (possibly UCS-4-encoded) + characters from BUF, if possible. */ +static SCM +narrow_stringbuf (SCM buf) +{ + SCM new_buf; + + if (!STRINGBUF_WIDE (buf)) + new_buf = buf; + else + { + size_t i, len; + scm_t_wchar *wmem; + unsigned char *mem; + + len = STRINGBUF_LENGTH (buf); + wmem = STRINGBUF_WIDE_CHARS (buf); + + for (i = 0; i < len; i++) + if (wmem[i] > 0xFF) + /* BUF cannot be narrowed. */ + return buf; + + new_buf = make_stringbuf (len); + + mem = STRINGBUF_CHARS (new_buf); + for (i = 0; i < len; i++) + mem[i] = (unsigned char) wmem[i]; + mem[len] = 0; + } + + return new_buf; +} + + +/* Copy-on-write strings. + */ + +#define STRING_TAG scm_tc7_string + +#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str)) +#define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str)) +#define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str)) + +#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf)) +#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start)) + +#define IS_STRING(str) (SCM_HAS_TYP7 (str, STRING_TAG)) + +/* Read-only strings. + */ + +#define RO_STRING_TAG scm_tc7_ro_string +#define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG) + +/* Mutation-sharing substrings + */ + +#define SH_STRING_TAG (scm_tc7_string + 0x100) + +#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh)) +/* START and LENGTH as for STRINGs. */ + +#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG) + +void +scm_i_print_stringbuf (SCM exp, SCM port, scm_print_state *pstate) +{ + SCM str = scm_double_cell (STRING_TAG, SCM_UNPACK(exp), 0, + STRINGBUF_LENGTH (exp)); + scm_puts ("#<stringbuf ", port); + scm_iprin1 (str, port, pstate); + scm_puts (">", port); +} + +SCM scm_nullstr; + +static SCM null_stringbuf; + +static void +init_null_stringbuf (void) +{ + null_stringbuf = make_stringbuf (0); +} + +/* Create a scheme string with space for LEN 8-bit Latin-1-encoded + characters. CHARSP, if not NULL, will be set to location of the + char array. If READ_ONLY_P, the returned string is read-only; + otherwise it is writable. */ +SCM +scm_i_make_string (size_t len, char **charsp, int read_only_p) +{ + SCM buf; + SCM res; + + if (len == 0) + { + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_null_stringbuf); + buf = null_stringbuf; + } + else + buf = make_stringbuf (len); + + if (charsp) + *charsp = (char *) STRINGBUF_CHARS (buf); + res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG, + SCM_UNPACK (buf), + (scm_t_bits) 0, (scm_t_bits) len); + return res; +} + +/* Create a scheme string with space for LEN 32-bit UCS-4-encoded + characters. CHARSP, if not NULL, will be set to location of the + character array. If READ_ONLY_P, the returned string is read-only; + otherwise it is writable. */ +SCM +scm_i_make_wide_string (size_t len, scm_t_wchar **charsp, int read_only_p) +{ + SCM buf = make_wide_stringbuf (len); + SCM res; + if (charsp) + *charsp = STRINGBUF_WIDE_CHARS (buf); + res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG, + SCM_UNPACK (buf), + (scm_t_bits) 0, (scm_t_bits) len); + return res; +} + +static void +validate_substring_args (SCM str, size_t start, size_t end) +{ + if (!IS_STRING (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + if (start > STRING_LENGTH (str)) + scm_out_of_range (NULL, scm_from_size_t (start)); + if (end > STRING_LENGTH (str) || end < start) + scm_out_of_range (NULL, scm_from_size_t (end)); +} + +static inline void +get_str_buf_start (SCM *str, SCM *buf, size_t *start) +{ + *start = STRING_START (*str); + if (IS_SH_STRING (*str)) + { + *str = SH_STRING_STRING (*str); + *start += STRING_START (*str); + } + *buf = STRING_STRINGBUF (*str); +} + +static SCM +substring_with_immutable_stringbuf (SCM str, size_t start, size_t end, + int force_copy_p, int read_only_p) +{ + SCM buf; + size_t str_start, len; + scm_t_bits tag = read_only_p ? RO_STRING_TAG : STRING_TAG; + + get_str_buf_start (&str, &buf, &str_start); + len = end - start; + start += str_start; + + if (len == 0) + return scm_i_make_string (0, NULL, read_only_p); + else if (!force_copy_p && SCM_LIKELY (!STRINGBUF_MUTABLE (buf))) + return scm_double_cell (tag, SCM_UNPACK (buf), start, len); + else + { + SCM new_buf, new_str; + + if (STRINGBUF_WIDE (buf)) + { + new_buf = make_wide_stringbuf (len); + u32_cpy ((uint32_t *) STRINGBUF_WIDE_CHARS (new_buf), + (uint32_t *) (STRINGBUF_WIDE_CHARS (buf) + start), len); + new_str = scm_double_cell (tag, SCM_UNPACK (new_buf), 0, len); + scm_i_try_narrow_string (new_str); + } + else + { + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + start, len); + new_str = scm_double_cell (tag, SCM_UNPACK (new_buf), 0, len); + } + + return new_str; + } +} + +SCM +scm_i_substring (SCM str, size_t start, size_t end) +{ + return substring_with_immutable_stringbuf (str, start, end, 0, 0); +} + +SCM +scm_i_substring_read_only (SCM str, size_t start, size_t end) +{ + return substring_with_immutable_stringbuf (str, start, end, 0, 1); +} + +SCM +scm_i_substring_copy (SCM str, size_t start, size_t end) +{ + return substring_with_immutable_stringbuf (str, start, end, 1, 0); +} + +static void +scm_i_string_ensure_mutable_x (SCM str) +{ + SCM buf; + + if (IS_SH_STRING (str)) + { + /* Shared-mutation strings always have mutable stringbufs. */ + buf = STRING_STRINGBUF (SH_STRING_STRING (str)); + if (!STRINGBUF_MUTABLE (buf)) + abort (); + return; + } + + if (IS_RO_STRING (str)) + scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (str)); + + buf = STRING_STRINGBUF (str); + + if (STRINGBUF_MUTABLE (buf)) + return; + + /* Otherwise copy and mark the fresh stringbuf as mutable. Note that + we copy the whole stringbuf so that the start/len offsets from the + original string keep working, so that concurrent accessors on this + string don't see things in an inconsistent state. */ + { + SCM new_buf; + size_t len = STRINGBUF_LENGTH (buf); + + if (STRINGBUF_WIDE (buf)) + { + new_buf = make_wide_stringbuf (len); + u32_cpy ((uint32_t *) STRINGBUF_WIDE_CHARS (new_buf), + (uint32_t *) STRINGBUF_WIDE_CHARS (buf), len); + } + else + { + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), STRINGBUF_CHARS (buf), len); + } + + STRINGBUF_SET_MUTABLE (new_buf); + SET_STRING_STRINGBUF (str, new_buf); + } +} + +SCM +scm_i_substring_shared (SCM str, size_t start, size_t end) +{ + if (start == 0 && end == STRING_LENGTH (str)) + return str; + else if (start == end) + return scm_i_make_string (0, NULL, 0); + else if (IS_RO_STRING (str)) + return scm_i_substring_read_only (str, start, end); + else + { + size_t len = end - start; + if (IS_SH_STRING (str)) + { + start += STRING_START (str); + str = SH_STRING_STRING (str); + } + + scm_i_string_ensure_mutable_x (str); + + return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str), + (scm_t_bits)start, (scm_t_bits) len); + } +} + +SCM +scm_c_substring (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring (str, start, end); +} + +SCM +scm_c_substring_read_only (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring_read_only (str, start, end); +} + +SCM +scm_c_substring_copy (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring_copy (str, start, end); +} + +SCM +scm_c_substring_shared (SCM str, size_t start, size_t end) +{ + validate_substring_args (str, start, end); + return scm_i_substring_shared (str, start, end); +} + + +/* Internal accessors + */ + +/* Returns the number of characters in STR. This may be different + than the memory size of the string storage. */ +size_t +scm_i_string_length (SCM str) +{ + return STRING_LENGTH (str); +} + +int +scm_i_string_is_mutable (SCM str) +{ + return !IS_RO_STRING (str); +} + +/* True if the string is 'narrow', meaning it has a 8-bit Latin-1 + encoding. False if it is 'wide', having a 32-bit UCS-4 + encoding. */ +int +scm_i_is_narrow_string (SCM str) +{ + if (IS_SH_STRING (str)) + str = SH_STRING_STRING (str); + + return !STRINGBUF_WIDE (STRING_STRINGBUF (str)); +} + +/* Try to coerce a string to be narrow. It if is narrow already, do + nothing. If it is wide, shrink it to narrow if none of its + characters are above 0xFF. Return true if the string is narrow or + was made to be narrow. */ +int +scm_i_try_narrow_string (SCM str) +{ + if (IS_SH_STRING (str)) + str = SH_STRING_STRING (str); + + SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str))); + + return scm_i_is_narrow_string (str); +} + +/* Return a pointer to the raw data of the string, which can be either Latin-1 + or UCS-4 encoded data, depending on `scm_i_is_narrow_string (STR)'. */ +const void * +scm_i_string_data (SCM str) +{ + SCM buf; + size_t start; + const char *data; + + get_str_buf_start (&str, &buf, &start); + + data = STRINGBUF_CONTENTS (buf); + data += start * (scm_i_is_narrow_string (str) ? 1 : 4); + + return data; +} + +/* Returns a pointer to the 8-bit Latin-1 encoded character array of + STR. */ +const char * +scm_i_string_chars (SCM str) +{ + SCM buf; + size_t start; + get_str_buf_start (&str, &buf, &start); + if (scm_i_is_narrow_string (str)) + return (const char *) STRINGBUF_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s", + scm_list_1 (str)); + return NULL; +} + +/* Returns a pointer to the 32-bit UCS-4 encoded character array of + STR. */ +const scm_t_wchar * +scm_i_string_wide_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (!scm_i_is_narrow_string (str)) + return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s", + scm_list_1 (str)); +} + +/* If the buffer in ORIG_STR is immutable, copy ORIG_STR's characters to + a new string buffer, so that it can be modified without modifying + other strings. */ +SCM +scm_i_string_start_writing (SCM orig_str) +{ + scm_i_string_ensure_mutable_x (orig_str); + return orig_str; +} + +/* Return a pointer to the 8-bit Latin-1 chars of a string. */ +char * +scm_i_string_writable_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (scm_i_is_narrow_string (str)) + return (char *) STRINGBUF_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s", + scm_list_1 (str)); + return NULL; +} + +/* Return a pointer to the UCS-4 codepoints of a string. */ +static scm_t_wchar * +scm_i_string_writable_wide_chars (SCM str) +{ + SCM buf; + size_t start; + + get_str_buf_start (&str, &buf, &start); + if (!scm_i_is_narrow_string (str)) + return STRINGBUF_WIDE_CHARS (buf) + start; + else + scm_misc_error (NULL, "Invalid write access of chars of narrow string: ~s", + scm_list_1 (str)); +} + +/* Unlock the string mutex that was locked when + scm_i_string_start_writing was called. */ +void +scm_i_string_stop_writing (void) +{ +} + +/* Return the Xth character of STR as a UCS-4 codepoint. */ +scm_t_wchar +scm_i_string_ref (SCM str, size_t x) +{ + if (scm_i_is_narrow_string (str)) + return (scm_t_wchar) (unsigned char) (scm_i_string_chars (str)[x]); + else + return scm_i_string_wide_chars (str)[x]; +} + +/* Returns index+1 of the first char in STR that matches C, or + 0 if the char is not found. */ +int +scm_i_string_contains_char (SCM str, char ch) +{ + size_t i; + size_t len = scm_i_string_length (str); + + i = 0; + if (scm_i_is_narrow_string (str)) + { + while (i < len) + { + if (scm_i_string_chars (str)[i] == ch) + return i+1; + i++; + } + } + else + { + while (i < len) + { + if (scm_i_string_wide_chars (str)[i] + == (unsigned char) ch) + return i+1; + i++; + } + } + return 0; +} + +int +scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr) +{ + if (scm_i_is_narrow_string (sstr)) + { + const char *a = scm_i_string_chars (sstr) + start_x; + const char *b = cstr; + return strncmp (a, b, strlen(b)); + } + else + { + size_t i; + const scm_t_wchar *a = scm_i_string_wide_chars (sstr) + start_x; + const char *b = cstr; + for (i = 0; i < strlen (b); i++) + { + if (a[i] != (unsigned char) b[i]) + return 1; + } + } + return 0; +} + +/* Set the Pth character of STR to UCS-4 codepoint CHR. */ +void +scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr) +{ + if (IS_SH_STRING (str)) + { + p += STRING_START (str); + str = SH_STRING_STRING (str); + } + + if (chr > 0xFF && scm_i_is_narrow_string (str)) + SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str))); + + if (scm_i_is_narrow_string (str)) + { + char *dst = scm_i_string_writable_chars (str); + dst[p] = chr; + } + else + { + scm_t_wchar *dst = scm_i_string_writable_wide_chars (str); + dst[p] = chr; + } +} + + +/* Symbols. + + Basic symbol creation and accessing is done here, the rest is in + symbols.[hc]. This has been done to keep stringbufs and the + internals of strings and string-like objects confined to this file. +*/ + +#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1 + +SCM +scm_i_make_symbol (SCM name, scm_t_bits flags, + unsigned long hash, SCM props) +{ + SCM buf; + size_t length = STRING_LENGTH (name); + + name = scm_i_substring_copy (name, 0, length); + buf = STRING_STRINGBUF (name); + return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), + (scm_t_bits) hash, SCM_UNPACK (props)); +} + +SCM +scm_i_c_make_symbol (const char *name, size_t len, + scm_t_bits flags, unsigned long hash, SCM props) +{ + SCM buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (buf), name, len); + + return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), + (scm_t_bits) hash, SCM_UNPACK (props)); +} + +/* Returns the number of characters in SYM. This may be different + from the memory size of SYM. */ +size_t +scm_i_symbol_length (SCM sym) +{ + return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym)); +} + +size_t +scm_c_symbol_length (SCM sym) +#define FUNC_NAME "scm_c_symbol_length" +{ + SCM_VALIDATE_SYMBOL (1, sym); + + return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym)); +} +#undef FUNC_NAME + +/* True if the name of SYM is stored as a Latin-1 encoded string. + False if it is stored as a 32-bit UCS-4-encoded string. */ +int +scm_i_is_narrow_symbol (SCM sym) +{ + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + return !STRINGBUF_WIDE (buf); +} + +/* Returns a pointer to the 8-bit Latin-1 encoded character array that + contains the name of SYM. */ +const char * +scm_i_symbol_chars (SCM sym) +{ + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + if (!STRINGBUF_WIDE (buf)) + return (const char *) STRINGBUF_CHARS (buf); + else + scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S", + scm_list_1 (sym)); +} + +/* Return a pointer to the 32-bit UCS-4-encoded character array of a + symbol's name. */ +const scm_t_wchar * +scm_i_symbol_wide_chars (SCM sym) +{ + SCM buf; + + buf = SYMBOL_STRINGBUF (sym); + if (STRINGBUF_WIDE (buf)) + return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf); + else + scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S", + scm_list_1 (sym)); +} + +SCM +scm_i_symbol_substring (SCM sym, size_t start, size_t end) +{ + SCM buf = SYMBOL_STRINGBUF (sym); + return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf), + (scm_t_bits)start, (scm_t_bits) end - start); +} + +/* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */ +scm_t_wchar +scm_i_symbol_ref (SCM sym, size_t x) +{ + if (scm_i_is_narrow_symbol (sym)) + return (scm_t_wchar) (unsigned char) (scm_i_symbol_chars (sym)[x]); + else + return scm_i_symbol_wide_chars (sym)[x]; +} + +/* Debugging + */ + +SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), + "Returns an association list containing debugging information\n" + "for @var{str}. The association list has the following entries." + "@table @code\n" + "@item string\n" + "The string itself.\n" + "@item start\n" + "The start index of the string into its stringbuf\n" + "@item length\n" + "The length of the string\n" + "@item shared\n" + "If this string is a substring, it returns its parent string.\n" + "Otherwise, it returns @code{#f}\n" + "@item read-only\n" + "@code{#t} if the string is read-only\n" + "@item stringbuf-chars\n" + "A new string containing this string's stringbuf's characters\n" + "@item stringbuf-length\n" + "The number of characters in this stringbuf\n" + "@item stringbuf-mutable\n" + "@code{#t} if this stringbuf is mutable\n" + "@item stringbuf-wide\n" + "@code{#t} if this stringbuf's characters are stored in a\n" + "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" + "buffer\n" + "@end table") +#define FUNC_NAME s_scm_sys_string_dump +{ + SCM e1, e2, e3, e4, e5, e6, e7, e8, e9; + SCM buf; + SCM_VALIDATE_STRING (1, str); + + /* String info */ + e1 = scm_cons (scm_from_latin1_symbol ("string"), + str); + e2 = scm_cons (scm_from_latin1_symbol ("start"), + scm_from_size_t (STRING_START (str))); + e3 = scm_cons (scm_from_latin1_symbol ("length"), + scm_from_size_t (STRING_LENGTH (str))); + + if (IS_SH_STRING (str)) + { + e4 = scm_cons (scm_from_latin1_symbol ("shared"), + SH_STRING_STRING (str)); + buf = STRING_STRINGBUF (SH_STRING_STRING (str)); + } + else + { + e4 = scm_cons (scm_from_latin1_symbol ("shared"), + SCM_BOOL_F); + buf = STRING_STRINGBUF (str); + } + + if (IS_RO_STRING (str)) + e5 = scm_cons (scm_from_latin1_symbol ("read-only"), + SCM_BOOL_T); + else + e5 = scm_cons (scm_from_latin1_symbol ("read-only"), + SCM_BOOL_F); + + /* Stringbuf info */ + if (!STRINGBUF_WIDE (buf)) + { + size_t len = STRINGBUF_LENGTH (buf); + char *cbuf; + SCM sbc = scm_i_make_string (len, &cbuf, 0); + memcpy (cbuf, STRINGBUF_CHARS (buf), len); + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), + sbc); + } + else + { + size_t len = STRINGBUF_LENGTH (buf); + scm_t_wchar *cbuf; + SCM sbc = scm_i_make_wide_string (len, &cbuf, 0); + u32_cpy ((uint32_t *) cbuf, + (uint32_t *) STRINGBUF_WIDE_CHARS (buf), len); + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), + sbc); + } + e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"), + scm_from_size_t (STRINGBUF_LENGTH (buf))); + if (STRINGBUF_MUTABLE (buf)) + e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), + SCM_BOOL_T); + else + e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), + SCM_BOOL_F); + if (STRINGBUF_WIDE (buf)) + e9 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e9 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), + SCM_BOOL_F); + + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, SCM_UNDEFINED); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), + "Returns an association list containing debugging information\n" + "for @var{sym}. The association list has the following entries." + "@table @code\n" + "@item symbol\n" + "The symbol itself\n" + "@item hash\n" + "Its hash value\n" + "@item interned\n" + "@code{#t} if it is an interned symbol\n" + "@item stringbuf-chars\n" + "A new string containing this symbols's stringbuf's characters\n" + "@item stringbuf-length\n" + "The number of characters in this stringbuf\n" + "@item stringbuf-mutable\n" + "@code{#t} if this stringbuf is mutable\n" + "@item stringbuf-wide\n" + "@code{#t} if this stringbuf's characters are stored in a\n" + "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" + "buffer\n" + "@end table") +#define FUNC_NAME s_scm_sys_symbol_dump +{ + SCM e1, e2, e3, e4, e5, e6, e7; + SCM buf; + SCM_VALIDATE_SYMBOL (1, sym); + e1 = scm_cons (scm_from_latin1_symbol ("symbol"), + sym); + e2 = scm_cons (scm_from_latin1_symbol ("hash"), + scm_from_ulong (scm_i_symbol_hash (sym))); + e3 = scm_cons (scm_from_latin1_symbol ("interned"), + scm_symbol_interned_p (sym)); + buf = SYMBOL_STRINGBUF (sym); + + /* Stringbuf info */ + if (!STRINGBUF_WIDE (buf)) + { + size_t len = STRINGBUF_LENGTH (buf); + char *cbuf; + SCM sbc = scm_i_make_string (len, &cbuf, 0); + memcpy (cbuf, STRINGBUF_CHARS (buf), len); + e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), + sbc); + } + else + { + size_t len = STRINGBUF_LENGTH (buf); + scm_t_wchar *cbuf; + SCM sbc = scm_i_make_wide_string (len, &cbuf, 0); + u32_cpy ((uint32_t *) cbuf, + (uint32_t *) STRINGBUF_WIDE_CHARS (buf), len); + e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"), + sbc); + } + e5 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"), + scm_from_size_t (STRINGBUF_LENGTH (buf))); + if (STRINGBUF_MUTABLE (buf)) + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), + SCM_BOOL_T); + else + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), + SCM_BOOL_F); + if (STRINGBUF_WIDE (buf)) + e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), + SCM_BOOL_F); + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, SCM_UNDEFINED); + +} +#undef FUNC_NAME + +#ifdef SCM_STRING_LENGTH_HISTOGRAM + +SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "") +#define FUNC_NAME s_scm_sys_stringbuf_hist +{ + int i; + for (i = 0; i < 1000; i++) + if (lenhist[i]) + fprintf (stderr, " %3d: %u\n", i, lenhist[i]); + fprintf (stderr, ">999: %u\n", lenhist[1000]); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#endif + + + +SCM_DEFINE (scm_string_p, "string?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a string, else @code{#f}.") +#define FUNC_NAME s_scm_string_p +{ + return scm_from_bool (IS_STRING (obj)); +} +#undef FUNC_NAME + + +SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string); + +SCM_DEFINE (scm_string, "string", 0, 0, 1, + (SCM chrs), + "@deffnx {Scheme Procedure} list->string chrs\n" + "Return a newly allocated string composed of the arguments,\n" + "@var{chrs}.") +#define FUNC_NAME s_scm_string +{ + SCM result = SCM_BOOL_F; + SCM rest; + size_t len; + size_t p = 0; + long i; + int wide = 0; + + /* Verify that this is a list of chars. */ + i = scm_ilength (chrs); + SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME); + + len = (size_t) i; + rest = chrs; + + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + SCM_VALIDATE_CHAR (SCM_ARGn, elt); + if (SCM_CHAR (elt) > 0xFF) + wide = 1; + rest = SCM_CDR (rest); + len--; + scm_remember_upto_here_1 (elt); + } + + /* Construct a string containing this list of chars. */ + len = (size_t) i; + rest = chrs; + + if (wide == 0) + { + char *buf; + + result = scm_i_make_string (len, NULL, 0); + buf = scm_i_string_writable_chars (result); + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + buf[p] = (unsigned char) SCM_CHAR (elt); + p++; + rest = SCM_CDR (rest); + len--; + scm_remember_upto_here_1 (elt); + } + } + else + { + scm_t_wchar *buf; + + result = scm_i_make_wide_string (len, NULL, 0); + buf = scm_i_string_writable_wide_chars (result); + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + buf[p] = SCM_CHAR (elt); + p++; + rest = SCM_CDR (rest); + len--; + scm_remember_upto_here_1 (elt); + } + } + + if (len > 0) + scm_misc_error (NULL, "list changed while constructing string", SCM_EOL); + if (!scm_is_null (rest)) + scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list"); + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, + (SCM k, SCM chr), + "Return a newly allocated string of\n" + "length @var{k}. If @var{chr} is given, then all elements of\n" + "the string are initialized to @var{chr}, otherwise the contents\n" + "of the string are all set to @code{#\nul}.") +#define FUNC_NAME s_scm_make_string +{ + SCM ret = scm_c_make_string (scm_to_size_t (k), chr); + /* Given that make-string is mostly used by Scheme to prepare a + mutable string buffer, let's go ahead and mark this as mutable to + avoid a copy when this buffer is next written to. */ + STRINGBUF_SET_MUTABLE (STRING_STRINGBUF (ret)); + return ret; +} +#undef FUNC_NAME + +SCM +scm_c_make_string (size_t len, SCM chr) +#define FUNC_NAME NULL +{ + size_t p; + char *contents = NULL; + SCM res = scm_i_make_string (len, &contents, 0); + + /* If no char is given, initialize string contents to NULL. */ + if (SCM_UNBNDP (chr)) + memset (contents, 0, len); + else + { + SCM_VALIDATE_CHAR (0, chr); + for (p = 0; p < len; p++) + scm_i_string_set_x (res, p, SCM_CHAR (chr)); + } + + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, + (SCM string), + "Return the number of characters in @var{string}.") +#define FUNC_NAME s_scm_string_length +{ + SCM_VALIDATE_STRING (1, string); + return scm_from_size_t (STRING_LENGTH (string)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_bytes_per_char, "string-bytes-per-char", 1, 0, 0, + (SCM string), + "Return the bytes used to represent a character in @var{string}." + "This will return 1 or 4.") +#define FUNC_NAME s_scm_string_bytes_per_char +{ + SCM_VALIDATE_STRING (1, string); + if (!scm_i_is_narrow_string (string)) + return scm_from_int (4); + + return scm_from_int (1); +} +#undef FUNC_NAME + +size_t +scm_c_string_length (SCM string) +{ + if (!IS_STRING (string)) + scm_wrong_type_arg_msg (NULL, 0, string, "string"); + return STRING_LENGTH (string); +} + +SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0, + (SCM str, SCM k), + "Return character @var{k} of @var{str} using zero-origin\n" + "indexing. @var{k} must be a valid index of @var{str}.") +#define FUNC_NAME s_scm_string_ref +{ + size_t len; + unsigned long idx; + + SCM_VALIDATE_STRING (1, str); + + len = scm_i_string_length (str); + if (SCM_LIKELY (len > 0)) + idx = scm_to_unsigned_integer (k, 0, len - 1); + else + scm_out_of_range (NULL, k); + + if (scm_i_is_narrow_string (str)) + return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]); + else + return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]); +} +#undef FUNC_NAME + +SCM +scm_c_string_ref (SCM str, size_t p) +{ + if (p >= scm_i_string_length (str)) + scm_out_of_range (NULL, scm_from_size_t (p)); + if (scm_i_is_narrow_string (str)) + return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]); + else + return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]); + +} + +SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0, + (SCM str, SCM k, SCM chr), + "Store @var{chr} in element @var{k} of @var{str} and return\n" + "an unspecified value. @var{k} must be a valid index of\n" + "@var{str}.") +#define FUNC_NAME s_scm_string_set_x +{ + size_t len; + unsigned long idx; + + SCM_VALIDATE_STRING (1, str); + + len = scm_i_string_length (str); + if (SCM_LIKELY (len > 0)) + idx = scm_to_unsigned_integer (k, 0, len - 1); + else + scm_out_of_range (NULL, k); + + SCM_VALIDATE_CHAR (3, chr); + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, idx, SCM_CHAR (chr)); + scm_i_string_stop_writing (); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_c_string_set_x (SCM str, size_t p, SCM chr) +{ + if (p >= scm_i_string_length (str)) + scm_out_of_range (NULL, scm_from_size_t (p)); + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, p, SCM_CHAR (chr)); + scm_i_string_stop_writing (); +} + +SCM_DEFINE (scm_substring, "substring", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return a newly allocated string formed from the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") +#define FUNC_NAME s_scm_substring +{ + size_t len, from, to; + + SCM_VALIDATE_STRING (1, str); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); + if (SCM_UNBNDP (end)) + to = len; + else + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring (str, from, to); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return a newly allocated string formed from the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n" + "\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n" + "\n" + "The returned string is read-only.\n") +#define FUNC_NAME s_scm_substring_read_only +{ + size_t len, from, to; + + SCM_VALIDATE_STRING (1, str); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); + if (SCM_UNBNDP (end)) + to = len; + else + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring_read_only (str, from, to); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return a newly allocated string formed from the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") +#define FUNC_NAME s_scm_substring_copy +{ + /* For the Scheme version, START is mandatory, but for the C + version, it is optional. See scm_string_copy in srfi-13.c for a + rationale. + */ + + size_t from, to; + + SCM_VALIDATE_STRING (1, str); + scm_i_get_substring_spec (scm_i_string_length (str), + start, &from, end, &to); + return scm_i_substring_copy (str, from, to); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0, + (SCM str, SCM start, SCM end), + "Return string that indirectly refers to the characters\n" + "of @var{str} beginning with index @var{start} (inclusive) and\n" + "ending with index @var{end} (exclusive).\n" + "@var{str} must be a string, @var{start} and @var{end} must be\n" + "exact integers satisfying:\n\n" + "0 <= @var{start} <= @var{end} <= (string-length @var{str}).") +#define FUNC_NAME s_scm_substring_shared +{ + size_t len, from, to; + + SCM_VALIDATE_STRING (1, str); + len = scm_i_string_length (str); + from = scm_to_unsigned_integer (start, 0, len); + if (SCM_UNBNDP (end)) + to = len; + else + to = scm_to_unsigned_integer (end, from, len); + return scm_i_substring_shared (str, from, to); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, + (SCM args), + "Return a newly allocated string whose characters form the\n" + "concatenation of the given strings, @var{args}.") +#define FUNC_NAME s_scm_string_append +{ + SCM res; + size_t total = 0; + size_t len; + int wide = 0; + SCM l, s; + size_t i; + union + { + char *narrow; + scm_t_wchar *wide; + } data; + + SCM_VALIDATE_REST_ARGUMENT (args); + for (l = args; !scm_is_null (l); l = SCM_CDR (l)) + { + s = SCM_CAR (l); + SCM_VALIDATE_STRING (SCM_ARGn, s); + len = scm_i_string_length (s); + if (((size_t) -1) - total < len) + scm_num_overflow (s_scm_string_append); + total += len; + if (!scm_i_is_narrow_string (s)) + wide = 1; + } + data.narrow = NULL; + if (!wide) + res = scm_i_make_string (total, &data.narrow, 0); + else + res = scm_i_make_wide_string (total, &data.wide, 0); + + for (l = args; !scm_is_null (l); l = SCM_CDR (l)) + { + size_t len; + s = SCM_CAR (l); + SCM_VALIDATE_STRING (SCM_ARGn, s); + len = scm_i_string_length (s); + if (len > total) + SCM_MISC_ERROR ("list changed during string-append", SCM_EOL); + if (!wide) + { + memcpy (data.narrow, scm_i_string_chars (s), len); + data.narrow += len; + } + else + { + if (scm_i_is_narrow_string (s)) + { + const char *src = scm_i_string_chars (s); + for (i = 0; i < len; i++) + data.wide[i] = (unsigned char) src[i]; + } + else + u32_cpy ((uint32_t *) data.wide, + (uint32_t *) scm_i_string_wide_chars (s), len); + data.wide += len; + } + total -= len; + scm_remember_upto_here_1 (s); + } + if (total != 0) + SCM_MISC_ERROR ("list changed during string-append", SCM_EOL); + return res; +} +#undef FUNC_NAME + + + +/* Charset conversion error handling. */ + +SCM_SYMBOL (scm_encoding_error_key, "encoding-error"); +SCM_SYMBOL (scm_decoding_error_key, "decoding-error"); + +/* Raise an exception informing that character CHR could not be written + to PORT in its current encoding. */ +void +scm_encoding_error (const char *subr, int err, const char *message, + SCM port, SCM chr) +{ + scm_throw (scm_encoding_error_key, + scm_list_n (scm_from_latin1_string (subr), + scm_from_latin1_string (message), + scm_from_int (err), + port, chr, + SCM_UNDEFINED)); +} + +/* Raise an exception informing of an encoding error on PORT. This + means that a character could not be written in PORT's encoding. */ +void +scm_decoding_error (const char *subr, int err, const char *message, SCM port) +{ + scm_throw (scm_decoding_error_key, + scm_list_n (scm_from_latin1_string (subr), + scm_from_latin1_string (message), + scm_from_int (err), + port, + SCM_UNDEFINED)); +} + + +/* String conversion to/from C. */ + +static void +decoding_error (const char *func_name, int errno_save, + const char *str, size_t len) +{ + /* Raise an error and pass the raw C string as a bytevector to the `throw' + handler. */ + SCM bv; + signed char *buf; + + buf = scm_gc_malloc_pointerless (len, "bytevector"); + memcpy (buf, str, len); + bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F); + + scm_decoding_error (func_name, errno_save, + "input locale conversion error", bv); +} + +SCM +scm_from_stringn (const char *str, size_t len, const char *encoding, + scm_t_string_failed_conversion_handler handler) +{ + size_t u32len, i; + scm_t_wchar *u32; + int wide = 0; + SCM res; + + /* The order of these checks is important. */ + if (!str && len != 0) + scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL); + if (len == (size_t) -1) + len = strlen (str); + + if (c_strcasecmp (encoding, "ISO-8859-1") == 0 || len == 0) + return scm_from_latin1_stringn (str, len); + else if (c_strcasecmp (encoding, "UTF-8") == 0 + && handler == SCM_FAILED_CONVERSION_ERROR) + return scm_from_utf8_stringn (str, len); + + u32len = 0; + u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding, + (enum iconv_ilseq_handler) + handler, + str, len, + NULL, + NULL, &u32len); + + if (SCM_UNLIKELY (u32 == NULL)) + decoding_error (__func__, errno, str, len); + + i = 0; + while (i < u32len) + if (u32[i++] > 0xFF) + { + wide = 1; + break; + } + + if (!wide) + { + char *dst; + res = scm_i_make_string (u32len, &dst, 0); + for (i = 0; i < u32len; i ++) + dst[i] = (unsigned char) u32[i]; + dst[u32len] = '\0'; + } + else + { + scm_t_wchar *wdst; + res = scm_i_make_wide_string (u32len, &wdst, 0); + u32_cpy ((uint32_t *) wdst, (uint32_t *) u32, u32len); + wdst[u32len] = 0; + } + + free (u32); + return res; +} + +SCM +scm_from_locale_string (const char *str) +{ + return scm_from_locale_stringn (str, -1); +} + +scm_t_string_failed_conversion_handler +scm_i_default_string_failed_conversion_handler (void) +{ + return scm_i_string_failed_conversion_handler + (scm_i_default_port_conversion_strategy ()); +} + +SCM +scm_from_locale_stringn (const char *str, size_t len) +{ + return scm_from_stringn (str, len, locale_charset (), + scm_i_default_string_failed_conversion_handler ()); +} + +SCM +scm_from_latin1_string (const char *str) +{ + return scm_from_latin1_stringn (str, -1); +} + +SCM +scm_from_latin1_stringn (const char *str, size_t len) +{ + char *buf; + SCM result; + + if (len == (size_t) -1) + len = strlen (str); + + /* Make a narrow string and copy STR as is. */ + result = scm_i_make_string (len, &buf, 0); + memcpy (buf, str, len); + + return result; +} + +SCM +scm_from_utf8_string (const char *str) +{ + return scm_from_utf8_stringn (str, -1); +} + +SCM +scm_from_utf8_stringn (const char *str, size_t len) +{ + size_t i, char_len; + const uint8_t *ustr = (const uint8_t *) str; + int ascii = 1, narrow = 1; + SCM res; + + if (len == (size_t) -1) + len = strlen (str); + + i = 0; + char_len = 0; + + while (i < len) + { + if (ustr[i] <= 127) + { + char_len++; + i++; + } + else + { + ucs4_t c; + int nbytes; + + ascii = 0; + + nbytes = u8_mbtoucr (&c, ustr + i, len - i); + + if (nbytes < 0) + /* Bad UTF-8. */ + decoding_error (__func__, errno, str, len); + + if (c > 255) + narrow = 0; + + char_len++; + i += nbytes; + } + } + + if (ascii) + { + char *dst; + res = scm_i_make_string (char_len, &dst, 0); + memcpy (dst, str, len); + } + else if (narrow) + { + char *dst; + size_t j; + ucs4_t c; + + res = scm_i_make_string (char_len, &dst, 0); + + for (i = 0, j = 0; i < len; j++) + { + i += u8_mbtouc_unsafe (&c, ustr + i, len - i); + dst[j] = (signed char) c; + } + } + else + { + scm_t_wchar *dst; + size_t j; + ucs4_t c; + + res = scm_i_make_wide_string (char_len, &dst, 0); + + for (i = 0, j = 0; i < len; j++) + { + i += u8_mbtouc_unsafe (&c, ustr + i, len - i); + dst[j] = c; + } + } + + return res; +} + +SCM +scm_from_utf32_string (const scm_t_wchar *str) +{ + return scm_from_utf32_stringn (str, -1); +} + +SCM +scm_from_utf32_stringn (const scm_t_wchar *str, size_t len) +{ + SCM result; + scm_t_wchar *buf; + + if (len == (size_t) -1) + len = u32_strlen ((uint32_t *) str); + + result = scm_i_make_wide_string (len, &buf, 0); + memcpy (buf, str, len * sizeof (scm_t_wchar)); + scm_i_try_narrow_string (result); + + return result; +} + +SCM +scm_from_port_string (const char *str, SCM port) +{ + return scm_from_port_stringn (str, -1, port); +} + +SCM +scm_from_port_stringn (const char *str, size_t len, SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + return scm_from_latin1_stringn (str, len); + else if (scm_is_eq (pt->encoding, sym_UTF_8) + && (scm_is_eq (pt->conversion_strategy, sym_error) + || (u8_check ((uint8_t *) str, len) == NULL))) + return scm_from_utf8_stringn (str, len); + else + return scm_from_stringn (str, len, scm_i_symbol_chars (pt->encoding), + scm_i_string_failed_conversion_handler + (SCM_PORT (port)->conversion_strategy)); +} + +/* Create a new scheme string from the C string STR. The memory of + STR may be used directly as storage for the new string. */ +/* FIXME: GC-wise, the only way to use the memory area pointed to by STR + would be to register a finalizer to eventually free(3) STR, which isn't + worth it. Should we just deprecate the `scm_take_' functions? */ +SCM +scm_take_locale_stringn (char *str, size_t len) +{ + SCM res; + + res = scm_from_locale_stringn (str, len); + free (str); + + return res; +} + +SCM +scm_take_locale_string (char *str) +{ + return scm_take_locale_stringn (str, -1); +} + +/* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a + *LENP-byte locale-encoded string, to `\xXX', `\uXXXX', or `\UXXXXXX'. + Set *LENP to the size of the resulting string. + + FIXME: This is a hack we should get rid of. See + <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00004.html> + for details. */ +static void +unistring_escapes_to_guile_escapes (char *buf, size_t *lenp) +{ + char *before, *after; + size_t i, j; + + before = buf; + after = buf; + i = 0; + j = 0; + while (i < *lenp) + { + if ((i <= *lenp - 6) + && before[i] == '\\' + && before[i + 1] == 'u' + && before[i + 2] == '0' && before[i + 3] == '0') + { + /* Convert \u00NN to \xNN */ + after[j] = '\\'; + after[j + 1] = 'x'; + after[j + 2] = tolower ((int) before[i + 4]); + after[j + 3] = tolower ((int) before[i + 5]); + i += 6; + j += 4; + } + else if ((i <= *lenp - 10) + && before[i] == '\\' + && before[i + 1] == 'U' + && before[i + 2] == '0' && before[i + 3] == '0') + { + /* Convert \U00NNNNNN to \UNNNNNN */ + after[j] = '\\'; + after[j + 1] = 'U'; + after[j + 2] = tolower ((int) before[i + 4]); + after[j + 3] = tolower ((int) before[i + 5]); + after[j + 4] = tolower ((int) before[i + 6]); + after[j + 5] = tolower ((int) before[i + 7]); + after[j + 6] = tolower ((int) before[i + 8]); + after[j + 7] = tolower ((int) before[i + 9]); + i += 10; + j += 8; + } + else + { + after[j] = before[i]; + i++; + j++; + } + } + *lenp = j; +} + +/* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a + *LENP-byte locale-encoded string, to `\xXXXX;'. Set *LEN to the size + of the resulting string. BUF must be large enough to handle the + worst case when `\uXXXX' escapes (6 characters) are replaced by + `\xXXXX;' (7 characters). */ +static void +unistring_escapes_to_r6rs_escapes (char *buf, size_t *lenp) +{ + char *before, *after; + size_t i, j; + /* The worst case is if the input string contains all 4-digit hex escapes. + "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */ + size_t max_out_len = (*lenp * 7) / 6 + 1; + size_t nzeros, ndigits; + + before = buf; + after = alloca (max_out_len); + i = 0; + j = 0; + while (i < *lenp) + { + if (((i <= *lenp - 6) && before[i] == '\\' && before[i + 1] == 'u') + || ((i <= *lenp - 10) && before[i] == '\\' && before[i + 1] == 'U')) + { + if (before[i + 1] == 'u') + ndigits = 4; + else if (before[i + 1] == 'U') + ndigits = 8; + else + abort (); + + /* Add the R6RS hex escape initial sequence. */ + after[j] = '\\'; + after[j + 1] = 'x'; + + /* Move string positions to the start of the hex numbers. */ + i += 2; + j += 2; + + /* Find the number of initial zeros in this hex number. */ + nzeros = 0; + while (before[i + nzeros] == '0' && nzeros < ndigits) + nzeros++; + + /* Copy the number, skipping initial zeros, and then move the string + positions. */ + if (nzeros == ndigits) + { + after[j] = '0'; + i += ndigits; + j += 1; + } + else + { + int pos; + for (pos = 0; pos < ndigits - nzeros; pos++) + after[j + pos] = tolower ((int) before[i + nzeros + pos]); + i += ndigits; + j += (ndigits - nzeros); + } + + /* Add terminating semicolon. */ + after[j] = ';'; + j++; + } + else + { + after[j] = before[i]; + i++; + j++; + } + } + *lenp = j; + memcpy (before, after, j); +} + +char * +scm_to_locale_string (SCM str) +{ + return scm_to_locale_stringn (str, NULL); +} + +char * +scm_to_locale_stringn (SCM str, size_t *lenp) +{ + return scm_to_stringn (str, lenp, + locale_charset (), + scm_i_default_string_failed_conversion_handler ()); +} + +char * +scm_to_latin1_string (SCM str) +{ + return scm_to_latin1_stringn (str, NULL); +} + +char * +scm_to_latin1_stringn (SCM str, size_t *lenp) +#define FUNC_NAME "scm_to_latin1_stringn" +{ + char *result; + + SCM_VALIDATE_STRING (1, str); + + if (scm_i_is_narrow_string (str)) + { + size_t len = scm_i_string_length (str); + + if (lenp) + *lenp = len; + + result = scm_strndup (scm_i_string_data (str), len); + } + else + result = scm_to_stringn (str, lenp, NULL, + SCM_FAILED_CONVERSION_ERROR); + + return result; +} +#undef FUNC_NAME + +char * +scm_to_utf8_string (SCM str) +{ + return scm_to_utf8_stringn (str, NULL); +} + +static size_t +latin1_u8_strlen (const uint8_t *str, size_t len) +{ + size_t ret, i; + for (i = 0, ret = 0; i < len; i++) + ret += (str[i] < 128) ? 1 : 2; + return ret; +} + +static uint8_t* +latin1_to_u8 (const uint8_t *str, size_t latin_len, + uint8_t *u8_result, size_t *u8_lenp) +{ + size_t i, n; + size_t u8_len = latin1_u8_strlen (str, latin_len); + + if (!(u8_result && u8_lenp && *u8_lenp > u8_len)) + u8_result = scm_malloc (u8_len + 1); + if (u8_lenp) + *u8_lenp = u8_len; + + for (i = 0, n = 0; i < latin_len; i++) + n += u8_uctomb (u8_result + n, str[i], u8_len - n); + if (n != u8_len) + abort (); + u8_result[n] = 0; + + return u8_result; +} + +/* UTF-8 code table + + (Note that this includes code points that are not allowed by Unicode, + but since this function has no way to report an error, and its + purpose is to determine the size of destination buffers for + libunicode conversion functions, we err on the safe side and handle + everything that libunicode might conceivably handle, now or in the + future.) + + Char. number range | UTF-8 octet sequence + (hexadecimal) | (binary) + --------------------+------------------------------------------------------ + 0000 0000-0000 007F | 0xxxxxxx + 0000 0080-0000 07FF | 110xxxxx 10xxxxxx + 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx + 0001 0000-001F FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + 0020 0000-03FF FFFF | 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + 0400 0000-7FFF FFFF | 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx +*/ + +static size_t +u32_u8_length_in_bytes (const uint32_t *str, size_t len) +{ + size_t ret, i; + + for (i = 0, ret = 0; i < len; i++) + { + uint32_t c = str[i]; + + if (c <= 0x7f) + ret += 1; + else if (c <= 0x7ff) + ret += 2; + else if (c <= 0xffff) + ret += 3; + else if (c <= 0x1fffff) + ret += 4; + else if (c <= 0x3ffffff) + ret += 5; + else + ret += 6; + } + + return ret; +} + +static size_t +utf8_length (SCM str) +{ + if (scm_i_is_narrow_string (str)) + return latin1_u8_strlen ((uint8_t *) scm_i_string_chars (str), + scm_i_string_length (str)); + else + return u32_u8_length_in_bytes + ((uint32_t *) scm_i_string_wide_chars (str), + scm_i_string_length (str)); +} + +size_t +scm_c_string_utf8_length (SCM string) +#define FUNC_NAME "scm_c_string_utf8_length" +{ + SCM_VALIDATE_STRING (1, string); + return utf8_length (string); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_utf8_length, "string-utf8-length", 1, 0, 0, + (SCM string), + "Returns the number of bytes in the UTF-8 representation of " + "@var{string}.") +#define FUNC_NAME s_scm_string_utf8_length +{ + SCM_VALIDATE_STRING (1, string); + return scm_from_size_t (utf8_length (string)); +} +#undef FUNC_NAME + +char * +scm_to_utf8_stringn (SCM str, size_t *lenp) +#define FUNC_NAME "scm_to_utf8_stringn" +{ + SCM_VALIDATE_STRING (1, str); + + if (scm_i_is_narrow_string (str)) + return (char *) latin1_to_u8 ((uint8_t *) scm_i_string_chars (str), + scm_i_string_length (str), + NULL, lenp); + else + { + uint32_t *chars = (uint32_t *) scm_i_string_wide_chars (str); + uint8_t *buf, *ret; + size_t num_chars = scm_i_string_length (str); + size_t num_bytes_predicted, num_bytes_actual; + + num_bytes_predicted = u32_u8_length_in_bytes (chars, num_chars); + + if (lenp) + { + *lenp = num_bytes_predicted; + buf = scm_malloc (num_bytes_predicted); + } + else + { + buf = scm_malloc (num_bytes_predicted + 1); + buf[num_bytes_predicted] = 0; + } + + num_bytes_actual = num_bytes_predicted; + ret = u32_to_u8 (chars, num_chars, buf, &num_bytes_actual); + + if (SCM_LIKELY (ret == buf && num_bytes_actual == num_bytes_predicted)) + return (char *) ret; + + /* An error: a bad codepoint. */ + { + int saved_errno = errno; + + free (buf); + if (!saved_errno) + abort (); + + scm_decoding_error ("scm_to_utf8_stringn", errno, + "invalid codepoint in string", str); + + /* Not reached. */ + return NULL; + } + } +} +#undef FUNC_NAME + +scm_t_wchar * +scm_to_utf32_string (SCM str) +{ + return scm_to_utf32_stringn (str, NULL); +} + +scm_t_wchar * +scm_to_utf32_stringn (SCM str, size_t *lenp) +#define FUNC_NAME "scm_to_utf32_stringn" +{ + scm_t_wchar *result; + + SCM_VALIDATE_STRING (1, str); + + if (scm_i_is_narrow_string (str)) + { + uint8_t *codepoints; + size_t i, len; + + codepoints = (uint8_t*) scm_i_string_chars (str); + len = scm_i_string_length (str); + if (lenp) + *lenp = len; + + result = scm_malloc ((len + 1) * sizeof (scm_t_wchar)); + for (i = 0; i < len; i++) + result[i] = codepoints[i]; + result[len] = 0; + } + else + { + size_t len; + + len = scm_i_string_length (str); + if (lenp) + *lenp = len; + + result = scm_malloc ((len + 1) * sizeof (scm_t_wchar)); + memcpy (result, scm_i_string_wide_chars (str), + len * sizeof (scm_t_wchar)); + result[len] = 0; + } + + return result; +} +#undef FUNC_NAME + +char * +scm_to_port_string (SCM str, SCM port) +{ + return scm_to_port_stringn (str, NULL, port); +} + +char * +scm_to_port_stringn (SCM str, size_t *lenp, SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1) + && scm_is_eq (pt->conversion_strategy, sym_error)) + return scm_to_latin1_stringn (str, lenp); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + return scm_to_utf8_stringn (str, lenp); + else + return scm_to_stringn (str, lenp, scm_i_symbol_chars (pt->encoding), + scm_i_string_failed_conversion_handler + (SCM_PORT (port)->conversion_strategy)); +} + +/* Return a malloc(3)-allocated buffer containing the contents of STR encoded + according to ENCODING. If LENP is non-NULL, set it to the size in bytes of + the returned buffer. If the conversion to ENCODING fails, apply the strategy + defined by HANDLER. */ +char * +scm_to_stringn (SCM str, size_t *lenp, const char *encoding, + scm_t_string_failed_conversion_handler handler) +{ + char *buf; + size_t ilen, len, i; + int ret; + const char *enc; + + if (!scm_is_string (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + + if (c_strcasecmp (encoding, "UTF-8") == 0) + /* This is the most common case--e.g., when calling libc bindings + while using a UTF-8 locale. */ + return scm_to_utf8_stringn (str, lenp); + + ilen = scm_i_string_length (str); + + if (ilen == 0) + { + buf = scm_malloc (1); + buf[0] = '\0'; + if (lenp) + *lenp = 0; + return buf; + } + + if (lenp == NULL) + for (i = 0; i < ilen; i++) + if (scm_i_string_ref (str, i) == '\0') + scm_misc_error (NULL, + "string contains #\\nul character: ~S", + scm_list_1 (str)); + + if (scm_i_is_narrow_string (str) + && c_strcasecmp (encoding, "ISO-8859-1") == 0) + { + /* If using native Latin-1 encoding, just copy the string + contents. */ + if (lenp) + { + buf = scm_malloc (ilen); + memcpy (buf, scm_i_string_chars (str), ilen); + *lenp = ilen; + return buf; + } + else + { + buf = scm_malloc (ilen + 1); + memcpy (buf, scm_i_string_chars (str), ilen); + buf[ilen] = '\0'; + return buf; + } + } + + + buf = NULL; + len = 0; + enc = encoding; + if (enc == NULL) + enc = "ISO-8859-1"; + if (scm_i_is_narrow_string (str)) + { + ret = mem_iconveh (scm_i_string_chars (str), ilen, + "ISO-8859-1", enc, + (enum iconv_ilseq_handler) handler, NULL, + &buf, &len); + + if (ret != 0) + scm_encoding_error (__func__, errno, + "cannot convert narrow string to output locale", + SCM_BOOL_F, + /* FIXME: Faulty character unknown. */ + SCM_BOOL_F); + } + else + { + buf = u32_conv_to_encoding (enc, + (enum iconv_ilseq_handler) handler, + (uint32_t *) scm_i_string_wide_chars (str), + ilen, + NULL, + NULL, &len); + if (buf == NULL) + scm_encoding_error (__func__, errno, + "cannot convert wide string to output locale", + SCM_BOOL_F, + /* FIXME: Faulty character unknown. */ + SCM_BOOL_F); + } + if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) + { + if (SCM_R6RS_ESCAPES_P) + { + /* The worst case is if the input string contains all 4-digit + hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;" + (seven characters). Make BUF large enough to hold + that. */ + buf = scm_realloc (buf, (len * 7) / 6 + 1); + unistring_escapes_to_r6rs_escapes (buf, &len); + } + else + unistring_escapes_to_guile_escapes (buf, &len); + + buf = scm_realloc (buf, len); + } + if (lenp) + *lenp = len; + else + { + buf = scm_realloc (buf, len + 1); + buf[len] = '\0'; + } + + scm_remember_upto_here_1 (str); + return buf; +} + +size_t +scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len) +{ + size_t len; + char *result = NULL; + if (!scm_is_string (str)) + scm_wrong_type_arg_msg (NULL, 0, str, "string"); + result = scm_to_locale_stringn (str, &len); + + memcpy (buf, result, (len > max_len) ? max_len : len); + free (result); + + scm_remember_upto_here_1 (str); + return len; +} + + +/* Unicode string normalization. */ + +/* This function is a partial clone of SCM_STRING_TO_U32_BUF from + libguile/i18n.c. It would be useful to have this factored out into a more + convenient location, but its use of alloca makes that tricky to do. */ + +static SCM +normalize_str (SCM string, uninorm_t form) +{ + SCM ret; + uint32_t *w_str; + scm_t_wchar *cbuf; + size_t rlen, len = scm_i_string_length (string); + + if (scm_i_is_narrow_string (string)) + { + size_t i; + const char *buf = scm_i_string_chars (string); + + w_str = alloca (sizeof (scm_t_wchar) * (len + 1)); + + for (i = 0; i < len; i ++) + w_str[i] = (unsigned char) buf[i]; + w_str[len] = 0; + } + else + w_str = (uint32_t *) scm_i_string_wide_chars (string); + + w_str = u32_normalize (form, w_str, len, NULL, &rlen); + + ret = scm_i_make_wide_string (rlen, &cbuf, 0); + u32_cpy ((uint32_t *) cbuf, w_str, rlen); + free (w_str); + + scm_i_try_narrow_string (ret); + + return ret; +} + +SCM_DEFINE (scm_string_normalize_nfc, "string-normalize-nfc", 1, 0, 0, + (SCM string), + "Returns the NFC normalized form of @var{string}.") +#define FUNC_NAME s_scm_string_normalize_nfc +{ + SCM_VALIDATE_STRING (1, string); + return normalize_str (string, UNINORM_NFC); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_normalize_nfd, "string-normalize-nfd", 1, 0, 0, + (SCM string), + "Returns the NFD normalized form of @var{string}.") +#define FUNC_NAME s_scm_string_normalize_nfd +{ + SCM_VALIDATE_STRING (1, string); + return normalize_str (string, UNINORM_NFD); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_normalize_nfkc, "string-normalize-nfkc", 1, 0, 0, + (SCM string), + "Returns the NFKC normalized form of @var{string}.") +#define FUNC_NAME s_scm_string_normalize_nfkc +{ + SCM_VALIDATE_STRING (1, string); + return normalize_str (string, UNINORM_NFKC); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_normalize_nfkd, "string-normalize-nfkd", 1, 0, 0, + (SCM string), + "Returns the NFKD normalized form of @var{string}.") +#define FUNC_NAME s_scm_string_normalize_nfkd +{ + SCM_VALIDATE_STRING (1, string); + return normalize_str (string, UNINORM_NFKD); +} +#undef FUNC_NAME + +/* converts C scm_array of strings to SCM scm_list of strings. + If argc < 0, a null terminated scm_array is assumed. + The current locale encoding is assumed */ +SCM +scm_makfromstrs (int argc, char **argv) +{ + int i = argc; + SCM lst = SCM_EOL; + if (0 > i) + for (i = 0; argv[i]; i++); + while (i--) + lst = scm_cons (scm_from_locale_string (argv[i]), lst); + return lst; +} + +/* Return a newly allocated array of char pointers to each of the strings + in args, with a terminating NULL pointer. The strings are encoded using + the current locale. */ + +char ** +scm_i_allocate_string_pointers (SCM list) +#define FUNC_NAME "scm_i_allocate_string_pointers" +{ + char **result; + int list_len = scm_ilength (list); + int i; + + if (list_len < 0) + scm_wrong_type_arg_msg (NULL, 0, list, "proper list"); + + result = scm_gc_malloc ((list_len + 1) * sizeof (char *), + "string pointers"); + result[list_len] = NULL; + + /* The list might have been modified in another thread, so + we check LIST before each access. + */ + for (i = 0; i < list_len && scm_is_pair (list); i++) + { + SCM str = SCM_CAR (list); + size_t len; /* String length in bytes */ + char *c_str = scm_to_locale_stringn (str, &len); + + /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses + scm_malloc to allocate the returned string, which must be + explicitly deallocated. This forces us to copy the string a + second time into a new buffer. Ideally there would be variants + of scm_to_*_stringn that can return garbage-collected buffers. */ + + result[i] = scm_gc_malloc_pointerless (len + 1, "string"); + memcpy (result[i], c_str, len); + result[i][len] = '\0'; + free (c_str); + + list = SCM_CDR (list); + } + + return result; +} +#undef FUNC_NAME + +void +scm_i_get_substring_spec (size_t len, + SCM start, size_t *cstart, + SCM end, size_t *cend) +{ + if (SCM_UNBNDP (start)) + *cstart = 0; + else + *cstart = scm_to_unsigned_integer (start, 0, len); + + if (SCM_UNBNDP (end)) + *cend = len; + else + *cend = scm_to_unsigned_integer (end, *cstart, len); +} + +SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string) + +void +scm_init_strings () +{ + scm_nullstr = scm_i_make_string (0, NULL, 0); + +#include "strings.x" +} + |