1 /* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
27 #include "libguile/_scm.h"
28 #include "libguile/chars.h"
29 #include "libguile/root.h"
30 #include "libguile/strings.h"
31 #include "libguile/deprecation.h"
32 #include "libguile/validate.h"
33 #include "libguile/dynwind.h"
43 * XXX - keeping an accurate refcount during GC seems to be quite
44 * tricky, so we just keep score of whether a stringbuf might be
45 * shared, not wether it definitely is.
47 * The scheme I (mvo) tried to keep an accurate reference count would
48 * recount all strings that point to a stringbuf during the mark-phase
49 * of the GC. This was done since one cannot access the stringbuf of
50 * a string when that string is freed (in order to decrease the
51 * reference count). The memory of the stringbuf might have been
52 * reused already for something completely different.
54 * This recounted worked for a small number of threads beating on
55 * cow-strings, but it failed randomly with more than 10 threads, say.
56 * I couldn't figure out what went wrong, so I used the conservative
57 * approach implemented below.
59 * A stringbuf needs to know its length, but only so that it can be
60 * reported when the stringbuf is freed.
62 * Stringbufs (and strings) are not stored very compactly: a stringbuf
63 * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
64 * information. As a compensation, the code below is made more
65 * complicated by storing small strings inline in the double cell of a
66 * stringbuf. So we have fixstrings and bigstrings...
69 #define STRINGBUF_F_SHARED 0x100
70 #define STRINGBUF_F_INLINE 0x200
72 #define STRINGBUF_TAG scm_tc7_stringbuf
73 #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
74 #define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
76 #define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
77 #define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
78 #define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
79 #define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
81 #define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
82 ? STRINGBUF_INLINE_CHARS (buf) \
83 : STRINGBUF_OUTLINE_CHARS (buf))
84 #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
85 ? STRINGBUF_INLINE_LENGTH (buf) \
86 : STRINGBUF_OUTLINE_LENGTH (buf))
88 #define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
90 #define SET_STRINGBUF_SHARED(buf) \
91 (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
94 static size_t lenhist[1001];
98 make_stringbuf (size_t len)
100 /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
101 scm_i_symbol_chars, all stringbufs are null-terminated. Once
102 SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
103 has been changed for scm_i_symbol_chars, this null-termination
114 if (len <= STRINGBUF_MAX_INLINE_LEN-1)
116 return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
121 char *mem = scm_gc_malloc (len+1, "string");
123 return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
124 (scm_t_bits) len, (scm_t_bits) 0);
128 /* Return a new stringbuf whose underlying storage consists of the LEN+1
129 octets pointed to by STR (the last octet is zero). */
131 scm_i_take_stringbufn (char *str, size_t len)
133 scm_gc_register_collectable_memory (str, len + 1, "stringbuf");
135 return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
136 (scm_t_bits) len, (scm_t_bits) 0);
140 scm_i_stringbuf_mark (SCM buf)
146 scm_i_stringbuf_free (SCM buf)
148 if (!STRINGBUF_INLINE (buf))
149 scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
150 STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
153 scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
155 /* Copy-on-write strings.
158 #define STRING_TAG scm_tc7_string
160 #define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
161 #define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
162 #define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
164 #define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
165 #define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
167 #define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
169 /* Read-only strings.
172 #define RO_STRING_TAG (scm_tc7_string + 0x200)
173 #define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
175 /* Mutation-sharing substrings
178 #define SH_STRING_TAG (scm_tc7_string + 0x100)
180 #define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
181 /* START and LENGTH as for STRINGs. */
183 #define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
186 scm_i_make_string (size_t len, char **charsp)
188 SCM buf = make_stringbuf (len);
191 *charsp = STRINGBUF_CHARS (buf);
192 res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
193 (scm_t_bits)0, (scm_t_bits) len);
198 validate_substring_args (SCM str, size_t start, size_t end)
200 if (!IS_STRING (str))
201 scm_wrong_type_arg_msg (NULL, 0, str, "string");
202 if (start > STRING_LENGTH (str))
203 scm_out_of_range (NULL, scm_from_size_t (start));
204 if (end > STRING_LENGTH (str) || end < start)
205 scm_out_of_range (NULL, scm_from_size_t (end));
209 get_str_buf_start (SCM *str, SCM *buf, size_t *start)
211 *start = STRING_START (*str);
212 if (IS_SH_STRING (*str))
214 *str = SH_STRING_STRING (*str);
215 *start += STRING_START (*str);
217 *buf = STRING_STRINGBUF (*str);
221 scm_i_substring (SCM str, size_t start, size_t end)
225 get_str_buf_start (&str, &buf, &str_start);
226 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
227 SET_STRINGBUF_SHARED (buf);
228 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
229 return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
230 (scm_t_bits)str_start + start,
231 (scm_t_bits) end - start);
235 scm_i_substring_read_only (SCM str, size_t start, size_t end)
239 get_str_buf_start (&str, &buf, &str_start);
240 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
241 SET_STRINGBUF_SHARED (buf);
242 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
243 return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
244 (scm_t_bits)str_start + start,
245 (scm_t_bits) end - start);
249 scm_i_substring_copy (SCM str, size_t start, size_t end)
251 size_t len = end - start;
254 get_str_buf_start (&str, &buf, &str_start);
255 my_buf = make_stringbuf (len);
256 memcpy (STRINGBUF_CHARS (my_buf),
257 STRINGBUF_CHARS (buf) + str_start + start, len);
258 scm_remember_upto_here_1 (buf);
259 return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
260 (scm_t_bits)0, (scm_t_bits) len);
264 scm_i_substring_shared (SCM str, size_t start, size_t end)
266 if (start == 0 && end == STRING_LENGTH (str))
270 size_t len = end - start;
271 if (IS_SH_STRING (str))
273 start += STRING_START (str);
274 str = SH_STRING_STRING (str);
276 return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
277 (scm_t_bits)start, (scm_t_bits) len);
282 scm_c_substring (SCM str, size_t start, size_t end)
284 validate_substring_args (str, start, end);
285 return scm_i_substring (str, start, end);
289 scm_c_substring_read_only (SCM str, size_t start, size_t end)
291 validate_substring_args (str, start, end);
292 return scm_i_substring_read_only (str, start, end);
296 scm_c_substring_copy (SCM str, size_t start, size_t end)
298 validate_substring_args (str, start, end);
299 return scm_i_substring_copy (str, start, end);
303 scm_c_substring_shared (SCM str, size_t start, size_t end)
305 validate_substring_args (str, start, end);
306 return scm_i_substring_shared (str, start, end);
310 scm_i_string_mark (SCM str)
312 if (IS_SH_STRING (str))
313 return SH_STRING_STRING (str);
315 return STRING_STRINGBUF (str);
319 scm_i_string_free (SCM str)
323 /* Internal accessors
327 scm_i_string_length (SCM str)
329 return STRING_LENGTH (str);
333 scm_i_string_chars (SCM str)
337 get_str_buf_start (&str, &buf, &start);
338 return STRINGBUF_CHARS (buf) + start;
342 scm_i_string_writable_chars (SCM orig_str)
344 SCM buf, str = orig_str;
347 get_str_buf_start (&str, &buf, &start);
348 if (IS_RO_STRING (str))
349 scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
351 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
352 if (STRINGBUF_SHARED (buf))
354 /* Clone stringbuf. For this, we put all threads to sleep.
357 size_t len = STRING_LENGTH (str);
360 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
362 new_buf = make_stringbuf (len);
363 memcpy (STRINGBUF_CHARS (new_buf),
364 STRINGBUF_CHARS (buf) + STRING_START (str), len);
366 scm_i_thread_put_to_sleep ();
367 SET_STRING_STRINGBUF (str, new_buf);
368 start -= STRING_START (str);
369 SET_STRING_START (str, 0);
370 scm_i_thread_wake_up ();
374 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
377 return STRINGBUF_CHARS (buf) + start;
381 scm_i_string_stop_writing (void)
383 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
388 Basic symbol creation and accessing is done here, the rest is in
389 symbols.[hc]. This has been done to keep stringbufs and the
390 internals of strings and string-like objects confined to this file.
393 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
396 scm_i_make_symbol (SCM name, scm_t_bits flags,
397 unsigned long hash, SCM props)
400 size_t start = STRING_START (name);
401 size_t length = STRING_LENGTH (name);
403 if (IS_SH_STRING (name))
405 name = SH_STRING_STRING (name);
406 start += STRING_START (name);
408 buf = SYMBOL_STRINGBUF (name);
410 if (start == 0 && length == STRINGBUF_LENGTH (buf))
413 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
414 SET_STRINGBUF_SHARED (buf);
415 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
420 SCM new_buf = make_stringbuf (length);
421 memcpy (STRINGBUF_CHARS (new_buf),
422 STRINGBUF_CHARS (buf) + start, length);
425 return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
426 (scm_t_bits) hash, SCM_UNPACK (props));
430 scm_i_c_make_symbol (const char *name, size_t len,
431 scm_t_bits flags, unsigned long hash, SCM props)
433 SCM buf = make_stringbuf (len);
434 memcpy (STRINGBUF_CHARS (buf), name, len);
436 return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
437 (scm_t_bits) hash, SCM_UNPACK (props));
440 /* Return a new symbol that uses the LEN bytes pointed to by NAME as its
441 underlying storage. */
443 scm_i_c_take_symbol (char *name, size_t len,
444 scm_t_bits flags, unsigned long hash, SCM props)
446 SCM buf = scm_i_take_stringbufn (name, len);
448 return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
449 (scm_t_bits) hash, SCM_UNPACK (props));
453 scm_i_symbol_length (SCM sym)
455 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
459 scm_c_symbol_length (SCM sym)
460 #define FUNC_NAME "scm_c_symbol_length"
462 SCM_VALIDATE_SYMBOL (1, sym);
464 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
469 scm_i_symbol_chars (SCM sym)
471 SCM buf = SYMBOL_STRINGBUF (sym);
472 return STRINGBUF_CHARS (buf);
476 scm_i_symbol_mark (SCM sym)
478 scm_gc_mark (SYMBOL_STRINGBUF (sym));
479 return SCM_CELL_OBJECT_3 (sym);
483 scm_i_symbol_free (SCM sym)
488 scm_i_symbol_substring (SCM sym, size_t start, size_t end)
490 SCM buf = SYMBOL_STRINGBUF (sym);
491 scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
492 SET_STRINGBUF_SHARED (buf);
493 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
494 return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
495 (scm_t_bits)start, (scm_t_bits) end - start);
503 SCM scm_sys_string_dump (SCM);
504 SCM scm_sys_symbol_dump (SCM);
505 SCM scm_sys_stringbuf_hist (void);
507 SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
510 #define FUNC_NAME s_scm_sys_string_dump
512 SCM_VALIDATE_STRING (1, str);
513 fprintf (stderr, "%p:\n", str);
514 fprintf (stderr, " start: %u\n", STRING_START (str));
515 fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
516 if (IS_SH_STRING (str))
518 fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
519 fprintf (stderr, "\n");
520 scm_sys_string_dump (SH_STRING_STRING (str));
524 SCM buf = STRING_STRINGBUF (str);
525 fprintf (stderr, " buf: %p\n", buf);
526 fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
527 fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
528 fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
530 return SCM_UNSPECIFIED;
534 SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
537 #define FUNC_NAME s_scm_sys_symbol_dump
539 SCM_VALIDATE_SYMBOL (1, sym);
540 fprintf (stderr, "%p:\n", sym);
541 fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
543 SCM buf = SYMBOL_STRINGBUF (sym);
544 fprintf (stderr, " buf: %p\n", buf);
545 fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
546 fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
547 fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
549 return SCM_UNSPECIFIED;
553 SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
556 #define FUNC_NAME s_scm_sys_stringbuf_hist
559 for (i = 0; i < 1000; i++)
561 fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
562 fprintf (stderr, ">999: %u\n", lenhist[1000]);
563 return SCM_UNSPECIFIED;
571 SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
573 "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
574 #define FUNC_NAME s_scm_string_p
576 return scm_from_bool (IS_STRING (obj));
581 SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
583 SCM_DEFINE (scm_string, "string", 0, 0, 1,
585 "@deffnx {Scheme Procedure} list->string chrs\n"
586 "Return a newly allocated string composed of the arguments,\n"
588 #define FUNC_NAME s_scm_string
595 long i = scm_ilength (chrs);
597 SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
601 result = scm_i_make_string (len, &data);
602 while (len > 0 && scm_is_pair (chrs))
604 SCM elt = SCM_CAR (chrs);
606 SCM_VALIDATE_CHAR (SCM_ARGn, elt);
607 *data++ = SCM_CHAR (elt);
608 chrs = SCM_CDR (chrs);
612 scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
613 if (!scm_is_null (chrs))
614 scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
620 SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
622 "Return a newly allocated string of\n"
623 "length @var{k}. If @var{chr} is given, then all elements of\n"
624 "the string are initialized to @var{chr}, otherwise the contents\n"
625 "of the @var{string} are unspecified.")
626 #define FUNC_NAME s_scm_make_string
628 return scm_c_make_string (scm_to_size_t (k), chr);
633 scm_c_make_string (size_t len, SCM chr)
634 #define FUNC_NAME NULL
637 SCM res = scm_i_make_string (len, &dst);
639 if (!SCM_UNBNDP (chr))
641 SCM_VALIDATE_CHAR (0, chr);
642 memset (dst, SCM_CHAR (chr), len);
649 SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
651 "Return the number of characters in @var{string}.")
652 #define FUNC_NAME s_scm_string_length
654 SCM_VALIDATE_STRING (1, string);
655 return scm_from_size_t (STRING_LENGTH (string));
660 scm_c_string_length (SCM string)
662 if (!IS_STRING (string))
663 scm_wrong_type_arg_msg (NULL, 0, string, "string");
664 return STRING_LENGTH (string);
667 SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
669 "Return character @var{k} of @var{str} using zero-origin\n"
670 "indexing. @var{k} must be a valid index of @var{str}.")
671 #define FUNC_NAME s_scm_string_ref
676 SCM_VALIDATE_STRING (1, str);
678 len = scm_i_string_length (str);
679 if (SCM_LIKELY (len > 0))
680 idx = scm_to_unsigned_integer (k, 0, len - 1);
682 scm_out_of_range (NULL, k);
684 return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
689 scm_c_string_ref (SCM str, size_t p)
691 if (p >= scm_i_string_length (str))
692 scm_out_of_range (NULL, scm_from_size_t (p));
693 return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
696 SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
697 (SCM str, SCM k, SCM chr),
698 "Store @var{chr} in element @var{k} of @var{str} and return\n"
699 "an unspecified value. @var{k} must be a valid index of\n"
701 #define FUNC_NAME s_scm_string_set_x
706 SCM_VALIDATE_STRING (1, str);
708 len = scm_i_string_length (str);
709 if (SCM_LIKELY (len > 0))
710 idx = scm_to_unsigned_integer (k, 0, len - 1);
712 scm_out_of_range (NULL, k);
714 SCM_VALIDATE_CHAR (3, chr);
716 char *dst = scm_i_string_writable_chars (str);
717 dst[idx] = SCM_CHAR (chr);
718 scm_i_string_stop_writing ();
720 return SCM_UNSPECIFIED;
725 scm_c_string_set_x (SCM str, size_t p, SCM chr)
727 if (p >= scm_i_string_length (str))
728 scm_out_of_range (NULL, scm_from_size_t (p));
730 char *dst = scm_i_string_writable_chars (str);
731 dst[p] = SCM_CHAR (chr);
732 scm_i_string_stop_writing ();
736 SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
737 (SCM str, SCM start, SCM end),
738 "Return a newly allocated string formed from the characters\n"
739 "of @var{str} beginning with index @var{start} (inclusive) and\n"
740 "ending with index @var{end} (exclusive).\n"
741 "@var{str} must be a string, @var{start} and @var{end} must be\n"
742 "exact integers satisfying:\n\n"
743 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
744 #define FUNC_NAME s_scm_substring
746 size_t len, from, to;
748 SCM_VALIDATE_STRING (1, str);
749 len = scm_i_string_length (str);
750 from = scm_to_unsigned_integer (start, 0, len);
751 if (SCM_UNBNDP (end))
754 to = scm_to_unsigned_integer (end, from, len);
755 return scm_i_substring (str, from, to);
759 SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0,
760 (SCM str, SCM start, SCM end),
761 "Return a newly allocated string formed from the characters\n"
762 "of @var{str} beginning with index @var{start} (inclusive) and\n"
763 "ending with index @var{end} (exclusive).\n"
764 "@var{str} must be a string, @var{start} and @var{end} must be\n"
765 "exact integers satisfying:\n"
767 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
769 "The returned string is read-only.\n")
770 #define FUNC_NAME s_scm_substring_read_only
772 size_t len, from, to;
774 SCM_VALIDATE_STRING (1, str);
775 len = scm_i_string_length (str);
776 from = scm_to_unsigned_integer (start, 0, len);
777 if (SCM_UNBNDP (end))
780 to = scm_to_unsigned_integer (end, from, len);
781 return scm_i_substring_read_only (str, from, to);
785 SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
786 (SCM str, SCM start, SCM end),
787 "Return a newly allocated string formed from the characters\n"
788 "of @var{str} beginning with index @var{start} (inclusive) and\n"
789 "ending with index @var{end} (exclusive).\n"
790 "@var{str} must be a string, @var{start} and @var{end} must be\n"
791 "exact integers satisfying:\n\n"
792 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
793 #define FUNC_NAME s_scm_substring_copy
795 /* For the Scheme version, START is mandatory, but for the C
796 version, it is optional. See scm_string_copy in srfi-13.c for a
802 SCM_VALIDATE_STRING (1, str);
803 scm_i_get_substring_spec (scm_i_string_length (str),
804 start, &from, end, &to);
805 return scm_i_substring_copy (str, from, to);
809 SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
810 (SCM str, SCM start, SCM end),
811 "Return string that indirectly refers to the characters\n"
812 "of @var{str} beginning with index @var{start} (inclusive) and\n"
813 "ending with index @var{end} (exclusive).\n"
814 "@var{str} must be a string, @var{start} and @var{end} must be\n"
815 "exact integers satisfying:\n\n"
816 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
817 #define FUNC_NAME s_scm_substring_shared
819 size_t len, from, to;
821 SCM_VALIDATE_STRING (1, str);
822 len = scm_i_string_length (str);
823 from = scm_to_unsigned_integer (start, 0, len);
824 if (SCM_UNBNDP (end))
827 to = scm_to_unsigned_integer (end, from, len);
828 return scm_i_substring_shared (str, from, to);
832 SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
834 "Return a newly allocated string whose characters form the\n"
835 "concatenation of the given strings, @var{args}.")
836 #define FUNC_NAME s_scm_string_append
843 SCM_VALIDATE_REST_ARGUMENT (args);
844 for (l = args; !scm_is_null (l); l = SCM_CDR (l))
847 SCM_VALIDATE_STRING (SCM_ARGn, s);
848 i += scm_i_string_length (s);
850 res = scm_i_make_string (i, &data);
851 for (l = args; !scm_is_null (l); l = SCM_CDR (l))
855 SCM_VALIDATE_STRING (SCM_ARGn, s);
856 len = scm_i_string_length (s);
857 memcpy (data, scm_i_string_chars (s), len);
859 scm_remember_upto_here_1 (s);
866 scm_is_string (SCM obj)
868 return IS_STRING (obj);
872 scm_from_locale_stringn (const char *str, size_t len)
877 if (len == (size_t)-1)
879 res = scm_i_make_string (len, &dst);
880 memcpy (dst, str, len);
885 scm_from_locale_string (const char *str)
887 return scm_from_locale_stringn (str, -1);
891 scm_take_locale_stringn (char *str, size_t len)
895 if (len == (size_t)-1)
899 /* Ensure STR is null terminated. A realloc for 1 extra byte should
900 often be satisfied from the alignment padding after the block, with
901 no actual data movement. */
902 str = scm_realloc (str, len+1);
906 buf = scm_i_take_stringbufn (str, len);
907 res = scm_double_cell (STRING_TAG,
909 (scm_t_bits) 0, (scm_t_bits) len);
914 scm_take_locale_string (char *str)
916 return scm_take_locale_stringn (str, -1);
920 scm_to_locale_stringn (SCM str, size_t *lenp)
925 if (!scm_is_string (str))
926 scm_wrong_type_arg_msg (NULL, 0, str, "string");
927 len = scm_i_string_length (str);
928 res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
929 memcpy (res, scm_i_string_chars (str), len);
933 if (strlen (res) != len)
936 scm_misc_error (NULL,
937 "string contains #\\nul character: ~S",
944 scm_remember_upto_here_1 (str);
949 scm_to_locale_string (SCM str)
951 return scm_to_locale_stringn (str, NULL);
955 scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
959 if (!scm_is_string (str))
960 scm_wrong_type_arg_msg (NULL, 0, str, "string");
961 len = scm_i_string_length (str);
962 memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
963 scm_remember_upto_here_1 (str);
967 /* converts C scm_array of strings to SCM scm_list of strings. */
968 /* If argc < 0, a null terminated scm_array is assumed. */
970 scm_makfromstrs (int argc, char **argv)
975 for (i = 0; argv[i]; i++);
977 lst = scm_cons (scm_from_locale_string (argv[i]), lst);
981 /* Return a newly allocated array of char pointers to each of the strings
982 in args, with a terminating NULL pointer. */
985 scm_i_allocate_string_pointers (SCM list)
988 int len = scm_ilength (list);
992 scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
994 scm_dynwind_begin (0);
996 result = (char **) scm_malloc ((len + 1) * sizeof (char *));
998 scm_dynwind_unwind_handler (free, result, 0);
1000 /* The list might be have been modified in another thread, so
1001 we check LIST before each access.
1003 for (i = 0; i < len && scm_is_pair (list); i++)
1005 result[i] = scm_to_locale_string (SCM_CAR (list));
1006 list = SCM_CDR (list);
1014 scm_i_free_string_pointers (char **pointers)
1018 for (i = 0; pointers[i]; i++)
1024 scm_i_get_substring_spec (size_t len,
1025 SCM start, size_t *cstart,
1026 SCM end, size_t *cend)
1028 if (SCM_UNBNDP (start))
1031 *cstart = scm_to_unsigned_integer (start, 0, len);
1033 if (SCM_UNBNDP (end))
1036 *cend = scm_to_unsigned_integer (end, *cstart, len);
1039 #if SCM_ENABLE_DEPRECATED
1041 /* When these definitions are removed, it becomes reasonable to use
1042 read-only strings for string literals. For that, change the reader
1043 to create string literals with scm_c_substring_read_only instead of
1044 with scm_c_substring_copy.
1048 scm_i_deprecated_stringp (SCM str)
1050 scm_c_issue_deprecation_warning
1051 ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
1053 return scm_is_string (str);
1057 scm_i_deprecated_string_chars (SCM str)
1061 scm_c_issue_deprecation_warning
1062 ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
1064 /* We don't accept shared substrings here since they are not
1067 if (IS_SH_STRING (str))
1068 scm_misc_error (NULL,
1069 "SCM_STRING_CHARS does not work with shared substrings.",
1072 /* We explicitly test for read-only strings to produce a better
1076 if (IS_RO_STRING (str))
1077 scm_misc_error (NULL,
1078 "SCM_STRING_CHARS does not work with read-only strings.",
1081 /* The following is still wrong, of course...
1083 chars = scm_i_string_writable_chars (str);
1084 scm_i_string_stop_writing ();
1089 scm_i_deprecated_string_length (SCM str)
1091 scm_c_issue_deprecation_warning
1092 ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
1093 return scm_c_string_length (str);
1101 scm_nullstr = scm_i_make_string (0, NULL);
1103 #include "libguile/strings.x"