mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity
guile/libguile/strings.c
Michael Gran eca29b0202 Don't include libunistring headers in Guile public headers 
This requres the creation of a new type
scm_t_string_failed_conversion_handler to replace libunistring's
enum iconveh_ilseq_handler.

* libguile/strings.h: don't include <uniconv.h>
(scm_t_string_failed_conversion_handler): new enum type
(SCM_FAILED_CONVERSION_ERROR, SCM_FAILED_CONVERSION_QUESTION_MARK):
(SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE): new enum type values

* libguile/strings.c (scm_to_stringn): now takes type
scm_t_string_failed_conversion_handler.  All callers changed.

* libguile/print.c: include <uniconv.h>

* libguile/ports.c (scm_lfwrite_substr): use
scm_t_string_conversion_handler's constants

* libguile/gen-scmconfig.c (SCM_ICONVEH_ERROR):
(SCM_ICONVEH_QUESTION_MARK, SCM_ICONVEH_ESCAPE_SEQUENCE): store
iconveh_ilseq_hander constants as #define's
2009-08-12 09:21:55 -07:00

1721 lines
47 KiB
C
Raw Permalink Blame History

This file contains invisible Unicode characters

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

/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009 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
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library 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 this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
#include <stdio.h>
#include <ctype.h>
#include <unistr.h>
#include <uniconv.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
/* {Strings}
*/
/* Stringbufs
*
* XXX - keeping an accurate refcount during GC seems to be quite
* tricky, so we just keep score of whether a stringbuf might be
* shared, not whether it definitely is.
*
* The scheme I (mvo) tried to keep an accurate reference count would
* recount all strings that point to a stringbuf during the mark-phase
* of the GC. This was done since one cannot access the stringbuf of
* a string when that string is freed (in order to decrease the
* reference count). The memory of the stringbuf might have been
* reused already for something completely different.
*
* This recounted worked for a small number of threads beating on
* cow-strings, but it failed randomly with more than 10 threads, say.
* I couldn't figure out what went wrong, so I used the conservative
* approach implemented below.
*
* A stringbuf needs to know its length, but only so that it can be
* reported when the stringbuf is freed.
*
* There are 3 storage strategies for stringbufs: inline, outline, and
* wide.
*
* Inline strings are small 8-bit strings stored within the double
* cell itself. Outline strings are larger 8-bit strings with GC
* allocated storage. Wide strings are 32-bit strings with allocated
* storage.
*
* There was little value in making wide string inlineable, since
* there is only room for three inlined 32-bit characters. Thus wide
* stringbufs are never inlined.
*/
#define STRINGBUF_F_SHARED 0x100
#define STRINGBUF_F_INLINE 0x200
#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4
encoding. Otherwise, strings
are Latin-1. */
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_CHARS (buf) \
: STRINGBUF_OUTLINE_CHARS (buf))
#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf))
#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_LENGTH (buf) \
: STRINGBUF_OUTLINE_LENGTH (buf))
#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
#define SET_STRINGBUF_SHARED(buf) \
(SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
#if 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.
*/
#if SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
lenhist[1000]++;
#endif
if (len <= STRINGBUF_MAX_INLINE_LEN-1)
{
return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
0, 0, 0);
}
else
{
char *mem = scm_gc_malloc (len+1, "string");
mem[len] = '\0';
return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
(scm_t_bits) len, (scm_t_bits) 0);
}
}
/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
characters. */
static SCM
make_wide_stringbuf (size_t len)
{
scm_t_wchar *mem;
#if SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
lenhist[1000]++;
#endif
mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
mem[len] = 0;
return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem,
(scm_t_bits) len, (scm_t_bits) 0);
}
/* Return a new stringbuf whose underlying storage consists of the LEN+1
octets pointed to by STR (the last octet is zero). */
SCM
scm_i_take_stringbufn (char *str, size_t len)
{
scm_gc_register_collectable_memory (str, len + 1, "stringbuf");
return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
(scm_t_bits) len, (scm_t_bits) 0);
}
SCM
scm_i_stringbuf_mark (SCM buf)
{
return SCM_BOOL_F;
}
void
scm_i_stringbuf_free (SCM buf)
{
if (!STRINGBUF_INLINE (buf))
{
if (!STRINGBUF_WIDE (buf))
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
else
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf)
+ 1), "string");
}
}
/* Convert a stringbuf containing 8-bit Latin-1-encoded characters to
one containing 32-bit UCS-4-encoded characters. */
static void
widen_stringbuf (SCM buf)
{
size_t i, len;
scm_t_wchar *mem;
if (STRINGBUF_WIDE (buf))
return;
if (STRINGBUF_INLINE (buf))
{
len = STRINGBUF_INLINE_LENGTH (buf);
mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
for (i = 0; i < len; i++)
mem[i] =
(scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS (buf)[i];
mem[len] = 0;
SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
SCM_SET_CELL_WORD_1 (buf, mem);
SCM_SET_CELL_WORD_2 (buf, len);
}
else
{
len = STRINGBUF_OUTLINE_LENGTH (buf);
mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
for (i = 0; i < len; i++)
mem[i] =
(scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf)[i];
mem[len] = 0;
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
SCM_SET_CELL_WORD_1 (buf, mem);
SCM_SET_CELL_WORD_2 (buf, len);
}
}
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* 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_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
/* Read-only strings.
*/
#define RO_STRING_TAG (scm_tc7_string + 0x200)
#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)
/* 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. */
SCM
scm_i_make_string (size_t len, char **charsp)
{
SCM buf = make_stringbuf (len);
SCM res;
if (charsp)
*charsp = STRINGBUF_CHARS (buf);
res = scm_double_cell (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. */
SCM
scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
{
SCM buf = make_wide_stringbuf (len);
SCM res;
if (charsp)
*charsp = STRINGBUF_WIDE_CHARS (buf);
res = scm_double_cell (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);
}
SCM
scm_i_substring (SCM str, size_t start, size_t end)
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
}
SCM
scm_i_substring_read_only (SCM str, size_t start, size_t end)
{
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)str_start + start,
(scm_t_bits) end - start);
}
SCM
scm_i_substring_copy (SCM str, size_t start, size_t end)
{
size_t len = end - start;
SCM buf, my_buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
if (scm_i_is_narrow_string (str))
{
my_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (my_buf),
STRINGBUF_CHARS (buf) + str_start + start, len);
}
else
{
my_buf = make_wide_stringbuf (len);
u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
(scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
+ start), len);
/* Even though this string is wide, the substring may be narrow.
Consider adding code to narrow the string. */
}
scm_remember_upto_here_1 (buf);
return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
(scm_t_bits) 0, (scm_t_bits) len);
}
SCM
scm_i_substring_shared (SCM str, size_t start, size_t end)
{
if (start == 0 && end == STRING_LENGTH (str))
return str;
else
{
size_t len = end - start;
if (IS_SH_STRING (str))
{
start += STRING_START (str);
str = SH_STRING_STRING (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);
}
SCM
scm_i_string_mark (SCM str)
{
if (IS_SH_STRING (str))
return SH_STRING_STRING (str);
else
return STRING_STRINGBUF (str);
}
void
scm_i_string_free (SCM str)
{
}
/* 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);
}
/* 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)
{
return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
}
/* 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 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 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 shared, copy ORIG_STR's characters to
a new string buffer, so that it can be modified without modifying
other strings. Also, lock the string mutex. Later, one must call
scm_i_string_stop_writing to unlock the mutex. */
SCM
scm_i_string_start_writing (SCM orig_str)
{
SCM buf, str = orig_str;
size_t start;
get_str_buf_start (&str, &buf, &start);
if (IS_RO_STRING (str))
scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
/* Clone the stringbuf. */
size_t len = STRING_LENGTH (str);
SCM new_buf;
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
if (scm_i_is_narrow_string (str))
{
new_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (new_buf),
STRINGBUF_CHARS (buf) + STRING_START (str), len);
}
else
{
new_buf = make_wide_stringbuf (len);
u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
(scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
+ STRING_START (str)), len);
}
scm_i_thread_put_to_sleep ();
SET_STRING_STRINGBUF (str, new_buf);
start -= STRING_START (str);
SET_STRING_START (str, 0);
scm_i_thread_wake_up ();
buf = new_buf;
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
}
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 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 read 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)
{
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
/* 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];
}
/* 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 (chr > 0xFF && scm_i_is_narrow_string (str))
widen_stringbuf (STRING_STRINGBUF (str));
if (scm_i_is_narrow_string (str))
{
char *dst = scm_i_string_writable_chars (str);
dst[p] = (char) (unsigned char) 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 start = STRING_START (name);
size_t length = STRING_LENGTH (name);
if (IS_SH_STRING (name))
{
name = SH_STRING_STRING (name);
start += STRING_START (name);
}
buf = SYMBOL_STRINGBUF (name);
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
/* reuse buf. */
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
else
{
/* make new buf. */
if (scm_i_is_narrow_string (name))
{
SCM new_buf = make_stringbuf (length);
memcpy (STRINGBUF_CHARS (new_buf),
STRINGBUF_CHARS (buf) + start, length);
buf = new_buf;
}
else
{
SCM new_buf = make_wide_stringbuf (length);
u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
(scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start,
length);
buf = new_buf;
}
}
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));
}
/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
underlying storage. */
SCM
scm_i_c_take_symbol (char *name, size_t len,
scm_t_bits flags, unsigned long hash, SCM props)
{
SCM buf = scm_i_take_stringbufn (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 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 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_mark (SCM sym)
{
scm_gc_mark (SYMBOL_STRINGBUF (sym));
return SCM_CELL_OBJECT_3 (sym);
}
void
scm_i_symbol_free (SCM sym)
{
}
SCM
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
SCM buf = SYMBOL_STRINGBUF (sym);
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
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-shared\n"
"@code{#t} if this stringbuf is shared\n"
"@item stringbuf-inline\n"
"@code{#t} if this stringbuf's characters are stored in the\n"
"cell itself, or @code{#f} if they were allocated in memory\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, e10;
SCM buf;
SCM_VALIDATE_STRING (1, str);
/* String info */
e1 = scm_cons (scm_from_locale_symbol ("string"),
str);
e2 = scm_cons (scm_from_locale_symbol ("start"),
scm_from_size_t (STRING_START (str)));
e3 = scm_cons (scm_from_locale_symbol ("length"),
scm_from_size_t (STRING_LENGTH (str)));
if (IS_SH_STRING (str))
{
e4 = scm_cons (scm_from_locale_symbol ("shared"),
SH_STRING_STRING (str));
buf = STRING_STRINGBUF (SH_STRING_STRING (str));
}
else
{
e4 = scm_cons (scm_from_locale_symbol ("shared"),
SCM_BOOL_F);
buf = STRING_STRINGBUF (str);
}
if (IS_RO_STRING (str))
e5 = scm_cons (scm_from_locale_symbol ("read-only"),
SCM_BOOL_T);
else
e5 = scm_cons (scm_from_locale_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);
memcpy (cbuf, STRINGBUF_CHARS (buf), len);
e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
sbc);
}
else
{
size_t len = STRINGBUF_LENGTH (buf);
scm_t_wchar *cbuf;
SCM sbc = scm_i_make_wide_string (len, &cbuf);
u32_cpy ((scm_t_uint32 *) cbuf,
(scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
sbc);
}
e7 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
scm_from_size_t (STRINGBUF_LENGTH (buf)));
if (STRINGBUF_SHARED (buf))
e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_T);
else
e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_F);
if (STRINGBUF_INLINE (buf))
e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
SCM_BOOL_T);
else
e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
SCM_BOOL_F);
if (STRINGBUF_WIDE (buf))
e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_T);
else
e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_F);
return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, 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-shared\n"
"@code{#t} if this stringbuf is shared\n"
"@item stringbuf-inline\n"
"@code{#t} if this stringbuf's characters are stored in the\n"
"cell itself, or @code{#f} if they were allocated in memory\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, e8;
SCM buf;
SCM_VALIDATE_SYMBOL (1, sym);
e1 = scm_cons (scm_from_locale_symbol ("symbol"),
sym);
e2 = scm_cons (scm_from_locale_symbol ("hash"),
scm_from_ulong (scm_i_symbol_hash (sym)));
e3 = scm_cons (scm_from_locale_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);
memcpy (cbuf, STRINGBUF_CHARS (buf), len);
e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
sbc);
}
else
{
size_t len = STRINGBUF_LENGTH (buf);
scm_t_wchar *cbuf;
SCM sbc = scm_i_make_wide_string (len, &cbuf);
u32_cpy ((scm_t_uint32 *) cbuf,
(scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
sbc);
}
e5 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
scm_from_size_t (STRINGBUF_LENGTH (buf)));
if (STRINGBUF_SHARED (buf))
e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_T);
else
e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
SCM_BOOL_F);
if (STRINGBUF_INLINE (buf))
e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
SCM_BOOL_T);
else
e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
SCM_BOOL_F);
if (STRINGBUF_WIDE (buf))
e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_T);
else
e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
SCM_BOOL_F);
return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, SCM_UNDEFINED);
}
#undef FUNC_NAME
#if 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 rest;
size_t len;
size_t p = 0;
long i;
/* 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);
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;
result = scm_i_make_string (len, NULL);
result = scm_i_string_start_writing (result);
while (len > 0 && scm_is_pair (rest))
{
SCM elt = SCM_CAR (rest);
scm_i_string_set_x (result, p, SCM_CHAR (elt));
p++;
rest = SCM_CDR (rest);
len--;
scm_remember_upto_here_1 (elt);
}
scm_i_string_stop_writing ();
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 @var{string} are unspecified.")
#define FUNC_NAME s_scm_make_string
{
return scm_c_make_string (scm_to_size_t (k), chr);
}
#undef FUNC_NAME
SCM
scm_c_make_string (size_t len, SCM chr)
#define FUNC_NAME NULL
{
size_t p;
SCM res = scm_i_make_string (len, NULL);
if (!SCM_UNBNDP (chr))
{
SCM_VALIDATE_CHAR (0, chr);
res = scm_i_string_start_writing (res);
for (p = 0; p < len; p++)
scm_i_string_set_x (res, p, SCM_CHAR (chr));
scm_i_string_stop_writing ();
}
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_width, "string-width", 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_width
{
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 len = 0;
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 (!scm_i_is_narrow_string (s))
wide = 1;
}
data.narrow = NULL;
if (!wide)
res = scm_i_make_string (len, &data.narrow);
else
res = scm_i_make_wide_string (len, &data.wide);
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 (!wide)
{
memcpy (data.narrow, scm_i_string_chars (s), len);
data.narrow += len;
}
else
{
if (scm_i_is_narrow_string (s))
{
for (i = 0; i < scm_i_string_length (s); i++)
data.wide[i] = (unsigned char) scm_i_string_chars (s)[i];
}
else
u32_cpy ((scm_t_uint32 *) data.wide,
(scm_t_uint32 *) scm_i_string_wide_chars (s), len);
data.wide += len;
}
scm_remember_upto_here_1 (s);
}
return res;
}
#undef FUNC_NAME
int
scm_is_string (SCM obj)
{
return IS_STRING (obj);
}
SCM
scm_from_locale_stringn (const char *str, size_t len)
{
SCM res;
char *dst;
if (len == (size_t) -1)
len = strlen (str);
if (len == 0)
return scm_nullstr;
res = scm_i_make_string (len, &dst);
memcpy (dst, str, len);
return res;
}
SCM
scm_from_locale_string (const char *str)
{
if (str == NULL)
return scm_nullstr;
return scm_from_locale_stringn (str, -1);
}
/* Create a new scheme string from the C string STR. The memory of
STR may be used directly as storage for the new string. */
SCM
scm_take_locale_stringn (char *str, size_t len)
{
SCM buf, res;
if (len == (size_t) -1)
len = strlen (str);
else
{
/* Ensure STR is null terminated. A realloc for 1 extra byte should
often be satisfied from the alignment padding after the block, with
no actual data movement. */
str = scm_realloc (str, len + 1);
str[len] = '\0';
}
buf = scm_i_take_stringbufn (str, len);
res = scm_double_cell (STRING_TAG,
SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
SCM
scm_take_locale_string (char *str)
{
return scm_take_locale_stringn (str, -1);
}
/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
and \UXXXXXX. */
static void
unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
{
char *before, *after;
size_t i, j;
before = *bufp;
after = *bufp;
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;
after = scm_realloc (after, j);
}
char *
scm_to_locale_stringn (SCM str, size_t * lenp)
{
const char *enc;
/* In the future, enc will hold the port's encoding. */
enc = NULL;
return scm_to_stringn (str, lenp, enc,
SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
}
/* Low-level scheme to C string conversion function. */
char *
scm_to_stringn (SCM str, size_t * lenp, const char *encoding,
scm_t_string_failed_conversion_handler handler)
{
static const char iso[11] = "ISO-8859-1";
char *buf;
size_t ilen, len, i;
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
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))
{
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;
buf = u32_conv_to_encoding (iso,
(enum iconv_ilseq_handler) handler,
(scm_t_uint32 *) scm_i_string_wide_chars (str),
ilen, NULL, NULL, &len);
if (buf == NULL)
scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
scm_list_2 (scm_from_locale_string (iso), str));
if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
unistring_escapes_to_guile_escapes (&buf, &len);
if (lenp)
*lenp = len;
else
{
buf = scm_realloc (buf, len + 1);
buf[len] = '\0';
}
scm_remember_upto_here_1 (str);
return buf;
}
char *
scm_to_locale_string (SCM str)
{
return scm_to_locale_stringn (str, NULL);
}
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;
}
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array 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. */
char **
scm_i_allocate_string_pointers (SCM list)
{
char **result;
int len = scm_ilength (list);
int i;
if (len < 0)
scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
scm_dynwind_begin (0);
result = (char **) scm_malloc ((len + 1) * sizeof (char *));
result[len] = NULL;
scm_dynwind_unwind_handler (free, result, 0);
/* The list might be have been modified in another thread, so
we check LIST before each access.
*/
for (i = 0; i < len && scm_is_pair (list); i++)
{
result[i] = scm_to_locale_string (SCM_CAR (list));
list = SCM_CDR (list);
}
scm_dynwind_end ();
return result;
}
void
scm_i_free_string_pointers (char **pointers)
{
int i;
for (i = 0; pointers[i]; i++)
free (pointers[i]);
free (pointers);
}
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);
}
#if SCM_ENABLE_DEPRECATED
/* When these definitions are removed, it becomes reasonable to use
read-only strings for string literals. For that, change the reader
to create string literals with scm_c_substring_read_only instead of
with scm_c_substring_copy.
*/
int
scm_i_deprecated_stringp (SCM str)
{
scm_c_issue_deprecation_warning
("SCM_STRINGP is deprecated. Use scm_is_string instead.");
return scm_is_string (str);
}
char *
scm_i_deprecated_string_chars (SCM str)
{
char *chars;
scm_c_issue_deprecation_warning
("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
/* We don't accept shared substrings here since they are not
null-terminated.
*/
if (IS_SH_STRING (str))
scm_misc_error (NULL,
"SCM_STRING_CHARS does not work with shared substrings.",
SCM_EOL);
/* We explicitly test for read-only strings to produce a better
error message.
*/
if (IS_RO_STRING (str))
scm_misc_error (NULL,
"SCM_STRING_CHARS does not work with read-only strings.",
SCM_EOL);
/* The following is still wrong, of course...
*/
str = scm_i_string_start_writing (str);
chars = scm_i_string_writable_chars (str);
scm_i_string_stop_writing ();
return chars;
}
size_t
scm_i_deprecated_string_length (SCM str)
{
scm_c_issue_deprecation_warning
("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
return scm_c_string_length (str);
}
#endif
void
scm_init_strings ()
{
scm_nullstr = scm_i_make_string (0, NULL);
#include "libguile/strings.x"
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/
View git blame Copy permalink