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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
30 #include "libguile/_scm.h"
31 #include "libguile/chars.h"
32 #include "libguile/root.h"
33 #include "libguile/strings.h"
34 #include "libguile/deprecation.h"
35 #include "libguile/validate.h"
36 #include "libguile/dynwind.h"
46 * XXX - keeping an accurate refcount during GC seems to be quite
47 * tricky, so we just keep score of whether a stringbuf might be
48 * shared, not wether it definitely is.
50 * The scheme I (mvo) tried to keep an accurate reference count would
51 * recount all strings that point to a stringbuf during the mark-phase
52 * of the GC. This was done since one cannot access the stringbuf of
53 * a string when that string is freed (in order to decrease the
54 * reference count). The memory of the stringbuf might have been
55 * reused already for something completely different.
57 * This recounted worked for a small number of threads beating on
58 * cow-strings, but it failed randomly with more than 10 threads, say.
59 * I couldn't figure out what went wrong, so I used the conservative
60 * approach implemented below.
62 * A stringbuf needs to know its length, but only so that it can be
63 * reported when the stringbuf is freed.
65 * Stringbufs (and strings) are not stored very compactly: a stringbuf
66 * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
67 * information. As a compensation, the code below is made more
68 * complicated by storing small strings inline in the double cell of a
69 * stringbuf. So we have fixstrings and bigstrings...
72 #define STRINGBUF_F_SHARED 0x100
73 #define STRINGBUF_F_INLINE 0x200
74 #define STRINGBUF_F_WIDE 0x400
76 #define STRINGBUF_TAG scm_tc7_stringbuf
77 #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
78 #define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
79 #define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
81 #define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
82 #define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
83 #define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
84 #define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
86 #define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
87 ? STRINGBUF_INLINE_CHARS (buf) \
88 : STRINGBUF_OUTLINE_CHARS (buf))
89 #define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf))
90 #define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
91 ? STRINGBUF_INLINE_LENGTH (buf) \
92 : STRINGBUF_OUTLINE_LENGTH (buf))
94 #define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
96 #define SET_STRINGBUF_SHARED(buf) \
97 (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
100 static size_t lenhist
[1001];
104 make_stringbuf (size_t len
)
106 /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
107 scm_i_symbol_chars, all stringbufs are null-terminated. Once
108 SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
109 has been changed for scm_i_symbol_chars, this null-termination
120 if (len
<= STRINGBUF_MAX_INLINE_LEN
-1)
122 return scm_double_cell (STRINGBUF_TAG
| STRINGBUF_F_INLINE
| (len
<< 16),
127 char *mem
= scm_gc_malloc (len
+1, "string");
129 return scm_double_cell (STRINGBUF_TAG
, (scm_t_bits
) mem
,
130 (scm_t_bits
) len
, (scm_t_bits
) 0);
135 make_wide_stringbuf (size_t len
)
145 mem
= scm_gc_malloc (sizeof (scm_t_wchar
) * (len
+ 1), "string");
147 return scm_double_cell (STRINGBUF_TAG
| STRINGBUF_F_WIDE
, (scm_t_bits
) mem
,
148 (scm_t_bits
) len
, (scm_t_bits
) 0);
151 /* Return a new stringbuf whose underlying storage consists of the LEN+1
152 octets pointed to by STR (the last octet is zero). */
154 scm_i_take_stringbufn (char *str
, size_t len
)
156 scm_gc_register_collectable_memory (str
, len
+ 1, "stringbuf");
158 return scm_double_cell (STRINGBUF_TAG
, (scm_t_bits
) str
,
159 (scm_t_bits
) len
, (scm_t_bits
) 0);
163 scm_i_stringbuf_mark (SCM buf
)
169 scm_i_stringbuf_free (SCM buf
)
171 if (!STRINGBUF_INLINE (buf
))
173 if (!STRINGBUF_WIDE (buf
))
174 scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf
),
175 STRINGBUF_OUTLINE_LENGTH (buf
) + 1, "string");
177 scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf
),
178 sizeof (scm_t_wchar
) * (STRINGBUF_OUTLINE_LENGTH (buf
)
185 widen_stringbuf (SCM buf
)
190 if (STRINGBUF_WIDE (buf
))
193 if (STRINGBUF_INLINE (buf
))
195 len
= STRINGBUF_INLINE_LENGTH (buf
);
197 mem
= scm_gc_malloc (sizeof (scm_t_wchar
) * (len
+ 1), "string");
198 for (i
= 0; i
< len
; i
++)
200 (scm_t_wchar
) (unsigned char) STRINGBUF_INLINE_CHARS (buf
)[i
];
203 SCM_SET_CELL_WORD_0 (buf
, SCM_CELL_WORD_0 (buf
) ^ STRINGBUF_F_INLINE
);
204 SCM_SET_CELL_WORD_0 (buf
, SCM_CELL_WORD_0 (buf
) | STRINGBUF_F_WIDE
);
205 SCM_SET_CELL_WORD_1 (buf
, mem
);
206 SCM_SET_CELL_WORD_2 (buf
, len
);
210 len
= STRINGBUF_OUTLINE_LENGTH (buf
);
212 mem
= scm_gc_malloc (sizeof (scm_t_wchar
) * (len
+ 1), "string");
213 for (i
= 0; i
< len
; i
++)
215 (scm_t_wchar
) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf
)[i
];
218 scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf
), len
+ 1, "string");
220 SCM_SET_CELL_WORD_0 (buf
, SCM_CELL_WORD_0 (buf
) | STRINGBUF_F_WIDE
);
221 SCM_SET_CELL_WORD_1 (buf
, mem
);
222 SCM_SET_CELL_WORD_2 (buf
, len
);
226 scm_i_pthread_mutex_t stringbuf_write_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
228 /* Copy-on-write strings.
231 #define STRING_TAG scm_tc7_string
233 #define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
234 #define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
235 #define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
237 #define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
238 #define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
240 #define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
242 /* Read-only strings.
245 #define RO_STRING_TAG (scm_tc7_string + 0x200)
246 #define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
248 /* Mutation-sharing substrings
251 #define SH_STRING_TAG (scm_tc7_string + 0x100)
253 #define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
254 /* START and LENGTH as for STRINGs. */
256 #define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
259 scm_i_make_string (size_t len
, char **charsp
)
261 SCM buf
= make_stringbuf (len
);
264 *charsp
= STRINGBUF_CHARS (buf
);
265 res
= scm_double_cell (STRING_TAG
, SCM_UNPACK(buf
),
266 (scm_t_bits
)0, (scm_t_bits
) len
);
271 scm_i_make_wide_string (size_t len
, scm_t_wchar
** charsp
)
273 SCM buf
= make_wide_stringbuf (len
);
276 *charsp
= STRINGBUF_WIDE_CHARS (buf
);
277 res
= scm_double_cell (STRING_TAG
, SCM_UNPACK (buf
),
278 (scm_t_bits
) 0, (scm_t_bits
) len
);
283 validate_substring_args (SCM str
, size_t start
, size_t end
)
285 if (!IS_STRING (str
))
286 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
287 if (start
> STRING_LENGTH (str
))
288 scm_out_of_range (NULL
, scm_from_size_t (start
));
289 if (end
> STRING_LENGTH (str
) || end
< start
)
290 scm_out_of_range (NULL
, scm_from_size_t (end
));
294 get_str_buf_start (SCM
*str
, SCM
*buf
, size_t *start
)
296 *start
= STRING_START (*str
);
297 if (IS_SH_STRING (*str
))
299 *str
= SH_STRING_STRING (*str
);
300 *start
+= STRING_START (*str
);
302 *buf
= STRING_STRINGBUF (*str
);
306 scm_i_substring (SCM str
, size_t start
, size_t end
)
310 get_str_buf_start (&str
, &buf
, &str_start
);
311 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
312 SET_STRINGBUF_SHARED (buf
);
313 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
314 return scm_double_cell (STRING_TAG
, SCM_UNPACK(buf
),
315 (scm_t_bits
)str_start
+ start
,
316 (scm_t_bits
) end
- start
);
320 scm_i_substring_read_only (SCM str
, size_t start
, size_t end
)
324 get_str_buf_start (&str
, &buf
, &str_start
);
325 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
326 SET_STRINGBUF_SHARED (buf
);
327 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
328 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK(buf
),
329 (scm_t_bits
)str_start
+ start
,
330 (scm_t_bits
) end
- start
);
334 scm_i_substring_copy (SCM str
, size_t start
, size_t end
)
336 size_t len
= end
- start
;
339 get_str_buf_start (&str
, &buf
, &str_start
);
340 if (scm_i_is_narrow_string (str
))
342 my_buf
= make_stringbuf (len
);
343 memcpy (STRINGBUF_CHARS (my_buf
),
344 STRINGBUF_CHARS (buf
) + str_start
+ start
, len
);
348 my_buf
= make_wide_stringbuf (len
);
349 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (my_buf
),
350 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
) + str_start
352 /* Even though this string is wide, the substring may be narrow.
353 Consider adding code to narrow string. */
355 scm_remember_upto_here_1 (buf
);
356 return scm_double_cell (STRING_TAG
, SCM_UNPACK (my_buf
),
357 (scm_t_bits
) 0, (scm_t_bits
) len
);
361 scm_i_substring_shared (SCM str
, size_t start
, size_t end
)
363 if (start
== 0 && end
== STRING_LENGTH (str
))
367 size_t len
= end
- start
;
368 if (IS_SH_STRING (str
))
370 start
+= STRING_START (str
);
371 str
= SH_STRING_STRING (str
);
373 return scm_double_cell (SH_STRING_TAG
, SCM_UNPACK(str
),
374 (scm_t_bits
)start
, (scm_t_bits
) len
);
379 scm_c_substring (SCM str
, size_t start
, size_t end
)
381 validate_substring_args (str
, start
, end
);
382 return scm_i_substring (str
, start
, end
);
386 scm_c_substring_read_only (SCM str
, size_t start
, size_t end
)
388 validate_substring_args (str
, start
, end
);
389 return scm_i_substring_read_only (str
, start
, end
);
393 scm_c_substring_copy (SCM str
, size_t start
, size_t end
)
395 validate_substring_args (str
, start
, end
);
396 return scm_i_substring_copy (str
, start
, end
);
400 scm_c_substring_shared (SCM str
, size_t start
, size_t end
)
402 validate_substring_args (str
, start
, end
);
403 return scm_i_substring_shared (str
, start
, end
);
407 scm_i_string_mark (SCM str
)
409 if (IS_SH_STRING (str
))
410 return SH_STRING_STRING (str
);
412 return STRING_STRINGBUF (str
);
416 scm_i_string_free (SCM str
)
420 /* Internal accessors
424 scm_i_string_length (SCM str
)
426 return STRING_LENGTH (str
);
430 scm_i_is_narrow_string (SCM str
)
432 return !STRINGBUF_WIDE (STRING_STRINGBUF (str
));
436 scm_i_string_chars (SCM str
)
440 get_str_buf_start (&str
, &buf
, &start
);
441 if (scm_i_is_narrow_string (str
))
442 return STRINGBUF_CHARS (buf
) + start
;
444 scm_misc_error (NULL
, "Invalid read access of chars of wide string: ~s",
450 scm_i_string_wide_chars (SCM str
)
455 get_str_buf_start (&str
, &buf
, &start
);
456 if (!scm_i_is_narrow_string (str
))
457 return STRINGBUF_WIDE_CHARS (buf
) + start
;
459 scm_misc_error (NULL
, "Invalid read access of chars of narrow string: ~s",
463 /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
464 a new string buffer, so that it can be modified without modifying
467 scm_i_string_start_writing (SCM orig_str
)
469 SCM buf
, str
= orig_str
;
472 get_str_buf_start (&str
, &buf
, &start
);
473 if (IS_RO_STRING (str
))
474 scm_misc_error (NULL
, "string is read-only: ~s", scm_list_1 (orig_str
));
476 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
477 if (STRINGBUF_SHARED (buf
))
479 /* Clone the stringbuf. */
480 size_t len
= STRING_LENGTH (str
);
483 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
485 if (scm_i_is_narrow_string (str
))
487 new_buf
= make_stringbuf (len
);
488 memcpy (STRINGBUF_CHARS (new_buf
),
489 STRINGBUF_CHARS (buf
) + STRING_START (str
), len
);
494 new_buf
= make_wide_stringbuf (len
);
495 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
496 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
)
497 + STRING_START (str
)), len
);
499 scm_i_thread_put_to_sleep ();
500 SET_STRING_STRINGBUF (str
, new_buf
);
501 start
-= STRING_START (str
);
502 SET_STRING_START (str
, 0);
503 scm_i_thread_wake_up ();
507 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
512 /* Return a pointer to the chars of a string that fits in a Latin-1
515 scm_i_string_writable_chars (SCM str
)
520 get_str_buf_start (&str
, &buf
, &start
);
521 if (scm_i_is_narrow_string (str
))
522 return STRINGBUF_CHARS (buf
) + start
;
524 scm_misc_error (NULL
, "Invalid write access of chars of wide string: ~s",
529 /* Return a pointer to the Unicode codepoints of a string. */
531 scm_i_string_writable_wide_chars (SCM str
)
536 get_str_buf_start (&str
, &buf
, &start
);
537 if (!scm_i_is_narrow_string (str
))
538 return STRINGBUF_WIDE_CHARS (buf
) + start
;
540 scm_misc_error (NULL
, "Invalid read access of chars of narrow string: ~s",
545 scm_i_string_stop_writing (void)
547 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
550 /* Return the Xth character is C. */
552 scm_i_string_ref (SCM str
, size_t x
)
554 if (scm_i_is_narrow_string (str
))
555 return (scm_t_wchar
) (unsigned char) (scm_i_string_chars (str
)[x
]);
557 return scm_i_string_wide_chars (str
)[x
];
561 scm_i_string_set_x (SCM str
, size_t p
, scm_t_wchar chr
)
563 if (chr
> 0xFF && scm_i_is_narrow_string (str
))
564 widen_stringbuf (STRING_STRINGBUF (str
));
566 if (scm_i_is_narrow_string (str
))
568 char *dst
= scm_i_string_writable_chars (str
);
569 dst
[p
] = (char) (unsigned char) chr
;
573 scm_t_wchar
*dst
= scm_i_string_writable_wide_chars (str
);
580 Basic symbol creation and accessing is done here, the rest is in
581 symbols.[hc]. This has been done to keep stringbufs and the
582 internals of strings and string-like objects confined to this file.
585 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
588 scm_i_make_symbol (SCM name
, scm_t_bits flags
,
589 unsigned long hash
, SCM props
)
592 size_t start
= STRING_START (name
);
593 size_t length
= STRING_LENGTH (name
);
595 if (IS_SH_STRING (name
))
597 name
= SH_STRING_STRING (name
);
598 start
+= STRING_START (name
);
600 buf
= SYMBOL_STRINGBUF (name
);
602 if (start
== 0 && length
== STRINGBUF_LENGTH (buf
))
605 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
606 SET_STRINGBUF_SHARED (buf
);
607 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
612 if (scm_i_is_narrow_string (name
))
614 SCM new_buf
= make_stringbuf (length
);
615 memcpy (STRINGBUF_CHARS (new_buf
),
616 STRINGBUF_CHARS (buf
) + start
, length
);
621 SCM new_buf
= make_wide_stringbuf (length
);
622 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
623 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
) + start
,
628 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
629 (scm_t_bits
) hash
, SCM_UNPACK (props
));
633 scm_i_c_make_symbol (const char *name
, size_t len
,
634 scm_t_bits flags
, unsigned long hash
, SCM props
)
636 SCM buf
= make_stringbuf (len
);
637 memcpy (STRINGBUF_CHARS (buf
), name
, len
);
639 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
640 (scm_t_bits
) hash
, SCM_UNPACK (props
));
643 /* Return a new symbol that uses the LEN bytes pointed to by NAME as its
644 underlying storage. */
646 scm_i_c_take_symbol (char *name
, size_t len
,
647 scm_t_bits flags
, unsigned long hash
, SCM props
)
649 SCM buf
= scm_i_take_stringbufn (name
, len
);
651 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
652 (scm_t_bits
) hash
, SCM_UNPACK (props
));
656 scm_i_symbol_length (SCM sym
)
658 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
662 scm_c_symbol_length (SCM sym
)
663 #define FUNC_NAME "scm_c_symbol_length"
665 SCM_VALIDATE_SYMBOL (1, sym
);
667 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
672 scm_i_is_narrow_symbol (SCM sym
)
676 buf
= SYMBOL_STRINGBUF (sym
);
677 return !STRINGBUF_WIDE (buf
);
681 scm_i_symbol_chars (SCM sym
)
685 buf
= SYMBOL_STRINGBUF (sym
);
686 if (!STRINGBUF_WIDE (buf
))
687 return STRINGBUF_CHARS (buf
);
689 scm_misc_error (NULL
, "Invalid access of chars of a wide symbol ~S",
693 /* Return a pointer to the Unicode codepoints of a symbol's name. */
695 scm_i_symbol_wide_chars (SCM sym
)
699 buf
= SYMBOL_STRINGBUF (sym
);
700 if (STRINGBUF_WIDE (buf
))
701 return STRINGBUF_WIDE_CHARS (buf
);
703 scm_misc_error (NULL
, "Invalid access of chars of a narrow symbol ~S",
708 scm_i_symbol_mark (SCM sym
)
710 scm_gc_mark (SYMBOL_STRINGBUF (sym
));
711 return SCM_CELL_OBJECT_3 (sym
);
715 scm_i_symbol_free (SCM sym
)
720 scm_i_symbol_substring (SCM sym
, size_t start
, size_t end
)
722 SCM buf
= SYMBOL_STRINGBUF (sym
);
723 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
724 SET_STRINGBUF_SHARED (buf
);
725 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
726 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK (buf
),
727 (scm_t_bits
)start
, (scm_t_bits
) end
- start
);
731 scm_i_symbol_ref (SCM sym
, size_t x
)
733 if (scm_i_is_narrow_symbol (sym
))
734 return (scm_t_wchar
) (unsigned char) (scm_i_symbol_chars (sym
)[x
]);
736 return scm_i_symbol_wide_chars (sym
)[x
];
744 SCM
scm_sys_string_dump (SCM
);
745 SCM
scm_sys_symbol_dump (SCM
);
746 SCM
scm_sys_stringbuf_hist (void);
748 SCM_DEFINE (scm_sys_string_dump
, "%string-dump", 1, 0, 0, (SCM str
), "")
749 #define FUNC_NAME s_scm_sys_string_dump
751 SCM_VALIDATE_STRING (1, str
);
752 fprintf (stderr
, "%p:\n", str
);
753 fprintf (stderr
, " start: %u\n", STRING_START (str
));
754 fprintf (stderr
, " len: %u\n", STRING_LENGTH (str
));
755 if (scm_i_is_narrow_string (str
))
756 fprintf (stderr
, " format: narrow\n");
758 fprintf (stderr
, " format: wide\n");
759 if (IS_SH_STRING (str
))
761 fprintf (stderr
, " string: %p\n", SH_STRING_STRING (str
));
762 fprintf (stderr
, "\n");
763 scm_sys_string_dump (SH_STRING_STRING (str
));
767 SCM buf
= STRING_STRINGBUF (str
);
768 fprintf (stderr
, " buf: %p\n", buf
);
769 if (scm_i_is_narrow_string (str
))
770 fprintf (stderr
, " chars: %p\n", STRINGBUF_CHARS (buf
));
772 fprintf (stderr
, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf
));
773 fprintf (stderr
, " length: %u\n", STRINGBUF_LENGTH (buf
));
774 if (STRINGBUF_SHARED (buf
))
775 fprintf (stderr
, " shared: true\n");
777 fprintf (stderr
, " shared: false\n");
778 if (STRINGBUF_INLINE (buf
))
779 fprintf (stderr
, " inline: true\n");
781 fprintf (stderr
, " inline: false\n");
784 return SCM_UNSPECIFIED
;
788 SCM_DEFINE (scm_sys_symbol_dump
, "%symbol-dump", 1, 0, 0, (SCM sym
), "")
789 #define FUNC_NAME s_scm_sys_symbol_dump
791 SCM_VALIDATE_SYMBOL (1, sym
);
792 fprintf (stderr
, "%p:\n", sym
);
793 fprintf (stderr
, " hash: %lu\n", scm_i_symbol_hash (sym
));
794 if (scm_i_is_narrow_symbol (sym
))
795 fprintf (stderr
, " format: narrow\n");
797 fprintf (stderr
, " format: wide\n");
799 SCM buf
= SYMBOL_STRINGBUF (sym
);
800 fprintf (stderr
, " buf: %p\n", buf
);
801 if (scm_i_is_narrow_symbol (sym
))
802 fprintf (stderr
, " chars: %p\n", STRINGBUF_CHARS (buf
));
804 fprintf (stderr
, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf
));
805 fprintf (stderr
, " length: %u\n", STRINGBUF_LENGTH (buf
));
806 if (STRINGBUF_SHARED (buf
))
807 fprintf (stderr
, " shared: true\n");
809 fprintf (stderr
, " shared: false\n");
812 return SCM_UNSPECIFIED
;
816 SCM_DEFINE (scm_sys_stringbuf_hist
, "%stringbuf-hist", 0, 0, 0, (void), "")
817 #define FUNC_NAME s_scm_sys_stringbuf_hist
820 for (i
= 0; i
< 1000; i
++)
822 fprintf (stderr
, " %3d: %u\n", i
, lenhist
[i
]);
823 fprintf (stderr
, ">999: %u\n", lenhist
[1000]);
824 return SCM_UNSPECIFIED
;
832 SCM_DEFINE (scm_string_p
, "string?", 1, 0, 0,
834 "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
835 #define FUNC_NAME s_scm_string_p
837 return scm_from_bool (IS_STRING (obj
));
842 SCM_REGISTER_PROC (s_scm_list_to_string
, "list->string", 1, 0, 0, scm_string
);
844 SCM_DEFINE (scm_string
, "string", 0, 0, 1,
846 "@deffnx {Scheme Procedure} list->string chrs\n"
847 "Return a newly allocated string composed of the arguments,\n"
849 #define FUNC_NAME s_scm_string
857 /* Verify that this is a list of chars. */
858 i
= scm_ilength (chrs
);
862 SCM_ASSERT (len
>= 0, chrs
, SCM_ARG1
, FUNC_NAME
);
863 while (len
> 0 && scm_is_pair (rest
))
865 SCM elt
= SCM_CAR (rest
);
866 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
867 rest
= SCM_CDR (rest
);
869 scm_remember_upto_here_1 (elt
);
872 /* Construct a string containing this list of chars. */
876 result
= scm_i_make_string (len
, NULL
);
877 result
= scm_i_string_start_writing (result
);
878 while (len
> 0 && scm_is_pair (rest
))
880 SCM elt
= SCM_CAR (rest
);
881 scm_i_string_set_x (result
, p
, SCM_CHAR (elt
));
883 rest
= SCM_CDR (rest
);
885 scm_remember_upto_here_1 (elt
);
887 scm_i_string_stop_writing ();
890 scm_misc_error (NULL
, "list changed while constructing string", SCM_EOL
);
891 if (!scm_is_null (rest
))
892 scm_wrong_type_arg_msg (NULL
, 0, chrs
, "proper list");
898 SCM_DEFINE (scm_make_string
, "make-string", 1, 1, 0,
900 "Return a newly allocated string of\n"
901 "length @var{k}. If @var{chr} is given, then all elements of\n"
902 "the string are initialized to @var{chr}, otherwise the contents\n"
903 "of the @var{string} are unspecified.")
904 #define FUNC_NAME s_scm_make_string
906 return scm_c_make_string (scm_to_size_t (k
), chr
);
911 scm_c_make_string (size_t len
, SCM chr
)
912 #define FUNC_NAME NULL
915 SCM res
= scm_i_make_string (len
, NULL
);
917 if (!SCM_UNBNDP (chr
))
919 SCM_VALIDATE_CHAR (0, chr
);
920 res
= scm_i_string_start_writing (res
);
921 for (p
= 0; p
< len
; p
++)
922 scm_i_string_set_x (res
, p
, SCM_CHAR (chr
));
923 scm_i_string_stop_writing ();
930 SCM_DEFINE (scm_string_length
, "string-length", 1, 0, 0,
932 "Return the number of characters in @var{string}.")
933 #define FUNC_NAME s_scm_string_length
935 SCM_VALIDATE_STRING (1, string
);
936 return scm_from_size_t (STRING_LENGTH (string
));
940 SCM_DEFINE (scm_string_width
, "string-width", 1, 0, 0,
942 "Return the bytes used to represent a character in @var{string}."
943 "This will return 1 or 4.")
944 #define FUNC_NAME s_scm_string_width
946 SCM_VALIDATE_STRING (1, string
);
947 if (!scm_i_is_narrow_string (string
))
948 return scm_from_int (4);
950 return scm_from_int (1);
955 scm_c_string_length (SCM string
)
957 if (!IS_STRING (string
))
958 scm_wrong_type_arg_msg (NULL
, 0, string
, "string");
959 return STRING_LENGTH (string
);
962 SCM_DEFINE (scm_string_ref
, "string-ref", 2, 0, 0,
964 "Return character @var{k} of @var{str} using zero-origin\n"
965 "indexing. @var{k} must be a valid index of @var{str}.")
966 #define FUNC_NAME s_scm_string_ref
971 SCM_VALIDATE_STRING (1, str
);
973 len
= scm_i_string_length (str
);
974 if (SCM_LIKELY (len
> 0))
975 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
977 scm_out_of_range (NULL
, k
);
979 if (scm_i_is_narrow_string (str
))
980 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[idx
]);
982 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[idx
]);
987 scm_c_string_ref (SCM str
, size_t p
)
989 if (p
>= scm_i_string_length (str
))
990 scm_out_of_range (NULL
, scm_from_size_t (p
));
991 if (scm_i_is_narrow_string (str
))
992 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[p
]);
994 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[p
]);
998 SCM_DEFINE (scm_string_set_x
, "string-set!", 3, 0, 0,
999 (SCM str
, SCM k
, SCM chr
),
1000 "Store @var{chr} in element @var{k} of @var{str} and return\n"
1001 "an unspecified value. @var{k} must be a valid index of\n"
1003 #define FUNC_NAME s_scm_string_set_x
1008 SCM_VALIDATE_STRING (1, str
);
1010 len
= scm_i_string_length (str
);
1011 if (SCM_LIKELY (len
> 0))
1012 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1014 scm_out_of_range (NULL
, k
);
1016 SCM_VALIDATE_CHAR (3, chr
);
1017 str
= scm_i_string_start_writing (str
);
1018 scm_i_string_set_x (str
, idx
, SCM_CHAR (chr
));
1019 scm_i_string_stop_writing ();
1021 return SCM_UNSPECIFIED
;
1026 scm_c_string_set_x (SCM str
, size_t p
, SCM chr
)
1028 if (p
>= scm_i_string_length (str
))
1029 scm_out_of_range (NULL
, scm_from_size_t (p
));
1030 str
= scm_i_string_start_writing (str
);
1031 scm_i_string_set_x (str
, p
, SCM_CHAR (chr
));
1032 scm_i_string_stop_writing ();
1035 SCM_DEFINE (scm_substring
, "substring", 2, 1, 0,
1036 (SCM str
, SCM start
, SCM end
),
1037 "Return a newly allocated string formed from the characters\n"
1038 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1039 "ending with index @var{end} (exclusive).\n"
1040 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1041 "exact integers satisfying:\n\n"
1042 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1043 #define FUNC_NAME s_scm_substring
1045 size_t len
, from
, to
;
1047 SCM_VALIDATE_STRING (1, str
);
1048 len
= scm_i_string_length (str
);
1049 from
= scm_to_unsigned_integer (start
, 0, len
);
1050 if (SCM_UNBNDP (end
))
1053 to
= scm_to_unsigned_integer (end
, from
, len
);
1054 return scm_i_substring (str
, from
, to
);
1058 SCM_DEFINE (scm_substring_read_only
, "substring/read-only", 2, 1, 0,
1059 (SCM str
, SCM start
, SCM end
),
1060 "Return a newly allocated string formed from the characters\n"
1061 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1062 "ending with index @var{end} (exclusive).\n"
1063 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1064 "exact integers satisfying:\n"
1066 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
1068 "The returned string is read-only.\n")
1069 #define FUNC_NAME s_scm_substring_read_only
1071 size_t len
, from
, to
;
1073 SCM_VALIDATE_STRING (1, str
);
1074 len
= scm_i_string_length (str
);
1075 from
= scm_to_unsigned_integer (start
, 0, len
);
1076 if (SCM_UNBNDP (end
))
1079 to
= scm_to_unsigned_integer (end
, from
, len
);
1080 return scm_i_substring_read_only (str
, from
, to
);
1084 SCM_DEFINE (scm_substring_copy
, "substring/copy", 2, 1, 0,
1085 (SCM str
, SCM start
, SCM end
),
1086 "Return a newly allocated string formed from the characters\n"
1087 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1088 "ending with index @var{end} (exclusive).\n"
1089 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1090 "exact integers satisfying:\n\n"
1091 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1092 #define FUNC_NAME s_scm_substring_copy
1094 /* For the Scheme version, START is mandatory, but for the C
1095 version, it is optional. See scm_string_copy in srfi-13.c for a
1101 SCM_VALIDATE_STRING (1, str
);
1102 scm_i_get_substring_spec (scm_i_string_length (str
),
1103 start
, &from
, end
, &to
);
1104 return scm_i_substring_copy (str
, from
, to
);
1108 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
1109 (SCM str
, SCM start
, SCM end
),
1110 "Return string that indirectly refers to the characters\n"
1111 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1112 "ending with index @var{end} (exclusive).\n"
1113 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1114 "exact integers satisfying:\n\n"
1115 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1116 #define FUNC_NAME s_scm_substring_shared
1118 size_t len
, from
, to
;
1120 SCM_VALIDATE_STRING (1, str
);
1121 len
= scm_i_string_length (str
);
1122 from
= scm_to_unsigned_integer (start
, 0, len
);
1123 if (SCM_UNBNDP (end
))
1126 to
= scm_to_unsigned_integer (end
, from
, len
);
1127 return scm_i_substring_shared (str
, from
, to
);
1131 SCM_DEFINE (scm_string_append
, "string-append", 0, 0, 1,
1133 "Return a newly allocated string whose characters form the\n"
1134 "concatenation of the given strings, @var{args}.")
1135 #define FUNC_NAME s_scm_string_append
1145 SCM_VALIDATE_REST_ARGUMENT (args
);
1146 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1149 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1150 len
+= scm_i_string_length (s
);
1151 if (!scm_i_is_narrow_string (s
))
1155 res
= scm_i_make_string (len
, &data
);
1157 res
= scm_i_make_wide_string (len
, &wdata
);
1159 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1163 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1164 len
= scm_i_string_length (s
);
1167 memcpy (data
, scm_i_string_chars (s
), len
);
1172 if (scm_i_is_narrow_string (s
))
1174 for (i
= 0; i
< scm_i_string_length (s
); i
++)
1175 wdata
[i
] = (unsigned char) scm_i_string_chars (s
)[i
];
1178 u32_cpy ((scm_t_uint32
*) wdata
,
1179 (scm_t_uint32
*) scm_i_string_wide_chars (s
), len
);
1182 scm_remember_upto_here_1 (s
);
1189 scm_is_string (SCM obj
)
1191 return IS_STRING (obj
);
1195 scm_from_locale_stringn (const char *str
, size_t len
)
1200 if (len
== (size_t) -1)
1205 res
= scm_i_make_string (len
, &dst
);
1206 memcpy (dst
, str
, len
);
1211 scm_from_locale_string (const char *str
)
1216 return scm_from_locale_stringn (str
, -1);
1220 scm_take_locale_stringn (char *str
, size_t len
)
1224 if (len
== (size_t) -1)
1228 /* Ensure STR is null terminated. A realloc for 1 extra byte should
1229 often be satisfied from the alignment padding after the block, with
1230 no actual data movement. */
1231 str
= scm_realloc (str
, len
+ 1);
1235 buf
= scm_i_take_stringbufn (str
, len
);
1236 res
= scm_double_cell (STRING_TAG
,
1237 SCM_UNPACK (buf
), (scm_t_bits
) 0, (scm_t_bits
) len
);
1242 scm_take_locale_string (char *str
)
1244 return scm_take_locale_stringn (str
, -1);
1247 /* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
1250 unistring_escapes_to_guile_escapes (char **bufp
, size_t *lenp
)
1252 char *before
, *after
;
1261 if ((i
<= *lenp
- 6)
1262 && before
[i
] == '\\'
1263 && before
[i
+ 1] == 'u'
1264 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1266 /* Convert \u00NN to \xNN */
1269 after
[j
+ 2] = tolower (before
[i
+ 4]);
1270 after
[j
+ 3] = tolower (before
[i
+ 5]);
1274 else if ((i
<= *lenp
- 10)
1275 && before
[i
] == '\\'
1276 && before
[i
+ 1] == 'U'
1277 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1279 /* Convert \U00NNNNNN to \UNNNNNN */
1282 after
[j
+ 2] = tolower (before
[i
+ 4]);
1283 after
[j
+ 3] = tolower (before
[i
+ 5]);
1284 after
[j
+ 4] = tolower (before
[i
+ 6]);
1285 after
[j
+ 5] = tolower (before
[i
+ 7]);
1286 after
[j
+ 6] = tolower (before
[i
+ 8]);
1287 after
[j
+ 7] = tolower (before
[i
+ 9]);
1293 after
[j
] = before
[i
];
1299 after
= scm_realloc (after
, j
);
1303 scm_to_locale_stringn (SCM str
, size_t * lenp
)
1307 /* In the future, enc will hold the port's encoding. */
1310 return scm_to_stringn (str
, lenp
, enc
, iconveh_escape_sequence
);
1313 /* Low-level scheme to C string conversion function. */
1315 scm_to_stringn (SCM str
, size_t * lenp
, const char *encoding
,
1316 enum iconv_ilseq_handler handler
)
1318 static const char iso
[11] = "ISO-8859-1";
1320 size_t ilen
, len
, i
;
1322 if (!scm_is_string (str
))
1323 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
1324 ilen
= scm_i_string_length (str
);
1328 buf
= scm_malloc (1);
1336 for (i
= 0; i
< ilen
; i
++)
1337 if (scm_i_string_ref (str
, i
) == '\0')
1338 scm_misc_error (NULL
,
1339 "string contains #\\nul character: ~S",
1342 if (scm_i_is_narrow_string (str
))
1346 buf
= scm_malloc (ilen
);
1347 memcpy (buf
, scm_i_string_chars (str
), ilen
);
1353 buf
= scm_malloc (ilen
+ 1);
1354 memcpy (buf
, scm_i_string_chars (str
), ilen
);
1363 buf
= u32_conv_to_encoding (iso
,
1365 (scm_t_uint32
*) scm_i_string_wide_chars (str
),
1366 ilen
, NULL
, NULL
, &len
);
1368 scm_misc_error (NULL
, "cannot convert to output locale ~s: \"~s\"",
1369 scm_list_2 (scm_from_locale_string (iso
), str
));
1371 if (handler
== iconveh_escape_sequence
)
1372 unistring_escapes_to_guile_escapes (&buf
, &len
);
1378 buf
= scm_realloc (buf
, len
+ 1);
1382 scm_remember_upto_here_1 (str
);
1387 scm_to_locale_string (SCM str
)
1389 return scm_to_locale_stringn (str
, NULL
);
1393 scm_to_locale_stringbuf (SCM str
, char *buf
, size_t max_len
)
1396 char *result
= NULL
;
1397 if (!scm_is_string (str
))
1398 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
1399 result
= scm_to_locale_stringn (str
, &len
);
1401 memcpy (buf
, result
, (len
> max_len
) ? max_len
: len
);
1404 scm_remember_upto_here_1 (str
);
1408 /* converts C scm_array of strings to SCM scm_list of strings. */
1409 /* If argc < 0, a null terminated scm_array is assumed. */
1411 scm_makfromstrs (int argc
, char **argv
)
1416 for (i
= 0; argv
[i
]; i
++);
1418 lst
= scm_cons (scm_from_locale_string (argv
[i
]), lst
);
1422 /* Return a newly allocated array of char pointers to each of the strings
1423 in args, with a terminating NULL pointer. */
1426 scm_i_allocate_string_pointers (SCM list
)
1429 int len
= scm_ilength (list
);
1433 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
1435 scm_dynwind_begin (0);
1437 result
= (char **) scm_malloc ((len
+ 1) * sizeof (char *));
1439 scm_dynwind_unwind_handler (free
, result
, 0);
1441 /* The list might be have been modified in another thread, so
1442 we check LIST before each access.
1444 for (i
= 0; i
< len
&& scm_is_pair (list
); i
++)
1446 result
[i
] = scm_to_locale_string (SCM_CAR (list
));
1447 list
= SCM_CDR (list
);
1455 scm_i_free_string_pointers (char **pointers
)
1459 for (i
= 0; pointers
[i
]; i
++)
1465 scm_i_get_substring_spec (size_t len
,
1466 SCM start
, size_t *cstart
,
1467 SCM end
, size_t *cend
)
1469 if (SCM_UNBNDP (start
))
1472 *cstart
= scm_to_unsigned_integer (start
, 0, len
);
1474 if (SCM_UNBNDP (end
))
1477 *cend
= scm_to_unsigned_integer (end
, *cstart
, len
);
1480 #if SCM_ENABLE_DEPRECATED
1482 /* When these definitions are removed, it becomes reasonable to use
1483 read-only strings for string literals. For that, change the reader
1484 to create string literals with scm_c_substring_read_only instead of
1485 with scm_c_substring_copy.
1489 scm_i_deprecated_stringp (SCM str
)
1491 scm_c_issue_deprecation_warning
1492 ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
1494 return scm_is_string (str
);
1498 scm_i_deprecated_string_chars (SCM str
)
1502 scm_c_issue_deprecation_warning
1503 ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
1505 /* We don't accept shared substrings here since they are not
1508 if (IS_SH_STRING (str
))
1509 scm_misc_error (NULL
,
1510 "SCM_STRING_CHARS does not work with shared substrings.",
1513 /* We explicitly test for read-only strings to produce a better
1517 if (IS_RO_STRING (str
))
1518 scm_misc_error (NULL
,
1519 "SCM_STRING_CHARS does not work with read-only strings.",
1522 /* The following is still wrong, of course...
1524 str
= scm_i_string_start_writing (str
);
1525 chars
= scm_i_string_writable_chars (str
);
1526 scm_i_string_stop_writing ();
1531 scm_i_deprecated_string_length (SCM str
)
1533 scm_c_issue_deprecation_warning
1534 ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
1535 return scm_c_string_length (str
);
1543 scm_nullstr
= scm_i_make_string (0, NULL
);
1545 #include "libguile/strings.x"