mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 08:10:17 +02:00
Add Unicode strings and symbols
This adds full Unicode strings as a datatype, and it adds some
minimal functionality. The terminal and port encoding is assumed
to be ISO-8859-1. Non-ISO-8859-1 characters are written or
input as string character escapes.
The string character escapes now have 3 forms: \xXX \uXXXX and
\UXXXXXX, for unprintable characters that have 2, 4 or 6 hex digits.
The process for writing to strings has been modified. There is now a
function scm_i_string_start_writing that does the copy-on-write
conversion if necessary.
To compile strings that may be wide, the VM storage of strings and
string-likes has changed.
Most string-using functions have not yet been updated and may break
when used with wide strings.
* module/language/assembly/compile-bytecode.scm (write-bytecode):
use variable width string bytecode format
* module/language/assembly.scm (byte-length): use variable width
bytecode format
* libguile/vm-i-loader.c (load-string, load-symbol):
(load-keyword, define): use variable-width bytecode format
* libguile/vm-engine.h (FETCH_WIDTH): new macro
* libguile/strings.h: new declarations
* libguile/strings.c (make_wide_stringbuf): new function
(widen_stringbuf): new function
(scm_i_make_wide_string): new function
(scm_i_is_narrow_string): new function
(scm_i_string_wide_chars): new function
(scm_i_string_start_writing): new function
(scm_i_string_ref): new function
(scm_i_string_set_x): new function
(scm_i_is_narrow_symbol): new function
(scm_i_symbol_wide_chars, scm_i_symbol_ref): new function
(scm_string_width): new function
(unistring_escapes_to_guile_escapes): new function
(scm_to_stringn): new function
(scm_i_stringbuf_free): modify for wide strings
(scm_i_substring_copy): modify for wide strings
(scm_i_string_chars, scm_string_append): modify for wide strings
(scm_i_make_symbol, scm_to_locale_stringn): modify for wide strings
(scm_string_dump, scm_symbol_dump, scm_to_locale_stringbuf):
(scm_string, scm_i_deprecated_string_chars): modify for wide strings
(scm_from_locale_string, scm_from_locale_stringn): add null test
* libguile/srfi-13.c: add calls for scm_i_string_start_writing for
each call of scm_i_string_stop_writing
(scm_string_for_each): modify for wide strings
* libguile/socket.c: add calls for scm_i_string_start_writing for each
call of scm_i_string_stop_writing
* libguile/rw.c: add calls for scm_i_string_start_writing for each
call of scm_i_string_stop_writing
* libguile/read.c (scm_read_string): allow reading of wide strings
* libguile/print.h: add declaration for scm_charprint
* libguile/print.c (iprin1): print wide strings and add new string
escapes
(scm_charprint): new function
* libguile/ports.h: new declarations for scm_lfwrite_substr and
scm_lfwrite_str
* libguile/ports.c (update_port_lf): new function
(scm_lfwrite): use update_port_lf
(scm_lfwrite_substr): new function
(scm_lfwrite_str): new function
* test-suite/tests/asm-to-bytecode.test ("compiler"): add string
width byte to sting-like asm tests
This commit is contained in:
Michael Gran
parent
a876e7dcea
commit
9c44cd4559
15 changed files with 1046 additions and 306 deletions
|
|
@ -24,6 +24,8 @@
|
|||
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
#include <ctype.h>
|
||||
#include <unistr.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/chars.h"
|
||||
|
|
@ -69,10 +71,12 @@
|
|||
|
||||
#define STRINGBUF_F_SHARED 0x100
|
||||
#define STRINGBUF_F_INLINE 0x200
|
||||
#define STRINGBUF_F_WIDE 0x400
|
||||
|
||||
#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))
|
||||
|
|
@ -82,6 +86,7 @@
|
|||
#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))
|
||||
|
|
@ -126,6 +131,23 @@ make_stringbuf (size_t len)
|
|||
}
|
||||
}
|
||||
|
||||
static SCM
|
||||
make_wide_stringbuf (size_t len)
|
||||
{
|
||||
scm_t_wchar *mem;
|
||||
#if SCM_DEBUG
|
||||
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
|
||||
|
|
@ -147,8 +169,58 @@ void
|
|||
scm_i_stringbuf_free (SCM buf)
|
||||
{
|
||||
if (!STRINGBUF_INLINE (buf))
|
||||
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
|
||||
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
|
||||
{
|
||||
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");
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
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;
|
||||
|
|
@ -195,6 +267,18 @@ scm_i_make_string (size_t len, char **charsp)
|
|||
return res;
|
||||
}
|
||||
|
||||
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)
|
||||
{
|
||||
|
|
@ -253,12 +337,24 @@ scm_i_substring_copy (SCM str, size_t start, size_t end)
|
|||
SCM buf, my_buf;
|
||||
size_t str_start;
|
||||
get_str_buf_start (&str, &buf, &str_start);
|
||||
my_buf = make_stringbuf (len);
|
||||
memcpy (STRINGBUF_CHARS (my_buf),
|
||||
STRINGBUF_CHARS (buf) + str_start + start, len);
|
||||
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 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);
|
||||
return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
|
||||
(scm_t_bits) 0, (scm_t_bits) len);
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
@ -330,17 +426,45 @@ scm_i_string_length (SCM str)
|
|||
return STRING_LENGTH (str);
|
||||
}
|
||||
|
||||
int
|
||||
scm_i_is_narrow_string (SCM str)
|
||||
{
|
||||
return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
|
||||
}
|
||||
|
||||
const char *
|
||||
scm_i_string_chars (SCM str)
|
||||
{
|
||||
SCM buf;
|
||||
size_t start;
|
||||
get_str_buf_start (&str, &buf, &start);
|
||||
return STRINGBUF_CHARS (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;
|
||||
}
|
||||
|
||||
char *
|
||||
scm_i_string_writable_chars (SCM orig_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. */
|
||||
SCM
|
||||
scm_i_string_start_writing (SCM orig_str)
|
||||
{
|
||||
SCM buf, str = orig_str;
|
||||
size_t start;
|
||||
|
|
@ -352,18 +476,26 @@ scm_i_string_writable_chars (SCM orig_str)
|
|||
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
|
||||
if (STRINGBUF_SHARED (buf))
|
||||
{
|
||||
/* Clone stringbuf. For this, we put all threads to sleep.
|
||||
*/
|
||||
|
||||
/* Clone the stringbuf. */
|
||||
size_t len = STRING_LENGTH (str);
|
||||
SCM new_buf;
|
||||
|
||||
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
|
||||
|
||||
new_buf = make_stringbuf (len);
|
||||
memcpy (STRINGBUF_CHARS (new_buf),
|
||||
STRINGBUF_CHARS (buf) + STRING_START (str), len);
|
||||
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);
|
||||
|
|
@ -374,8 +506,39 @@ scm_i_string_writable_chars (SCM orig_str)
|
|||
|
||||
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
|
||||
}
|
||||
return orig_str;
|
||||
}
|
||||
|
||||
return STRINGBUF_CHARS (buf) + start;
|
||||
/* Return a pointer to the chars of a string that fits in a Latin-1
|
||||
encoding. */
|
||||
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 Unicode 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));
|
||||
}
|
||||
|
||||
void
|
||||
|
|
@ -384,6 +547,34 @@ scm_i_string_stop_writing (void)
|
|||
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
|
||||
}
|
||||
|
||||
/* Return the Xth character is C. */
|
||||
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];
|
||||
}
|
||||
|
||||
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
|
||||
|
|
@ -418,10 +609,21 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
|
|||
else
|
||||
{
|
||||
/* make new buf. */
|
||||
SCM new_buf = make_stringbuf (length);
|
||||
memcpy (STRINGBUF_CHARS (new_buf),
|
||||
STRINGBUF_CHARS (buf) + start, length);
|
||||
buf = 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));
|
||||
|
|
@ -466,11 +668,40 @@ scm_c_symbol_length (SCM sym)
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
int
|
||||
scm_i_is_narrow_symbol (SCM sym)
|
||||
{
|
||||
SCM buf;
|
||||
|
||||
buf = SYMBOL_STRINGBUF (sym);
|
||||
return !STRINGBUF_WIDE (buf);
|
||||
}
|
||||
|
||||
const char *
|
||||
scm_i_symbol_chars (SCM sym)
|
||||
{
|
||||
SCM buf = SYMBOL_STRINGBUF (sym);
|
||||
return STRINGBUF_CHARS (buf);
|
||||
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 Unicode codepoints 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
|
||||
|
|
@ -496,6 +727,15 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end)
|
|||
(scm_t_bits)start, (scm_t_bits) end - start);
|
||||
}
|
||||
|
||||
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
|
||||
*/
|
||||
|
||||
|
|
@ -505,15 +745,17 @@ SCM scm_sys_string_dump (SCM);
|
|||
SCM scm_sys_symbol_dump (SCM);
|
||||
SCM scm_sys_stringbuf_hist (void);
|
||||
|
||||
SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
|
||||
(SCM str),
|
||||
"")
|
||||
SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "")
|
||||
#define FUNC_NAME s_scm_sys_string_dump
|
||||
{
|
||||
SCM_VALIDATE_STRING (1, str);
|
||||
fprintf (stderr, "%p:\n", str);
|
||||
fprintf (stderr, " start: %u\n", STRING_START (str));
|
||||
fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
|
||||
if (scm_i_is_narrow_string (str))
|
||||
fprintf (stderr, " format: narrow\n");
|
||||
else
|
||||
fprintf (stderr, " format: wide\n");
|
||||
if (IS_SH_STRING (str))
|
||||
{
|
||||
fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
|
||||
|
|
@ -524,36 +766,54 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
|
|||
{
|
||||
SCM buf = STRING_STRINGBUF (str);
|
||||
fprintf (stderr, " buf: %p\n", buf);
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
|
||||
if (scm_i_is_narrow_string (str))
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
|
||||
else
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf));
|
||||
fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
|
||||
fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
|
||||
if (STRINGBUF_SHARED (buf))
|
||||
fprintf (stderr, " shared: true\n");
|
||||
else
|
||||
fprintf (stderr, " shared: false\n");
|
||||
if (STRINGBUF_INLINE (buf))
|
||||
fprintf (stderr, " inline: true\n");
|
||||
else
|
||||
fprintf (stderr, " inline: false\n");
|
||||
|
||||
}
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
|
||||
(SCM sym),
|
||||
"")
|
||||
SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "")
|
||||
#define FUNC_NAME s_scm_sys_symbol_dump
|
||||
{
|
||||
SCM_VALIDATE_SYMBOL (1, sym);
|
||||
fprintf (stderr, "%p:\n", sym);
|
||||
fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
|
||||
if (scm_i_is_narrow_symbol (sym))
|
||||
fprintf (stderr, " format: narrow\n");
|
||||
else
|
||||
fprintf (stderr, " format: wide\n");
|
||||
{
|
||||
SCM buf = SYMBOL_STRINGBUF (sym);
|
||||
fprintf (stderr, " buf: %p\n", buf);
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
|
||||
if (scm_i_is_narrow_symbol (sym))
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
|
||||
else
|
||||
fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf));
|
||||
fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
|
||||
fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
|
||||
if (STRINGBUF_SHARED (buf))
|
||||
fprintf (stderr, " shared: true\n");
|
||||
else
|
||||
fprintf (stderr, " shared: false\n");
|
||||
|
||||
}
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
|
||||
#define FUNC_NAME s_scm_sys_stringbuf_hist
|
||||
{
|
||||
int i;
|
||||
|
|
@ -589,29 +849,46 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
|
|||
#define FUNC_NAME s_scm_string
|
||||
{
|
||||
SCM result;
|
||||
SCM rest;
|
||||
size_t len;
|
||||
char *data;
|
||||
size_t p = 0;
|
||||
long i;
|
||||
|
||||
{
|
||||
long i = scm_ilength (chrs);
|
||||
/* Verify that this is a list of chars. */
|
||||
i = scm_ilength (chrs);
|
||||
len = (size_t) i;
|
||||
rest = chrs;
|
||||
|
||||
SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
|
||||
len = i;
|
||||
}
|
||||
|
||||
result = scm_i_make_string (len, &data);
|
||||
while (len > 0 && scm_is_pair (chrs))
|
||||
SCM_ASSERT (len >= 0, chrs, SCM_ARG1, FUNC_NAME);
|
||||
while (len > 0 && scm_is_pair (rest))
|
||||
{
|
||||
SCM elt = SCM_CAR (chrs);
|
||||
|
||||
SCM elt = SCM_CAR (rest);
|
||||
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
|
||||
*data++ = SCM_CHAR (elt);
|
||||
chrs = SCM_CDR (chrs);
|
||||
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 (chrs))
|
||||
if (!scm_is_null (rest))
|
||||
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
|
||||
|
||||
return result;
|
||||
|
|
@ -634,13 +911,16 @@ SCM
|
|||
scm_c_make_string (size_t len, SCM chr)
|
||||
#define FUNC_NAME NULL
|
||||
{
|
||||
char *dst;
|
||||
SCM res = scm_i_make_string (len, &dst);
|
||||
size_t p;
|
||||
SCM res = scm_i_make_string (len, NULL);
|
||||
|
||||
if (!SCM_UNBNDP (chr))
|
||||
{
|
||||
SCM_VALIDATE_CHAR (0, chr);
|
||||
memset (dst, SCM_CHAR (chr), len);
|
||||
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;
|
||||
|
|
@ -657,6 +937,20 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
|
|||
}
|
||||
#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)
|
||||
{
|
||||
|
|
@ -667,8 +961,8 @@ scm_c_string_length (SCM 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}.")
|
||||
"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;
|
||||
|
|
@ -682,7 +976,10 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
|
|||
else
|
||||
scm_out_of_range (NULL, k);
|
||||
|
||||
return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
|
||||
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
|
||||
|
||||
|
|
@ -691,14 +988,18 @@ 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));
|
||||
return SCM_MAKE_CHAR (scm_i_string_chars (str)[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}.")
|
||||
"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;
|
||||
|
|
@ -713,11 +1014,10 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
|
|||
scm_out_of_range (NULL, k);
|
||||
|
||||
SCM_VALIDATE_CHAR (3, chr);
|
||||
{
|
||||
char *dst = scm_i_string_writable_chars (str);
|
||||
dst[idx] = SCM_CHAR (chr);
|
||||
scm_i_string_stop_writing ();
|
||||
}
|
||||
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
|
||||
|
|
@ -727,11 +1027,9 @@ 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));
|
||||
{
|
||||
char *dst = scm_i_string_writable_chars (str);
|
||||
dst[p] = SCM_CHAR (chr);
|
||||
scm_i_string_stop_writing ();
|
||||
}
|
||||
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,
|
||||
|
|
@ -832,31 +1130,55 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
|
|||
|
||||
SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
|
||||
(SCM args),
|
||||
"Return a newly allocated string whose characters form the\n"
|
||||
"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 i = 0;
|
||||
size_t len = 0;
|
||||
int wide = 0;
|
||||
SCM l, s;
|
||||
char *data;
|
||||
scm_t_wchar *wdata;
|
||||
int i;
|
||||
|
||||
SCM_VALIDATE_REST_ARGUMENT (args);
|
||||
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
|
||||
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
|
||||
{
|
||||
s = SCM_CAR (l);
|
||||
SCM_VALIDATE_STRING (SCM_ARGn, s);
|
||||
i += scm_i_string_length (s);
|
||||
len += scm_i_string_length (s);
|
||||
if (!scm_i_is_narrow_string (s))
|
||||
wide = 1;
|
||||
}
|
||||
res = scm_i_make_string (i, &data);
|
||||
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
|
||||
if (!wide)
|
||||
res = scm_i_make_string (len, &data);
|
||||
else
|
||||
res = scm_i_make_wide_string (len, &wdata);
|
||||
|
||||
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);
|
||||
memcpy (data, scm_i_string_chars (s), len);
|
||||
data += len;
|
||||
if (!wide)
|
||||
{
|
||||
memcpy (data, scm_i_string_chars (s), len);
|
||||
data += len;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (scm_i_is_narrow_string (s))
|
||||
{
|
||||
for (i = 0; i < scm_i_string_length (s); i++)
|
||||
wdata[i] = (unsigned char) scm_i_string_chars (s)[i];
|
||||
}
|
||||
else
|
||||
u32_cpy ((scm_t_uint32 *) wdata,
|
||||
(scm_t_uint32 *) scm_i_string_wide_chars (s), len);
|
||||
wdata += len;
|
||||
}
|
||||
scm_remember_upto_here_1 (s);
|
||||
}
|
||||
return res;
|
||||
|
|
@ -875,8 +1197,11 @@ scm_from_locale_stringn (const char *str, size_t len)
|
|||
SCM res;
|
||||
char *dst;
|
||||
|
||||
if (len == (size_t)-1)
|
||||
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;
|
||||
|
|
@ -885,6 +1210,9 @@ scm_from_locale_stringn (const char *str, size_t len)
|
|||
SCM
|
||||
scm_from_locale_string (const char *str)
|
||||
{
|
||||
if (str == NULL)
|
||||
return scm_nullstr;
|
||||
|
||||
return scm_from_locale_stringn (str, -1);
|
||||
}
|
||||
|
||||
|
|
@ -893,21 +1221,20 @@ scm_take_locale_stringn (char *str, size_t len)
|
|||
{
|
||||
SCM buf, res;
|
||||
|
||||
if (len == (size_t)-1)
|
||||
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 = 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);
|
||||
SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
|
@ -917,33 +1244,143 @@ scm_take_locale_string (char *str)
|
|||
return scm_take_locale_stringn (str, -1);
|
||||
}
|
||||
|
||||
char *
|
||||
scm_to_locale_stringn (SCM str, size_t *lenp)
|
||||
/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
|
||||
and \UXXXXXX. */
|
||||
static void
|
||||
unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
|
||||
{
|
||||
char *res;
|
||||
size_t len;
|
||||
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 (before[i + 4]);
|
||||
after[j + 3] = tolower (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 (before[i + 4]);
|
||||
after[j + 3] = tolower (before[i + 5]);
|
||||
after[j + 4] = tolower (before[i + 6]);
|
||||
after[j + 5] = tolower (before[i + 7]);
|
||||
after[j + 6] = tolower (before[i + 8]);
|
||||
after[j + 7] = tolower (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, iconveh_escape_sequence);
|
||||
}
|
||||
|
||||
/* Low-level scheme to C string conversion function. */
|
||||
char *
|
||||
scm_to_stringn (SCM str, size_t * lenp, const char *encoding,
|
||||
enum iconv_ilseq_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");
|
||||
len = scm_i_string_length (str);
|
||||
res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
|
||||
memcpy (res, scm_i_string_chars (str), len);
|
||||
if (lenp == NULL)
|
||||
ilen = scm_i_string_length (str);
|
||||
|
||||
if (ilen == 0)
|
||||
{
|
||||
res[len] = '\0';
|
||||
if (strlen (res) != len)
|
||||
{
|
||||
free (res);
|
||||
scm_misc_error (NULL,
|
||||
"string contains #\\nul character: ~S",
|
||||
scm_list_1 (str));
|
||||
}
|
||||
buf = scm_malloc (1);
|
||||
buf[0] = '\0';
|
||||
if (lenp)
|
||||
*lenp = 0;
|
||||
return buf;
|
||||
}
|
||||
else
|
||||
|
||||
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,
|
||||
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 == iconveh_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 res;
|
||||
return buf;
|
||||
}
|
||||
|
||||
char *
|
||||
|
|
@ -956,18 +1393,21 @@ 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");
|
||||
len = scm_i_string_length (str);
|
||||
memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
|
||||
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
|
||||
scm_makfromstrs (int argc, char **argv)
|
||||
{
|
||||
int i = argc;
|
||||
|
|
@ -1081,6 +1521,7 @@ scm_i_deprecated_string_chars (SCM str)
|
|||
|
||||
/* 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;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue