-/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004 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
\f
#include <string.h>
+#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
/* {Strings}
*/
-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
+
+/* 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 wether 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.
+ *
+ * Stringbufs (and strings) are not stored very compactly: a stringbuf
+ * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
+ * information. As a compensation, the code below is made more
+ * complicated by storing small strings inline in the double cell of a
+ * stringbuf. So we have fixstrings and bigstrings...
+ */
+
+#define STRINGBUF_F_SHARED 0x100
+#define STRINGBUF_F_INLINE 0x200
+
+#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_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_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_DEBUG
+static size_t lenhist[1001];
+#endif
+
+static SCM
+make_stringbuf (size_t len)
{
- return scm_from_bool (SCM_I_STRINGP (obj));
-}
-#undef FUNC_NAME
+ /* 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_DEBUG
+ 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);
+ }
+}
-SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
+SCM
+scm_i_stringbuf_mark (SCM buf)
+{
+ return SCM_BOOL_F;
+}
-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
+void
+scm_i_stringbuf_free (SCM buf)
{
- SCM result;
+ if (!STRINGBUF_INLINE (buf))
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
+}
- {
- long i = scm_ilength (chrs);
+SCM_MUTEX (stringbuf_write_mutex);
- SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- result = scm_allocate_string (i);
- }
+/* Copy-on-write strings.
+ */
- {
- unsigned char *data = SCM_I_STRING_UCHARS (result);
+#define STRING_TAG scm_tc7_string
- while (!SCM_NULLP (chrs))
- {
- SCM elt = SCM_CAR (chrs);
+#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))
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- *data++ = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
- }
- }
- return result;
+#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)
+
+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;
}
-#undef FUNC_NAME
+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));
+}
-/* 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)
+SCM
+scm_i_substring (SCM str, size_t start, size_t end)
{
- int i = argc;
- SCM lst = SCM_EOL;
- if (0 > i)
- for (i = 0; argv[i]; i++);
- while (i--)
- lst = scm_cons (scm_mem2string (argv[i], strlen (argv[i])), lst);
- return lst;
+ SCM buf = STRING_STRINGBUF (str);
+ scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+ (scm_t_bits)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 = STRING_STRINGBUF (str);
+ SCM my_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (my_buf), STRINGBUF_CHARS (buf) + start, len);
+ scm_remember_upto_here_1 (buf);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
+ (scm_t_bits)0, (scm_t_bits) len);
+}
-/* This function must only be applied to memory obtained via malloc,
- since the GC is going to apply `free' to it when the string is
- dropped.
+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);
+}
- Also, s[len] must be `\0', since we promise that strings are
- null-terminated. Perhaps we could handle non-null-terminated
- strings by claiming they're shared substrings of a string we just
- made up. */
SCM
-scm_take_str (char *s, size_t len)
-#define FUNC_NAME "scm_take_str"
+scm_c_substring_copy (SCM str, size_t start, size_t end)
{
- SCM answer;
+ validate_substring_args (str, start, end);
+ return scm_i_substring_copy (str, start, end);
+}
+
+/* Mutation-sharing substrings
+ */
- SCM_ASSERT_RANGE (2, scm_from_ulong (len), len <= SCM_STRING_MAX_LENGTH);
+#define SH_STRING_TAG (scm_tc7_string + 0x100)
- answer = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) s);
- scm_gc_register_collectable_memory (s, len+1, "string");
+#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
+/* START and LENGTH as for STRINGs. */
- return answer;
+#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+
+SCM
+scm_i_substring_shared (SCM str, size_t start, size_t end)
+{
+ if (start == 0 && end == STRING_LENGTH (str))
+ return str;
+ else
+ {
+ SCM res = scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
+ (scm_t_bits)start, (scm_t_bits) end - start);
+ return res;
+ }
}
-#undef FUNC_NAME
+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);
+}
-/* `s' must be a malloc'd string. See scm_take_str. */
SCM
-scm_take0str (char *s)
+scm_i_string_mark (SCM str)
{
- return scm_take_locale_string (s);
+ if (IS_SH_STRING (str))
+ return SH_STRING_STRING (str);
+ else
+ return STRING_STRINGBUF (str);
}
+void
+scm_i_string_free (SCM str)
+{
+}
-SCM
-scm_mem2string (const char *src, size_t len)
+/* Internal accessors
+ */
+
+size_t
+scm_i_string_length (SCM str)
{
- return scm_from_locale_stringn (src, len);
+ return STRING_LENGTH (str);
}
+const char *
+scm_i_string_chars (SCM str)
+{
+ SCM buf;
+ size_t start = STRING_START(str);
+ if (IS_SH_STRING (str))
+ {
+ str = SH_STRING_STRING (str);
+ start += STRING_START (str);
+ }
+ buf = STRING_STRINGBUF (str);
+ return STRINGBUF_CHARS (buf) + start;
+}
-SCM
-scm_str2string (const char *src)
+char *
+scm_i_string_writable_chars (SCM str)
{
- return scm_from_locale_string (src);
+ SCM buf;
+ size_t start = STRING_START(str);
+ if (IS_SH_STRING (str))
+ {
+ str = SH_STRING_STRING (str);
+ start += STRING_START (str);
+ }
+ buf = STRING_STRINGBUF (str);
+ scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ if (STRINGBUF_SHARED (buf))
+ {
+ /* Clone stringbuf. For this, we put all threads to sleep.
+ */
+
+ size_t len = STRING_LENGTH (str);
+ SCM new_buf;
+
+ scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+
+ new_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_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_plugin_mutex_lock (&stringbuf_write_mutex);
+ }
+
+ return STRINGBUF_CHARS (buf) + start;
}
+void
+scm_i_string_stop_writing (void)
+{
+ scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+}
-SCM
-scm_makfrom0str (const char *src)
+/* 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, 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_plugin_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ }
+ else
+ {
+ /* make new buf. */
+ SCM new_buf = make_stringbuf (length);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + start, length);
+ buf = new_buf;
+ }
+ return scm_double_cell (scm_tc7_symbol, SCM_UNPACK (buf),
+ (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
+size_t
+scm_i_symbol_length (SCM sym)
{
- if (!src) return SCM_BOOL_F;
- return scm_from_locale_string (src);
+ return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
}
+const char *
+scm_i_symbol_chars (SCM sym)
+{
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ return STRINGBUF_CHARS (buf);
+}
-SCM
-scm_makfrom0str_opt (const char *src)
+SCM
+scm_i_symbol_mark (SCM sym)
{
- return scm_makfrom0str (src);
+ scm_gc_mark (SYMBOL_STRINGBUF (sym));
+ return SCM_CELL_OBJECT_3 (sym);
}
+void
+scm_i_symbol_free (SCM sym)
+{
+}
SCM
-scm_allocate_string (size_t len)
-#define FUNC_NAME "scm_allocate_string"
+scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
- char *mem;
- SCM s;
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+ (scm_t_bits)start, (scm_t_bits) end - start);
+}
- SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= SCM_STRING_MAX_LENGTH);
+/* Debugging
+ */
- mem = (char *) scm_gc_malloc (len + 1, "string");
- mem[len] = 0;
+#if SCM_DEBUG
- s = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) mem);
+SCM scm_sys_string_dump (SCM);
+SCM scm_sys_symbol_dump (SCM);
+SCM scm_sys_stringbuf_hist (void);
- return s;
+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 (IS_SH_STRING (str))
+ {
+ fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
+ fprintf (stderr, "\n");
+ scm_sys_string_dump (SH_STRING_STRING (str));
+ }
+ else
+ {
+ SCM buf = STRING_STRINGBUF (str);
+ fprintf (stderr, " buf: %p\n", buf);
+ fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
+ fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
+ fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+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));
+ {
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ fprintf (stderr, " buf: %p\n", buf);
+ fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
+ fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
+ fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_sys_string_dump
+{
+ 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
+
+\f
+
+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;
+ size_t len;
+ char *data;
+
+ {
+ long i = scm_ilength (chrs);
+
+ SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
+ len = i;
+ }
+
+ result = scm_i_make_string (len, &data);
+ while (len > 0 && SCM_CONSP (chrs))
+ {
+ SCM elt = SCM_CAR (chrs);
+
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ *data++ = SCM_CHAR (elt);
+ chrs = SCM_CDR (chrs);
+ len--;
+ }
+ if (len > 0)
+ scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
+ if (!SCM_NULLP (chrs))
+ 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),
"of the @var{string} are unspecified.")
#define FUNC_NAME s_scm_make_string
{
- size_t i = scm_to_unsigned_integer (k, 0, SCM_STRING_MAX_LENGTH);
- SCM res = scm_allocate_string (i);
+ 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
+{
+ char *dst;
+ SCM res = scm_i_make_string (len, &dst);
if (!SCM_UNBNDP (chr))
{
- unsigned char *dst;
-
- SCM_VALIDATE_CHAR (2, chr);
-
- dst = SCM_I_STRING_UCHARS (res);
- memset (dst, SCM_CHAR (chr), i);
+ SCM_VALIDATE_CHAR (0, chr);
+ memset (dst, SCM_CHAR (chr), len);
}
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 (SCM_I_STRING_LENGTH (string));
+ return scm_from_size_t (STRING_LENGTH (string));
}
#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"
unsigned long idx;
SCM_VALIDATE_STRING (1, str);
- idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1);
- return SCM_MAKE_CHAR (SCM_I_STRING_UCHARS (str)[idx]);
+ idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
+ return SCM_MAKE_CHAR (scm_i_string_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));
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+}
SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
(SCM str, SCM k, SCM chr),
unsigned long idx;
SCM_VALIDATE_STRING (1, str);
- idx = scm_to_unsigned_integer (k, 0, SCM_I_STRING_LENGTH(str)-1);
+ idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
SCM_VALIDATE_CHAR (3, chr);
- SCM_I_STRING_UCHARS (str)[idx] = SCM_CHAR (chr);
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[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));
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[p] = SCM_CHAR (chr);
+ scm_i_string_stop_writing ();
+ }
+}
SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
(SCM str, SCM start, SCM end),
"0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
#define FUNC_NAME s_scm_substring
{
- unsigned long int from;
- unsigned long int to;
- SCM substr;
+ size_t len, from, to;
SCM_VALIDATE_STRING (1, str);
- from = scm_to_unsigned_integer (start, 0, SCM_I_STRING_LENGTH(str));
+ len = scm_i_string_length (str);
+ from = scm_to_unsigned_integer (start, 0, len);
if (SCM_UNBNDP (end))
- to = SCM_I_STRING_LENGTH(str);
+ to = len;
else
- to = scm_to_unsigned_integer (end, from, SCM_I_STRING_LENGTH(str));
- substr = scm_allocate_string (to - from);
- memcpy (SCM_I_STRING_CHARS (substr), SCM_I_STRING_CHARS (str) + from,
- to - from);
- scm_remember_upto_here_1 (str);
- return substr;
+ to = scm_to_unsigned_integer (end, from, len);
+ return scm_i_substring (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
+{
+ 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_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),
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
- i += SCM_I_STRING_LENGTH (s);
+ i += scm_i_string_length (s);
}
- res = scm_allocate_string (i);
- data = SCM_I_STRING_CHARS (res);
+ res = scm_i_make_string (i, &data);
for (l = args; !SCM_NULLP (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
- memcpy (data, SCM_I_STRING_CHARS (s), SCM_I_STRING_LENGTH (s));
- data += SCM_I_STRING_LENGTH (s);
+ SCM_VALIDATE_STRING (SCM_ARGn, s);
+ size_t len = scm_i_string_length (s);
+ memcpy (data, scm_i_string_chars (s), len);
+ data += len;
scm_remember_upto_here_1 (s);
}
return res;
int
scm_is_string (SCM obj)
{
- return SCM_I_STRINGP (obj);
+ return IS_STRING (obj);
}
SCM
if (len == (size_t)-1)
len = strlen (str);
- res = scm_allocate_string (len);
- dst = SCM_I_STRING_CHARS (res);
+ res = scm_i_make_string (len, &dst);
memcpy (dst, str, len);
return res;
}
scm_take_locale_string (char *str)
{
size_t len = strlen (str);
- SCM res;
+ SCM buf, res;
- if (len > SCM_STRING_MAX_LENGTH)
- {
- free (str);
- scm_out_of_range (NULL, scm_from_size_t (len));
- }
-
- res = scm_cell (SCM_I_MAKE_STRING_TAG (len), (scm_t_bits) str);
+ buf = scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
+ (scm_t_bits) len, (scm_t_bits) 0);
+ res = scm_double_cell (STRING_TAG,
+ SCM_UNPACK (buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
scm_gc_register_collectable_memory (str, len+1, "string");
-
return res;
}
char *res;
size_t len;
- if (!SCM_I_STRINGP (str))
+ if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
- len = SCM_I_STRING_LENGTH (str);
+ len = scm_i_string_length (str);
res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
- memcpy (res, SCM_I_STRING_CHARS (str), len);
+ memcpy (res, scm_i_string_chars (str), len);
if (lenp == NULL)
{
res[len] = '\0';
{
size_t len;
- if (!SCM_I_STRINGP (str))
+ 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);
+ len = scm_i_string_length (str);
+ memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
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. */
*cend = scm_to_unsigned_integer (end, *cstart, len);
}
+#if SCM_ENABLE_DEPRECATED
+
+int
+SCM_STRINGP (SCM str)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
+
+ /* We don't accept shared substrings here since they are not
+ null-terminated.
+ */
+
+ return IS_STRING (str) && !IS_SH_STRING (str);
+}
+
+char *
+SCM_STRING_CHARS (SCM str)
+{
+ char *chars;
+
+ scm_c_issue_deprecation_warning
+ ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
+
+ /* The following is wrong, of course...
+ */
+ chars = scm_i_string_writable_chars (str);
+ scm_i_string_stop_writing ();
+ return chars;
+}
+
+size_t
+SCM_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_allocate_string (0);
+ scm_nullstr = scm_i_make_string (0, NULL);
#include "libguile/strings.x"
}
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004 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
\f
-#define SCM_STRING_MAX_LENGTH ((SCM_T_BITS_MAX-255)/256)
+/* String representation.
-#define SCM_I_MAKE_STRING_TAG(l) ((((scm_t_bits) (l)) << 8) + scm_tc7_string)
-#define SCM_I_STRINGP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_string))
-#define SCM_I_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x)))
-#define SCM_I_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x)))
-#define SCM_I_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8))
+ A string is a piece of a stringbuf. A stringbuf can be used by
+ more than one string. When a string is written to and the
+ stringbuf of that string is used by more than one string, a new
+ stringbuf is created. That is, strings are copy-on-write. This
+ behavior can be used to make the substring operation quite
+ efficient.
-#define SCM_STRINGP SCM_I_STRINGP
-#define SCM_STRING_CHARS SCM_I_STRING_CHARS
-#define SCM_STRING_UCHARS SCM_I_STRING_UCHARS
-#define SCM_STRING_LENGTH SCM_I_STRING_LENGTH
+ The implementation is tuned so that mutating a string is costly,
+ but just reading it is cheap and lock-free.
-\f
+ There are also mutation-sharing strings. They refer to a part of
+ an ordinary string. Writing to a mutation-sharing string just
+ writes to the ordinary string.
+
+
+ Internal, low level interface to the character arrays
+
+ - Use scm_i_string_chars to get a pointer to the byte array of a
+ string for reading. Use scm_i_string_length to get the number of
+ bytes in that array. The array is not null-terminated.
+
+ - The array is valid as long as the corresponding SCM object is
+ protected but only until the next SCM_TICK. During such a 'safe
+ point', strings might change their representation.
+
+ - Use scm_i_string_writable_chars to get the same pointer as with
+ scm_i_string_chars, but for reading and writing. This is a
+ potentially costly operation since it implements the
+ copy-on-write behavior. When done with the writing, call
+ scm_i_string_stop_writing. You must do this before the next
+ SCM_TICK. (This means, before calling almost any other scm_
+ function and you can't allow throws, of course.)
+
+ - New strings can be created with scm_i_make_string. This gives
+ access to a writable pointer that remains valid as long as nobody
+ else makes a copy-on-write substring of the string. Do not call
+ scm_i_string_stop_writing for this pointer.
+
+ Legacy interface
+
+ - SCM_STRINGP returns false for sh-strings.
+
+ - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
+ calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
+ is the same as scm_i_string_length. SCM_STRINGP will only return
+ true for strings that are null-terminated when accessed with
+ SCM_STRING_CHARS.
+*/
SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append (SCM args);
-SCM_API SCM scm_makfromstrs (int argc, char **argv);
-SCM_API SCM scm_take_str (char *s, size_t len);
-SCM_API SCM scm_take0str (char *s);
-SCM_API SCM scm_mem2string (const char *src, size_t len);
-SCM_API SCM scm_str2string (const char *src);
-SCM_API SCM scm_makfrom0str (const char *src);
-SCM_API SCM scm_makfrom0str_opt (const char *src);
-SCM_API SCM scm_allocate_string (size_t len);
+SCM_API SCM scm_c_make_string (size_t len, SCM chr);
+SCM_API size_t scm_c_string_length (SCM str);
+SCM_API SCM scm_c_string_ref (SCM str, size_t pos);
+SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr);
+SCM_API SCM scm_c_substring (SCM str, size_t start, size_t end);
+SCM_API SCM scm_c_substring_shared (SCM str, size_t start, size_t end);
+SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end);
SCM_API int scm_is_string (SCM x);
SCM_API SCM scm_from_locale_string (const char *str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
+SCM_API SCM scm_makfromstrs (int argc, char **argv);
+
+/* internal accessor functions. Arguments must be valid. */
+
+SCM_API SCM scm_i_make_string (size_t len, char **datap);
+SCM_API SCM scm_i_substring (SCM str, size_t start, size_t end);
+SCM_API SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
+SCM_API SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
+SCM_API size_t scm_i_string_length (SCM str);
+SCM_API const char *scm_i_string_chars (SCM str);
+SCM_API char *scm_i_string_writable_chars (SCM str);
+SCM_API void scm_i_string_stop_writing (void);
+
+/* internal functions related to symbols. */
+
+SCM_API SCM scm_i_make_symbol (SCM name, unsigned long hash, SCM props);
+SCM_API const char *scm_i_symbol_chars (SCM sym);
+SCM_API size_t scm_i_symbol_length (SCM sym);
+SCM_API SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
+
+/* internal GC functions. */
+
+SCM_API SCM scm_i_string_mark (SCM str);
+SCM_API SCM scm_i_stringbuf_mark (SCM buf);
+SCM_API SCM scm_i_symbol_mark (SCM buf);
+SCM_API void scm_i_string_free (SCM str);
+SCM_API void scm_i_stringbuf_free (SCM buf);
+SCM_API void scm_i_symbol_free (SCM sym);
+
/* internal utility functions. */
SCM_API char **scm_i_allocate_string_pointers (SCM list);
SCM start, size_t *cstart,
SCM end, size_t *cend);
+/* deprecated stuff */
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_API int SCM_STRINGP (SCM obj);
+SCM_API char *SCM_STRING_CHARS (SCM str);
+SCM_API size_t SCM_STRING_LENGTH (SCM str);
+#define SCM_STRING_UCHARS ((unsigned char *)SCM_STRING_CHARS (str))
+
+#endif
+
SCM_API void scm_init_strings (void);
#endif /* SCM_STRINGS_H */
* without first creating an SCM string object. (This would have
* been necessary if we had used the hashtable API in hashtab.h.)
*
- * 2. We can use the raw hash value stored in SCM_SYMBOL_HASH (sym)
+ * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym)
* to speed up lookup.
*
* Both optimizations might be possible without breaking the
unsigned long
scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
{
- return SCM_SYMBOL_HASH (obj) % n;
+ return scm_i_symbol_hash (obj) % n;
}
-SCM
-scm_mem2symbol (const char *name, size_t len)
+static SCM
+scm_i_mem2symbol (SCM str)
{
+ const char *name = scm_i_string_chars (str);
+ size_t len = scm_i_string_length (str);
+
size_t raw_hash = scm_string_hash ((const unsigned char *) name, len) / 2;
size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
l = SCM_CDR (l))
{
SCM sym = SCM_CAAR (l);
- if (SCM_SYMBOL_HASH (sym) == raw_hash
- && SCM_SYMBOL_LENGTH (sym) == len)
+ if (scm_i_symbol_hash (sym) == raw_hash
+ && scm_i_symbol_length (sym) == len)
{
- char *chrs = SCM_SYMBOL_CHARS (sym);
+ const char *chrs = scm_i_symbol_chars (sym);
size_t i = len;
while (i != 0)
{
/* The symbol was not found - create it. */
- SCM symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
- (scm_t_bits) scm_gc_strndup (name, len,
- "symbol"),
- raw_hash,
- SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
+ SCM symbol = scm_i_make_symbol (str, raw_hash,
+ scm_cons (SCM_BOOL_F, SCM_EOL));
SCM slot = SCM_HASHTABLE_BUCKETS (symbols) [hash];
SCM cell = scm_cons (symbol, SCM_UNDEFINED);
}
}
-SCM
-scm_mem2uninterned_symbol (const char *name, size_t len)
+static SCM
+scm_i_mem2uninterned_symbol (SCM str)
{
+ const char *name = scm_i_string_chars (str);
+ size_t len = scm_i_string_length (str);
+
size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2
+ SCM_T_BITS_MAX/2 + 1);
- return scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
- (scm_t_bits) scm_gc_strndup (name, len,
- "symbol"),
- raw_hash,
- SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
-}
-
-SCM
-scm_str2symbol (const char *str)
-{
- return scm_mem2symbol (str, strlen (str));
+ return scm_i_make_symbol (str, raw_hash,
+ scm_cons (SCM_BOOL_F, SCM_EOL));
}
SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0,
"@code{#f}.")
#define FUNC_NAME s_scm_symbol_p
{
- return scm_from_bool (SCM_SYMBOLP (obj));
+ return scm_from_bool (scm_is_symbol (obj));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_interned_p
{
SCM_VALIDATE_SYMBOL (1, symbol);
- return scm_from_bool (SCM_SYMBOL_INTERNED_P (symbol));
+ return scm_from_bool (scm_i_symbol_is_interned (symbol));
}
#undef FUNC_NAME
"calls to @code{string->symbol} will not return it.")
#define FUNC_NAME s_scm_make_symbol
{
- SCM sym;
SCM_VALIDATE_STRING (1, name);
- sym = scm_mem2uninterned_symbol (SCM_I_STRING_CHARS (name),
- SCM_I_STRING_LENGTH (name));
- scm_remember_upto_here_1 (name);
- return sym;
+ return scm_i_mem2uninterned_symbol (name);
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_symbol_to_string
{
- SCM str;
SCM_VALIDATE_SYMBOL (1, s);
- str = scm_mem2string (SCM_SYMBOL_CHARS (s), SCM_SYMBOL_LENGTH (s));
- scm_remember_upto_here_1 (s);
- return str;
+ return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s));
}
#undef FUNC_NAME
"@end lisp")
#define FUNC_NAME s_scm_string_to_symbol
{
- SCM sym;
SCM_VALIDATE_STRING (1, string);
- sym = scm_mem2symbol (SCM_I_STRING_CHARS (string),
- SCM_I_STRING_LENGTH (string));
- scm_remember_upto_here_1 (string);
- return sym;
+ return scm_i_mem2symbol (string);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_gensym
{
static int gensym_counter = 0;
+
+ SCM suffix, name;
+ int n, n_digits;
+ char buf[SCM_INTBUFLEN];
- char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
- char *name = buf;
- size_t len;
if (SCM_UNBNDP (prefix))
- {
- name[0] = ' ';
- name[1] = 'g';
- len = 2;
- }
- else
- {
- SCM_VALIDATE_STRING (1, prefix);
- len = SCM_I_STRING_LENGTH (prefix);
- if (len > MAX_PREFIX_LENGTH)
- name = scm_malloc (len + SCM_INTBUFLEN);
- memcpy (name, SCM_I_STRING_CHARS (prefix), len);
- scm_remember_upto_here_1 (prefix);
- }
- {
- int n, n_digits;
-
- /* mutex in case another thread looks and incs at the exact same moment */
- scm_mutex_lock (&scm_i_misc_mutex);
- n = gensym_counter++;
- scm_mutex_unlock (&scm_i_misc_mutex);
-
- n_digits = scm_iint2str (n, 10, &name[len]);
- SCM res = scm_mem2symbol (name, len + n_digits);
- if (name != buf)
- free (name);
- return res;
- }
+ prefix = scm_from_locale_string (" g");
+
+ /* mutex in case another thread looks and incs at the exact same moment */
+ scm_mutex_lock (&scm_i_misc_mutex);
+ n = gensym_counter++;
+ scm_mutex_unlock (&scm_i_misc_mutex);
+
+ n_digits = scm_iint2str (n, 10, buf);
+ suffix = scm_from_locale_stringn (buf, n_digits);
+ name = scm_string_append (scm_list_2 (prefix, suffix));
+ return scm_string_to_symbol (name);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_hash
{
SCM_VALIDATE_SYMBOL (1, symbol);
- return scm_from_ulong (SCM_SYMBOL_HASH (symbol));
+ return scm_from_ulong (scm_i_symbol_hash (symbol));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_fref
{
SCM_VALIDATE_SYMBOL (1, s);
- return SCM_SYMBOL_FUNC (s);
+ return SCM_CAR (SCM_CELL_OBJECT_3 (s));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_pref
{
SCM_VALIDATE_SYMBOL (1, s);
- return SCM_SYMBOL_PROPS (s);
+ return SCM_CDR (SCM_CELL_OBJECT_3 (s));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_fset_x
{
SCM_VALIDATE_SYMBOL (1, s);
- SCM_SET_SYMBOL_FUNC (s, val);
+ SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_symbol_pset_x
{
SCM_VALIDATE_SYMBOL (1, s);
- SCM_DEFER_INTS;
- SCM_SET_SYMBOL_PROPS (s, val);
- SCM_ALLOW_INTS;
+ SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
-/* Converts the given Scheme symbol OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme symbols may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme symbol (if LENP is non-null). */
-#define FUNC_NAME "scm_c_symbol2str"
-char *
-scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
+SCM
+scm_from_locale_symbol (const char *sym)
{
- size_t len;
-
- SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME);
- len = SCM_SYMBOL_LENGTH (obj);
-
- if (str == NULL)
- {
- /* FIXME: Should we use exported wrappers for malloc (and free), which
- * allow windows DLLs to call the correct freeing function? */
- str = (char *) scm_malloc ((len + 1) * sizeof (char));
- if (str == NULL)
- return NULL;
- }
-
- memcpy (str, SCM_SYMBOL_CHARS (obj), len);
- scm_remember_upto_here_1 (obj);
- str[len] = '\0';
-
- if (lenp != NULL)
- *lenp = len;
-
- return str;
+ return scm_string_to_symbol (scm_from_locale_string (sym));
}
-#undef FUNC_NAME
+SCM
+scm_from_locale_symboln (const char *sym, size_t len)
+{
+ return scm_string_to_symbol (scm_from_locale_stringn (sym, len));
+}
void
scm_symbols_prehistory ()
HCoop / bpt / guile.git / commitdiff