1
/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006 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
24
#include "libguile/_scm.h"
25
#include "libguile/chars.h"
26
#include "libguile/root.h"
27
#include "libguile/strings.h"
28
#include "libguile/deprecation.h"
29
#include "libguile/validate.h"
30
#include "libguile/dynwind.h"
40
* XXX - keeping an accurate refcount during GC seems to be quite
41
* tricky, so we just keep score of whether a stringbuf might be
42
* shared, not wether it definitely is.
44
* The scheme I (mvo) tried to keep an accurate reference count would
45
* recount all strings that point to a stringbuf during the mark-phase
46
* of the GC. This was done since one cannot access the stringbuf of
47
* a string when that string is freed (in order to decrease the
48
* reference count). The memory of the stringbuf might have been
49
* reused already for something completely different.
51
* This recounted worked for a small number of threads beating on
52
* cow-strings, but it failed randomly with more than 10 threads, say.
53
* I couldn't figure out what went wrong, so I used the conservative
54
* approach implemented below.
56
* A stringbuf needs to know its length, but only so that it can be
57
* reported when the stringbuf is freed.
59
* Stringbufs (and strings) are not stored very compactly: a stringbuf
60
* has room for about 2*sizeof(scm_t_bits)-1 bytes additional
61
* information. As a compensation, the code below is made more
62
* complicated by storing small strings inline in the double cell of a
63
* stringbuf. So we have fixstrings and bigstrings...
66
#define STRINGBUF_F_SHARED 0x100
67
#define STRINGBUF_F_INLINE 0x200
69
#define STRINGBUF_TAG scm_tc7_stringbuf
70
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
71
#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
73
#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
74
#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
75
#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
76
#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
78
#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
79
? STRINGBUF_INLINE_CHARS (buf) \
80
: STRINGBUF_OUTLINE_CHARS (buf))
81
#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
82
? STRINGBUF_INLINE_LENGTH (buf) \
83
: STRINGBUF_OUTLINE_LENGTH (buf))
85
#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
87
#define SET_STRINGBUF_SHARED(buf) \
88
(SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
91
static size_t lenhist[1001];
95
make_stringbuf (size_t len)
97
/* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
98
scm_i_symbol_chars, all stringbufs are null-terminated. Once
99
SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
100
has been changed for scm_i_symbol_chars, this null-termination
111
if (len <= STRINGBUF_MAX_INLINE_LEN-1)
113
return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
118
char *mem = scm_gc_malloc (len+1, "string");
120
return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
121
(scm_t_bits) len, (scm_t_bits) 0);
125
/* Return a new stringbuf whose underlying storage consists of the LEN+1
126
octets pointed to by STR (the last octet is zero). */
127
SCM_C_INLINE_KEYWORD SCM
128
scm_i_take_stringbufn (char *str, size_t len)
130
scm_gc_register_collectable_memory (str, len + 1, "stringbuf");
132
return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
133
(scm_t_bits) len, (scm_t_bits) 0);
137
scm_i_stringbuf_mark (SCM buf)
143
scm_i_stringbuf_free (SCM buf)
145
if (!STRINGBUF_INLINE (buf))
146
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
147
STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
150
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
152
/* Copy-on-write strings.
155
#define STRING_TAG scm_tc7_string
157
#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
158
#define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
159
#define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
161
#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
162
#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
164
#define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
166
/* Read-only strings.
169
#define RO_STRING_TAG (scm_tc7_string + 0x200)
170
#define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
172
/* Mutation-sharing substrings
175
#define SH_STRING_TAG (scm_tc7_string + 0x100)
177
#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
178
/* START and LENGTH as for STRINGs. */
180
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
183
scm_i_make_string (size_t len, char **charsp)
185
SCM buf = make_stringbuf (len);
188
*charsp = STRINGBUF_CHARS (buf);
189
res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
190
(scm_t_bits)0, (scm_t_bits) len);
195
validate_substring_args (SCM str, size_t start, size_t end)
197
if (!IS_STRING (str))
198
scm_wrong_type_arg_msg (NULL, 0, str, "string");
199
if (start > STRING_LENGTH (str))
200
scm_out_of_range (NULL, scm_from_size_t (start));
201
if (end > STRING_LENGTH (str) || end < start)
202
scm_out_of_range (NULL, scm_from_size_t (end));
206
get_str_buf_start (SCM *str, SCM *buf, size_t *start)
208
*start = STRING_START (*str);
209
if (IS_SH_STRING (*str))
211
*str = SH_STRING_STRING (*str);
212
*start += STRING_START (*str);
214
*buf = STRING_STRINGBUF (*str);
218
scm_i_substring (SCM str, size_t start, size_t end)
222
get_str_buf_start (&str, &buf, &str_start);
223
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
224
SET_STRINGBUF_SHARED (buf);
225
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
226
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
227
(scm_t_bits)str_start + start,
228
(scm_t_bits) end - start);
232
scm_i_substring_read_only (SCM str, size_t start, size_t end)
236
get_str_buf_start (&str, &buf, &str_start);
237
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
238
SET_STRINGBUF_SHARED (buf);
239
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
240
return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
241
(scm_t_bits)str_start + start,
242
(scm_t_bits) end - start);
246
scm_i_substring_copy (SCM str, size_t start, size_t end)
248
size_t len = end - start;
251
get_str_buf_start (&str, &buf, &str_start);
252
my_buf = make_stringbuf (len);
253
memcpy (STRINGBUF_CHARS (my_buf),
254
STRINGBUF_CHARS (buf) + str_start + start, len);
255
scm_remember_upto_here_1 (buf);
256
return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
257
(scm_t_bits)0, (scm_t_bits) len);
261
scm_i_substring_shared (SCM str, size_t start, size_t end)
263
if (start == 0 && end == STRING_LENGTH (str))
267
size_t len = end - start;
268
if (IS_SH_STRING (str))
270
start += STRING_START (str);
271
str = SH_STRING_STRING (str);
273
return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
274
(scm_t_bits)start, (scm_t_bits) len);
279
scm_c_substring (SCM str, size_t start, size_t end)
281
validate_substring_args (str, start, end);
282
return scm_i_substring (str, start, end);
286
scm_c_substring_read_only (SCM str, size_t start, size_t end)
288
validate_substring_args (str, start, end);
289
return scm_i_substring_read_only (str, start, end);
293
scm_c_substring_copy (SCM str, size_t start, size_t end)
295
validate_substring_args (str, start, end);
296
return scm_i_substring_copy (str, start, end);
300
scm_c_substring_shared (SCM str, size_t start, size_t end)
302
validate_substring_args (str, start, end);
303
return scm_i_substring_shared (str, start, end);
307
scm_i_string_mark (SCM str)
309
if (IS_SH_STRING (str))
310
return SH_STRING_STRING (str);
312
return STRING_STRINGBUF (str);
316
scm_i_string_free (SCM str)
320
/* Internal accessors
324
scm_i_string_length (SCM str)
326
return STRING_LENGTH (str);
330
scm_i_string_chars (SCM str)
334
get_str_buf_start (&str, &buf, &start);
335
return STRINGBUF_CHARS (buf) + start;
339
scm_i_string_writable_chars (SCM orig_str)
341
SCM buf, str = orig_str;
344
get_str_buf_start (&str, &buf, &start);
345
if (IS_RO_STRING (str))
346
scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
348
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
349
if (STRINGBUF_SHARED (buf))
351
/* Clone stringbuf. For this, we put all threads to sleep.
354
size_t len = STRING_LENGTH (str);
357
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
359
new_buf = make_stringbuf (len);
360
memcpy (STRINGBUF_CHARS (new_buf),
361
STRINGBUF_CHARS (buf) + STRING_START (str), len);
363
scm_i_thread_put_to_sleep ();
364
SET_STRING_STRINGBUF (str, new_buf);
365
start -= STRING_START (str);
366
SET_STRING_START (str, 0);
367
scm_i_thread_wake_up ();
371
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
374
return STRINGBUF_CHARS (buf) + start;
378
scm_i_string_stop_writing (void)
380
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
385
Basic symbol creation and accessing is done here, the rest is in
386
symbols.[hc]. This has been done to keep stringbufs and the
387
internals of strings and string-like objects confined to this file.
390
#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
393
scm_i_make_symbol (SCM name, scm_t_bits flags,
394
unsigned long hash, SCM props)
397
size_t start = STRING_START (name);
398
size_t length = STRING_LENGTH (name);
400
if (IS_SH_STRING (name))
402
name = SH_STRING_STRING (name);
403
start += STRING_START (name);
405
buf = SYMBOL_STRINGBUF (name);
407
if (start == 0 && length == STRINGBUF_LENGTH (buf))
410
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
411
SET_STRINGBUF_SHARED (buf);
412
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
417
SCM new_buf = make_stringbuf (length);
418
memcpy (STRINGBUF_CHARS (new_buf),
419
STRINGBUF_CHARS (buf) + start, length);
422
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
423
(scm_t_bits) hash, SCM_UNPACK (props));
427
scm_i_c_make_symbol (const char *name, size_t len,
428
scm_t_bits flags, unsigned long hash, SCM props)
430
SCM buf = make_stringbuf (len);
431
memcpy (STRINGBUF_CHARS (buf), name, len);
433
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
434
(scm_t_bits) hash, SCM_UNPACK (props));
437
/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
438
underlying storage. */
440
scm_i_c_take_symbol (char *name, size_t len,
441
scm_t_bits flags, unsigned long hash, SCM props)
443
SCM buf = scm_i_take_stringbufn (name, len);
445
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
446
(scm_t_bits) hash, SCM_UNPACK (props));
450
scm_i_symbol_length (SCM sym)
452
return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
456
scm_i_symbol_chars (SCM sym)
458
SCM buf = SYMBOL_STRINGBUF (sym);
459
return STRINGBUF_CHARS (buf);
463
scm_i_symbol_mark (SCM sym)
465
scm_gc_mark (SYMBOL_STRINGBUF (sym));
466
return SCM_CELL_OBJECT_3 (sym);
470
scm_i_symbol_free (SCM sym)
475
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
477
SCM buf = SYMBOL_STRINGBUF (sym);
478
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
479
SET_STRINGBUF_SHARED (buf);
480
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
481
return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
482
(scm_t_bits)start, (scm_t_bits) end - start);
490
SCM scm_sys_string_dump (SCM);
491
SCM scm_sys_symbol_dump (SCM);
492
SCM scm_sys_stringbuf_hist (void);
494
SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
497
#define FUNC_NAME s_scm_sys_string_dump
499
SCM_VALIDATE_STRING (1, str);
500
fprintf (stderr, "%p:\n", str);
501
fprintf (stderr, " start: %u\n", STRING_START (str));
502
fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
503
if (IS_SH_STRING (str))
505
fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
506
fprintf (stderr, "\n");
507
scm_sys_string_dump (SH_STRING_STRING (str));
511
SCM buf = STRING_STRINGBUF (str);
512
fprintf (stderr, " buf: %p\n", buf);
513
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
514
fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
515
fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
517
return SCM_UNSPECIFIED;
521
SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
524
#define FUNC_NAME s_scm_sys_symbol_dump
526
SCM_VALIDATE_SYMBOL (1, sym);
527
fprintf (stderr, "%p:\n", sym);
528
fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
530
SCM buf = SYMBOL_STRINGBUF (sym);
531
fprintf (stderr, " buf: %p\n", buf);
532
fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
533
fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
534
fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
536
return SCM_UNSPECIFIED;
540
SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
543
#define FUNC_NAME s_scm_sys_stringbuf_hist
546
for (i = 0; i < 1000; i++)
548
fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
549
fprintf (stderr, ">999: %u\n", lenhist[1000]);
550
return SCM_UNSPECIFIED;
558
SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
560
"Return @code{#t} if @var{obj} is a string, else @code{#f}.")
561
#define FUNC_NAME s_scm_string_p
563
return scm_from_bool (IS_STRING (obj));
568
SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
570
SCM_DEFINE (scm_string, "string", 0, 0, 1,
572
"@deffnx {Scheme Procedure} list->string chrs\n"
573
"Return a newly allocated string composed of the arguments,\n"
575
#define FUNC_NAME s_scm_string
582
long i = scm_ilength (chrs);
584
SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
588
result = scm_i_make_string (len, &data);
589
while (len > 0 && scm_is_pair (chrs))
591
SCM elt = SCM_CAR (chrs);
593
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
594
*data++ = SCM_CHAR (elt);
595
chrs = SCM_CDR (chrs);
599
scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
600
if (!scm_is_null (chrs))
601
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
607
SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
609
"Return a newly allocated string of\n"
610
"length @var{k}. If @var{chr} is given, then all elements of\n"
611
"the string are initialized to @var{chr}, otherwise the contents\n"
612
"of the @var{string} are unspecified.")
613
#define FUNC_NAME s_scm_make_string
615
return scm_c_make_string (scm_to_size_t (k), chr);
620
scm_c_make_string (size_t len, SCM chr)
621
#define FUNC_NAME NULL
624
SCM res = scm_i_make_string (len, &dst);
626
if (!SCM_UNBNDP (chr))
628
SCM_VALIDATE_CHAR (0, chr);
629
memset (dst, SCM_CHAR (chr), len);
636
SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
638
"Return the number of characters in @var{string}.")
639
#define FUNC_NAME s_scm_string_length
641
SCM_VALIDATE_STRING (1, string);
642
return scm_from_size_t (STRING_LENGTH (string));
647
scm_c_string_length (SCM string)
649
if (!IS_STRING (string))
650
scm_wrong_type_arg_msg (NULL, 0, string, "string");
651
return STRING_LENGTH (string);
654
SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
656
"Return character @var{k} of @var{str} using zero-origin\n"
657
"indexing. @var{k} must be a valid index of @var{str}.")
658
#define FUNC_NAME s_scm_string_ref
662
SCM_VALIDATE_STRING (1, str);
663
idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
664
return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
669
scm_c_string_ref (SCM str, size_t p)
671
if (p >= scm_i_string_length (str))
672
scm_out_of_range (NULL, scm_from_size_t (p));
673
return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
676
SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
677
(SCM str, SCM k, SCM chr),
678
"Store @var{chr} in element @var{k} of @var{str} and return\n"
679
"an unspecified value. @var{k} must be a valid index of\n"
681
#define FUNC_NAME s_scm_string_set_x
685
SCM_VALIDATE_STRING (1, str);
686
idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
687
SCM_VALIDATE_CHAR (3, chr);
689
char *dst = scm_i_string_writable_chars (str);
690
dst[idx] = SCM_CHAR (chr);
691
scm_i_string_stop_writing ();
693
return SCM_UNSPECIFIED;
698
scm_c_string_set_x (SCM str, size_t p, SCM chr)
700
if (p >= scm_i_string_length (str))
701
scm_out_of_range (NULL, scm_from_size_t (p));
703
char *dst = scm_i_string_writable_chars (str);
704
dst[p] = SCM_CHAR (chr);
705
scm_i_string_stop_writing ();
709
SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
710
(SCM str, SCM start, SCM end),
711
"Return a newly allocated string formed from the characters\n"
712
"of @var{str} beginning with index @var{start} (inclusive) and\n"
713
"ending with index @var{end} (exclusive).\n"
714
"@var{str} must be a string, @var{start} and @var{end} must be\n"
715
"exact integers satisfying:\n\n"
716
"0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
717
#define FUNC_NAME s_scm_substring
719
size_t len, from, to;
721
SCM_VALIDATE_STRING (1, str);
722
len = scm_i_string_length (str);
723
from = scm_to_unsigned_integer (start, 0, len);
724
if (SCM_UNBNDP (end))
727
to = scm_to_unsigned_integer (end, from, len);
728
return scm_i_substring (str, from, to);
732
SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0,
733
(SCM str, SCM start, SCM end),
734
"Return a newly allocated string formed from the characters\n"
735
"of @var{str} beginning with index @var{start} (inclusive) and\n"
736
"ending with index @var{end} (exclusive).\n"
737
"@var{str} must be a string, @var{start} and @var{end} must be\n"
738
"exact integers satisfying:\n"
740
"0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
742
"The returned string is read-only.\n")
743
#define FUNC_NAME s_scm_substring_read_only
745
size_t len, from, to;
747
SCM_VALIDATE_STRING (1, str);
748
len = scm_i_string_length (str);
749
from = scm_to_unsigned_integer (start, 0, len);
750
if (SCM_UNBNDP (end))
753
to = scm_to_unsigned_integer (end, from, len);
754
return scm_i_substring_read_only (str, from, to);
758
SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
759
(SCM str, SCM start, SCM end),
760
"Return a newly allocated string formed from the characters\n"
761
"of @var{str} beginning with index @var{start} (inclusive) and\n"
762
"ending with index @var{end} (exclusive).\n"
763
"@var{str} must be a string, @var{start} and @var{end} must be\n"
764
"exact integers satisfying:\n\n"
765
"0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
766
#define FUNC_NAME s_scm_substring_copy
768
/* For the Scheme version, START is mandatory, but for the C
769
version, it is optional. See scm_string_copy in srfi-13.c for a
775
SCM_VALIDATE_STRING (1, str);
776
scm_i_get_substring_spec (scm_i_string_length (str),
777
start, &from, end, &to);
778
return scm_i_substring_copy (str, from, to);
782
SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
783
(SCM str, SCM start, SCM end),
784
"Return string that indirectly refers to the characters\n"
785
"of @var{str} beginning with index @var{start} (inclusive) and\n"
786
"ending with index @var{end} (exclusive).\n"
787
"@var{str} must be a string, @var{start} and @var{end} must be\n"
788
"exact integers satisfying:\n\n"
789
"0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
790
#define FUNC_NAME s_scm_substring_shared
792
size_t len, from, to;
794
SCM_VALIDATE_STRING (1, str);
795
len = scm_i_string_length (str);
796
from = scm_to_unsigned_integer (start, 0, len);
797
if (SCM_UNBNDP (end))
800
to = scm_to_unsigned_integer (end, from, len);
801
return scm_i_substring_shared (str, from, to);
805
SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
807
"Return a newly allocated string whose characters form the\n"
808
"concatenation of the given strings, @var{args}.")
809
#define FUNC_NAME s_scm_string_append
816
SCM_VALIDATE_REST_ARGUMENT (args);
817
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
820
SCM_VALIDATE_STRING (SCM_ARGn, s);
821
i += scm_i_string_length (s);
823
res = scm_i_make_string (i, &data);
824
for (l = args; !scm_is_null (l); l = SCM_CDR (l))
828
SCM_VALIDATE_STRING (SCM_ARGn, s);
829
len = scm_i_string_length (s);
830
memcpy (data, scm_i_string_chars (s), len);
832
scm_remember_upto_here_1 (s);
839
scm_is_string (SCM obj)
841
return IS_STRING (obj);
845
scm_from_locale_stringn (const char *str, size_t len)
850
if (len == (size_t)-1)
852
res = scm_i_make_string (len, &dst);
853
memcpy (dst, str, len);
858
scm_from_locale_string (const char *str)
860
return scm_from_locale_stringn (str, -1);
864
scm_take_locale_stringn (char *str, size_t len)
868
if (len == (size_t)-1)
872
/* Ensure STR is null terminated. A realloc for 1 extra byte should
873
often be satisfied from the alignment padding after the block, with
874
no actual data movement. */
875
str = scm_realloc (str, len+1);
879
buf = scm_i_take_stringbufn (str, len);
880
res = scm_double_cell (STRING_TAG,
882
(scm_t_bits) 0, (scm_t_bits) len);
887
scm_take_locale_string (char *str)
889
return scm_take_locale_stringn (str, -1);
893
scm_to_locale_stringn (SCM str, size_t *lenp)
898
if (!scm_is_string (str))
899
scm_wrong_type_arg_msg (NULL, 0, str, "string");
900
len = scm_i_string_length (str);
901
res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
902
memcpy (res, scm_i_string_chars (str), len);
906
if (strlen (res) != len)
909
scm_misc_error (NULL,
910
"string contains #\\nul character: ~S",
917
scm_remember_upto_here_1 (str);
922
scm_to_locale_string (SCM str)
924
return scm_to_locale_stringn (str, NULL);
928
scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
932
if (!scm_is_string (str))
933
scm_wrong_type_arg_msg (NULL, 0, str, "string");
934
len = scm_i_string_length (str);
935
memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
936
scm_remember_upto_here_1 (str);
940
/* converts C scm_array of strings to SCM scm_list of strings. */
941
/* If argc < 0, a null terminated scm_array is assumed. */
943
scm_makfromstrs (int argc, char **argv)
948
for (i = 0; argv[i]; i++);
950
lst = scm_cons (scm_from_locale_string (argv[i]), lst);
954
/* Return a newly allocated array of char pointers to each of the strings
955
in args, with a terminating NULL pointer. */
958
scm_i_allocate_string_pointers (SCM list)
961
int len = scm_ilength (list);
965
scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
967
scm_dynwind_begin (0);
969
result = (char **) scm_malloc ((len + 1) * sizeof (char *));
971
scm_dynwind_unwind_handler (free, result, 0);
973
/* The list might be have been modified in another thread, so
974
we check LIST before each access.
976
for (i = 0; i < len && scm_is_pair (list); i++)
978
result[i] = scm_to_locale_string (SCM_CAR (list));
979
list = SCM_CDR (list);
987
scm_i_free_string_pointers (char **pointers)
991
for (i = 0; pointers[i]; i++)
997
scm_i_get_substring_spec (size_t len,
998
SCM start, size_t *cstart,
999
SCM end, size_t *cend)
1001
if (SCM_UNBNDP (start))
1004
*cstart = scm_to_unsigned_integer (start, 0, len);
1006
if (SCM_UNBNDP (end))
1009
*cend = scm_to_unsigned_integer (end, *cstart, len);
1012
#if SCM_ENABLE_DEPRECATED
1014
/* When these definitions are removed, it becomes reasonable to use
1015
read-only strings for string literals. For that, change the reader
1016
to create string literals with scm_c_substring_read_only instead of
1017
with scm_c_substring_copy.
1021
scm_i_deprecated_stringp (SCM str)
1023
scm_c_issue_deprecation_warning
1024
("SCM_STRINGP is deprecated. Use scm_is_string instead.");
1026
return scm_is_string (str);
1030
scm_i_deprecated_string_chars (SCM str)
1034
scm_c_issue_deprecation_warning
1035
("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
1037
/* We don't accept shared substrings here since they are not
1040
if (IS_SH_STRING (str))
1041
scm_misc_error (NULL,
1042
"SCM_STRING_CHARS does not work with shared substrings.",
1045
/* We explicitely test for read-only strings to produce a better
1049
if (IS_RO_STRING (str))
1050
scm_misc_error (NULL,
1051
"SCM_STRING_CHARS does not work with read-only strings.",
1054
/* The following is still wrong, of course...
1056
chars = scm_i_string_writable_chars (str);
1057
scm_i_string_stop_writing ();
1062
scm_i_deprecated_string_length (SCM str)
1064
scm_c_issue_deprecation_warning
1065
("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
1066
return scm_c_string_length (str);
1074
scm_nullstr = scm_i_make_string (0, NULL);
1076
#include "libguile/strings.x"
added
removed
libguile/strings.c
