-/* Copyright (C) 1995,1996,1998,2000,2001, 2004 Free Software Foundation, Inc.
+/* 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 2.1 of the License, or (at your option) any later version.
+ * 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
+ * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * 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 "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
}
}
+/* 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)
{
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
}
-SCM_MUTEX (stringbuf_write_mutex);
+scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Copy-on-write strings.
*/
#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
*/
SCM buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ 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;
+ SCM buf, my_buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- SCM my_buf = make_stringbuf (len);
+ my_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (my_buf),
STRINGBUF_CHARS (buf) + str_start + start, len);
scm_remember_upto_here_1 (buf);
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)
{
}
char *
-scm_i_string_writable_chars (SCM str)
+scm_i_string_writable_chars (SCM orig_str)
{
- SCM buf;
+ SCM buf, str = orig_str;
size_t start;
+
get_str_buf_start (&str, &buf, &start);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ 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 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);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
new_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (new_buf),
buf = new_buf;
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_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_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
/* Symbols.
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
/* reuse buf. */
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
SET_STRINGBUF_SHARED (buf);
- scm_i_plugin_mutex_unlock (&stringbuf_write_mutex);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
else
{
(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));
+}
+
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
+
const char *
scm_i_symbol_chars (SCM sym)
{
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
SCM buf = SYMBOL_STRINGBUF (sym);
- scm_i_plugin_mutex_lock (&stringbuf_write_mutex);
+ scm_i_pthread_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_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);
}
}
result = scm_i_make_string (len, &data);
- while (len > 0 && SCM_CONSP (chrs))
+ while (len > 0 && scm_is_pair (chrs))
{
SCM elt = SCM_CAR (chrs);
}
if (len > 0)
scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
- if (!SCM_NULLP (chrs))
+ if (!scm_is_null (chrs))
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
return result;
"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);
- idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
+
+ 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);
+
return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
}
#undef FUNC_NAME
"@var{str}.")
#define FUNC_NAME s_scm_string_set_x
{
+ size_t len;
unsigned long idx;
SCM_VALIDATE_STRING (1, str);
- idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
+
+ 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);
{
char *dst = scm_i_string_writable_chars (str);
}
#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"
char *data;
SCM_VALIDATE_REST_ARGUMENT (args);
- for (l = args; !SCM_NULLP (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
i += scm_i_string_length (s);
}
res = scm_i_make_string (i, &data);
- for (l = args; !SCM_NULLP (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
+ size_t len;
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
- size_t len = scm_i_string_length (s);
+ len = scm_i_string_length (s);
memcpy (data, scm_i_string_chars (s), len);
data += len;
scm_remember_upto_here_1 (s);
SCM
scm_take_locale_stringn (char *str, size_t len)
{
+ SCM buf, res;
+
if (len == (size_t)-1)
- return scm_take_locale_string (str);
+ len = strlen (str);
else
{
- /* STR might not be zero terminated and we are not allowed to
- look at str[len], so we have to make a new one...
- */
- SCM res = scm_from_locale_stringn (str, len);
- free (str);
- return res;
+ /* 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)
{
- size_t len = strlen (str);
- SCM buf, res;
-
- 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;
+ return scm_take_locale_stringn (str, -1);
}
char *
if (len < 0)
scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
- scm_frame_begin (0);
+ scm_dynwind_begin (0);
result = (char **) scm_malloc ((len + 1) * sizeof (char *));
result[len] = NULL;
- scm_frame_unwind_handler (free, result, 0);
+ 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_CONSP (list); i++)
+ for (i = 0; i < len && scm_is_pair (list); i++)
{
result[i] = scm_to_locale_string (SCM_CAR (list));
list = SCM_CDR (list);
}
- scm_frame_end ();
+ scm_dynwind_end ();
return result;
}
#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_STRINGP (SCM str)
+scm_i_deprecated_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);
+ return scm_is_string (str);
}
char *
-SCM_STRING_CHARS (SCM str)
+scm_i_deprecated_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...
+ /* 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...
*/
chars = scm_i_string_writable_chars (str);
scm_i_string_stop_writing ();
}
size_t
-SCM_STRING_LENGTH (SCM str)
+scm_i_deprecated_string_length (SCM str)
{
scm_c_issue_deprecation_warning
("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
#endif
+static SCM
+string_handle_ref (scm_t_array_handle *h, size_t index)
+{
+ return scm_c_string_ref (h->array, index);
+}
+
+static void
+string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
+{
+ scm_c_string_set_x (h->array, index, val);
+}
+
+static void
+string_get_handle (SCM v, scm_t_array_handle *h)
+{
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = scm_c_string_length (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
+ h->elements = h->writable_elements = NULL;
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2,
+ string_handle_ref, string_handle_set,
+ string_get_handle);
+SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string);
+
void
scm_init_strings ()
{
HCoop / bpt / guile.git / blobdiff