-/* Copyright (C) 1995,1996,1998,2000 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
-
-\f
-
-#include <stdio.h>
-#include <string.h>
-
-#include "libguile/_scm.h"
-#include "libguile/chars.h"
-
-#include "libguile/strings.h"
-#include "libguile/validate.h"
-\f
-
-/* {Strings}
- */
-
-SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
- (SCM obj),
- "Returns #t iff OBJ is a string, else returns #f.")
-#define FUNC_NAME s_scm_string_p
-{
- return SCM_BOOL (SCM_STRINGP (obj));
-}
-#undef FUNC_NAME
-
-#if SCM_DEBUG_DEPRECATED == 0
-
-/* The concept of read-only strings will disappear in next release
- * of Guile.
- */
-
-SCM_DEFINE (scm_read_only_string_p, "read-only-string?", 1, 0, 0,
- (SCM x),
- "Return true if OBJ can be read as a string,\n\n"
- "This illustrates the difference between @code{string?} and\n"
- "@code{read-only-string?}:\n\n"
- "@example\n"
- "(string? \"a string\") @result{} #t\n"
- "(string? 'a-symbol) @result{} #f\n\n"
- "(read-only-string? \"a string\") @result{} #t\n"
- "(read-only-string? 'a-symbol) @result{} #t\n"
- "@end example")
-#define FUNC_NAME s_scm_read_only_string_p
-{
- return SCM_BOOL(SCM_ROSTRINGP (x));
-}
-#undef FUNC_NAME
-
-#endif /* DEPRECATED */
-
-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 primitive list->string chrs\n"
- "Returns a newly allocated string composed of the arguments, CHRS.")
-#define FUNC_NAME s_scm_string
-{
- SCM result;
-
- {
- long i = scm_ilength (chrs);
-
- SCM_ASSERT (i >= 0, chrs, SCM_ARGn, FUNC_NAME);
- result = scm_makstr (i, 0);
- }
-
- {
- unsigned char *data = SCM_STRING_UCHARS (result);
-
- while (SCM_NNULLP (chrs))
- {
- SCM elt = SCM_CAR (chrs);
-
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- *data++ = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
- }
- }
- return result;
-}
-#undef FUNC_NAME
-
-SCM
-scm_makstr (long len, int dummy)
-{
- SCM s;
- char *mem = (char *) scm_must_malloc (len + 1, "scm_makstr");
-
- mem[len] = 0;
- SCM_NEWCELL (s);
- SCM_SETCHARS (s, mem);
- SCM_SETLENGTH (s, len, scm_tc7_string);
-
- return s;
-}
-
-/* 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_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst);
- return lst;
-}
-
-
-/* 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.
-
- 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, int len)
-{
- SCM answer;
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- SCM_SETLENGTH (answer, len, scm_tc7_string);
- scm_done_malloc (len + 1);
- SCM_SETCHARS (answer, s);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-/* `s' must be a malloc'd string. See scm_take_str. */
-SCM
-scm_take0str (char *s)
-{
- return scm_take_str (s, strlen (s));
-}
-
-SCM
-scm_makfromstr (const char *src, scm_sizet len, int dummy)
-{
- SCM s = scm_makstr (len, 0);
- char *dst = SCM_STRING_CHARS (s);
-
- while (len--)
- *dst++ = *src++;
- return s;
-}
-
-SCM
-scm_makfrom0str (const char *src)
-{
- if (!src) return SCM_BOOL_F;
- return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
-}
-
-
-SCM
-scm_makfrom0str_opt (const char *src)
-{
- return scm_makfrom0str (src);
-}
-
-
-
-
-SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
- (SCM k, SCM chr),
- "Returns a newly allocated string of\n"
- "length K. If CHR is given, then all elements of the string\n"
- "are initialized to CHR, otherwise the contents of the\n"
- "STRING are unspecified.\n")
-#define FUNC_NAME s_scm_make_string
-{
- SCM res;
- register long i;
- SCM_VALIDATE_INUM_MIN_COPY (1,k,0,i);
- res = scm_makstr (i, 0);
- if (!SCM_UNBNDP (chr))
- {
- SCM_VALIDATE_CHAR (2,chr);
- {
- unsigned char *dst = SCM_STRING_UCHARS (res);
- char c = SCM_CHAR (chr);
-
- memset (dst, c, i);
- }
- }
- return res;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
- (SCM string),
- "Returns the number of characters in STRING")
-#define FUNC_NAME s_scm_string_length
-{
- SCM_VALIDATE_STRING (1, string);
- return SCM_MAKINUM (SCM_STRING_LENGTH (string));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
- (SCM str, SCM k),
- "Returns character K of STR using zero-origin indexing.\n"
- "K must be a valid index of STR.")
-#define FUNC_NAME s_scm_string_ref
-{
- int idx;
-
- SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_INUM_COPY (2, k, idx);
- SCM_ASSERT_RANGE (2, k, idx >= 0 && idx < SCM_STRING_LENGTH (str));
- return SCM_MAKE_CHAR (SCM_STRING_UCHARS (str)[idx]);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
- (SCM str, SCM k, SCM chr),
- "Stores CHR in element K of STRING and returns an unspecified value.\n"
- "K must be a valid index of STR.")
-#define FUNC_NAME s_scm_string_set_x
-{
-#if (SCM_DEBUG_DEPRECATED == 0)
- SCM_VALIDATE_RWSTRING (1, str);
-#else
- SCM_VALIDATE_STRING (1, str);
-#endif
- SCM_VALIDATE_INUM_RANGE (2,k,0,SCM_STRING_LENGTH(str));
- SCM_VALIDATE_CHAR (3,chr);
- SCM_STRING_UCHARS (str)[SCM_INUM (k)] = SCM_CHAR (chr);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
- (SCM str, SCM start, SCM end),
- "Returns a newly allocated string formed from the characters\n"
- "of STR beginning with index START (inclusive) and ending with\n"
- "index END (exclusive).\n"
- "STR must be a string, START and END must be exact integers satisfying:\n\n"
- "0 <= START <= END <= (string-length STR).")
-#define FUNC_NAME s_scm_substring
-{
- long int from;
- long int to;
-
- SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_INUM (2, start);
- SCM_VALIDATE_INUM_DEF (3, end, SCM_STRING_LENGTH (str));
-
- from = SCM_INUM (start);
- SCM_ASSERT_RANGE (2, start, 0 <= from && from <= SCM_STRING_LENGTH (str));
- to = SCM_INUM (end);
- SCM_ASSERT_RANGE (3, end, from <= to && to <= SCM_STRING_LENGTH (str));
-
- return scm_makfromstr (&SCM_STRING_CHARS (str)[from], (scm_sizet) (to - from), 0);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
- (SCM args),
- "Returns a newly allocated string whose characters form the\n"
- "concatenation of the given strings, ARGS.")
-#define FUNC_NAME s_scm_string_append
-{
- SCM res;
- register long i = 0;
- register SCM l, s;
- register unsigned char *data;
-
- SCM_VALIDATE_REST_ARGUMENT (args);
- for (l = args; !SCM_NULLP (l); l = SCM_CDR (l)) {
- s = SCM_CAR (l);
- SCM_VALIDATE_STRING (SCM_ARGn,s);
- i += SCM_STRING_LENGTH (s);
- }
- res = scm_makstr (i, 0);
- data = SCM_STRING_UCHARS (res);
- for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
- s = SCM_CAR (l);
- for (i = 0;i<SCM_STRING_LENGTH (s);i++) *data++ = SCM_STRING_UCHARS (s)[i];
- }
- return res;
-}
-#undef FUNC_NAME
-
-#if SCM_DEBUG_DEPRECATED == 0
-
-/* Explicit shared substrings will disappear from Guile.
- *
- * Instead, "normal" strings will be implemented using sharing
- * internally, combined with a copy-on-write strategy.
- */
-
-SCM_DEFINE (scm_make_shared_substring, "make-shared-substring", 1, 2, 0,
- (SCM str, SCM frm, SCM to),
- "Return a shared substring of @var{str}. The semantics are the same as\n"
- "for the @code{substring} function: the shared substring returned\n"
- "includes all of the text from @var{str} between indexes @var{start}\n"
- "(inclusive) and @var{end} (exclusive). If @var{end} is omitted, it\n"
- "defaults to the end of @var{str}. The shared substring returned by\n"
- "@code{make-shared-substring} occupies the same storage space as\n"
- "@var{str}.")
-#define FUNC_NAME s_scm_make_shared_substring
-{
- long f;
- long t;
- SCM answer;
- SCM len_str;
-
- SCM_VALIDATE_ROSTRING (1,str);
- SCM_VALIDATE_INUM_DEF_COPY (2,frm,0,f);
- SCM_VALIDATE_INUM_DEF_COPY (3,to,SCM_ROLENGTH(str),t);
-
- SCM_ASSERT_RANGE (2,frm,(f >= 0));
- SCM_ASSERT_RANGE (3,to, (f <= t) && (t <= SCM_ROLENGTH (str)));
-
- SCM_NEWCELL (answer);
- SCM_NEWCELL (len_str);
-
- SCM_DEFER_INTS;
- if (SCM_SUBSTRP (str))
- {
- long offset;
- offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
- f += offset;
- t += offset;
- SCM_SETCAR (len_str, SCM_MAKINUM (f));
- SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
- SCM_SETCDR (answer, len_str);
- SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
- }
- else
- {
- SCM_SETCAR (len_str, SCM_MAKINUM (f));
- SCM_SETCDR (len_str, str);
- SCM_SETCDR (answer, len_str);
- SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
- }
- SCM_ALLOW_INTS;
- return answer;
-}
-#undef FUNC_NAME
-
-#endif /* DEPRECATED */
-
-void
-scm_init_strings ()
-{
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/strings.x"
-#endif
-}
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* 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
+ */
+
+
+\f
+#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"
+
+\f
+
+/* {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
+
+\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;
+ 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:
+*/
HCoop / bpt / guile.git / blobdiff