1 /* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012 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
33 #include "striconveh.h"
35 #include "libguile/_scm.h"
36 #include "libguile/chars.h"
37 #include "libguile/root.h"
38 #include "libguile/strings.h"
39 #include "libguile/error.h"
40 #include "libguile/generalized-vectors.h"
41 #include "libguile/deprecation.h"
42 #include "libguile/validate.h"
43 #include "libguile/private-options.h"
53 * XXX - keeping an accurate refcount during GC seems to be quite
54 * tricky, so we just keep score of whether a stringbuf might be
55 * shared, not whether it definitely is.
57 * The scheme I (mvo) tried to keep an accurate reference count would
58 * recount all strings that point to a stringbuf during the mark-phase
59 * of the GC. This was done since one cannot access the stringbuf of
60 * a string when that string is freed (in order to decrease the
61 * reference count). The memory of the stringbuf might have been
62 * reused already for something completely different.
64 * This recounted worked for a small number of threads beating on
65 * cow-strings, but it failed randomly with more than 10 threads, say.
66 * I couldn't figure out what went wrong, so I used the conservative
67 * approach implemented below.
69 * There are 2 storage strategies for stringbufs: 8-bit and wide. 8-bit
70 * strings are ISO-8859-1-encoded strings; wide strings are 32-bit (UCS-4)
74 /* The size in words of the stringbuf header (type tag + size). */
75 #define STRINGBUF_HEADER_SIZE 2U
77 #define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM))
79 #define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED
80 #define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE
82 #define STRINGBUF_TAG scm_tc7_stringbuf
83 #define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
84 #define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
86 #define STRINGBUF_CONTENTS(buf) ((void *) \
87 SCM_CELL_OBJECT_LOC (buf, \
88 STRINGBUF_HEADER_SIZE))
89 #define STRINGBUF_CHARS(buf) ((unsigned char *) STRINGBUF_CONTENTS (buf))
90 #define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CONTENTS (buf))
92 #define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf))
94 #define SET_STRINGBUF_SHARED(buf) \
97 /* Don't modify BUF if it's already marked as shared since it might be \
98 a read-only, statically allocated stringbuf. */ \
99 if (SCM_LIKELY (!STRINGBUF_SHARED (buf))) \
100 SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED); \
104 #ifdef SCM_STRING_LENGTH_HISTOGRAM
105 static size_t lenhist
[1001];
108 /* Make a stringbuf with space for LEN 8-bit Latin-1-encoded
111 make_stringbuf (size_t len
)
113 /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
114 scm_i_symbol_chars, all stringbufs are null-terminated. Once
115 SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
116 has been changed for scm_i_symbol_chars, this null-termination
122 #ifdef SCM_STRING_LENGTH_HISTOGRAM
129 buf
= PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES
+ len
+ 1,
132 SCM_SET_CELL_TYPE (buf
, STRINGBUF_TAG
);
133 SCM_SET_CELL_WORD_1 (buf
, (scm_t_bits
) len
);
135 STRINGBUF_CHARS (buf
)[len
] = 0;
140 /* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
143 make_wide_stringbuf (size_t len
)
148 #ifdef SCM_STRING_LENGTH_HISTOGRAM
155 raw_len
= (len
+ 1) * sizeof (scm_t_wchar
);
156 buf
= PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES
+ raw_len
,
159 SCM_SET_CELL_TYPE (buf
, STRINGBUF_TAG
| STRINGBUF_F_WIDE
);
160 SCM_SET_CELL_WORD_1 (buf
, (scm_t_bits
) len
);
162 STRINGBUF_WIDE_CHARS (buf
)[len
] = 0;
167 /* Return a UCS-4-encoded stringbuf containing the (possibly Latin-1-encoded)
168 characters from BUF. */
170 wide_stringbuf (SCM buf
)
174 if (STRINGBUF_WIDE (buf
))
181 len
= STRINGBUF_LENGTH (buf
);
183 new_buf
= make_wide_stringbuf (len
);
185 mem
= STRINGBUF_WIDE_CHARS (new_buf
);
186 for (i
= 0; i
< len
; i
++)
187 mem
[i
] = (scm_t_wchar
) STRINGBUF_CHARS (buf
)[i
];
194 /* Return a Latin-1-encoded stringbuf containing the (possibly UCS-4-encoded)
195 characters from BUF, if possible. */
197 narrow_stringbuf (SCM buf
)
201 if (!STRINGBUF_WIDE (buf
))
209 len
= STRINGBUF_LENGTH (buf
);
210 wmem
= STRINGBUF_WIDE_CHARS (buf
);
212 for (i
= 0; i
< len
; i
++)
214 /* BUF cannot be narrowed. */
217 new_buf
= make_stringbuf (len
);
219 mem
= STRINGBUF_CHARS (new_buf
);
220 for (i
= 0; i
< len
; i
++)
221 mem
[i
] = (unsigned char) wmem
[i
];
228 scm_i_pthread_mutex_t stringbuf_write_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
231 /* Copy-on-write strings.
234 #define STRING_TAG scm_tc7_string
236 #define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
237 #define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
238 #define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
240 #define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
241 #define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
243 #define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
245 /* Read-only strings.
248 #define RO_STRING_TAG scm_tc7_ro_string
249 #define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
251 /* Mutation-sharing substrings
254 #define SH_STRING_TAG (scm_tc7_string + 0x100)
256 #define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
257 /* START and LENGTH as for STRINGs. */
259 #define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
263 /* Create a scheme string with space for LEN 8-bit Latin-1-encoded
264 characters. CHARSP, if not NULL, will be set to location of the
265 char array. If READ_ONLY_P, the returned string is read-only;
266 otherwise it is writable. */
268 scm_i_make_string (size_t len
, char **charsp
, int read_only_p
)
270 SCM buf
= make_stringbuf (len
);
273 *charsp
= (char *) STRINGBUF_CHARS (buf
);
274 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
276 (scm_t_bits
) 0, (scm_t_bits
) len
);
280 /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
281 characters. CHARSP, if not NULL, will be set to location of the
282 character array. If READ_ONLY_P, the returned string is read-only;
283 otherwise it is writable. */
285 scm_i_make_wide_string (size_t len
, scm_t_wchar
**charsp
, int read_only_p
)
287 SCM buf
= make_wide_stringbuf (len
);
290 *charsp
= STRINGBUF_WIDE_CHARS (buf
);
291 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
293 (scm_t_bits
) 0, (scm_t_bits
) len
);
298 validate_substring_args (SCM str
, size_t start
, size_t end
)
300 if (!IS_STRING (str
))
301 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
302 if (start
> STRING_LENGTH (str
))
303 scm_out_of_range (NULL
, scm_from_size_t (start
));
304 if (end
> STRING_LENGTH (str
) || end
< start
)
305 scm_out_of_range (NULL
, scm_from_size_t (end
));
309 get_str_buf_start (SCM
*str
, SCM
*buf
, size_t *start
)
311 *start
= STRING_START (*str
);
312 if (IS_SH_STRING (*str
))
314 *str
= SH_STRING_STRING (*str
);
315 *start
+= STRING_START (*str
);
317 *buf
= STRING_STRINGBUF (*str
);
321 scm_i_substring (SCM str
, size_t start
, size_t end
)
325 get_str_buf_start (&str
, &buf
, &str_start
);
326 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
327 SET_STRINGBUF_SHARED (buf
);
328 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
329 return scm_double_cell (STRING_TAG
, SCM_UNPACK(buf
),
330 (scm_t_bits
)str_start
+ start
,
331 (scm_t_bits
) end
- start
);
335 scm_i_substring_read_only (SCM str
, size_t start
, size_t end
)
339 get_str_buf_start (&str
, &buf
, &str_start
);
340 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
341 SET_STRINGBUF_SHARED (buf
);
342 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
343 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK(buf
),
344 (scm_t_bits
)str_start
+ start
,
345 (scm_t_bits
) end
- start
);
349 scm_i_substring_copy (SCM str
, size_t start
, size_t end
)
351 size_t len
= end
- start
;
352 SCM buf
, my_buf
, substr
;
355 get_str_buf_start (&str
, &buf
, &str_start
);
356 if (scm_i_is_narrow_string (str
))
358 my_buf
= make_stringbuf (len
);
359 memcpy (STRINGBUF_CHARS (my_buf
),
360 STRINGBUF_CHARS (buf
) + str_start
+ start
, len
);
364 my_buf
= make_wide_stringbuf (len
);
365 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (my_buf
),
366 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
) + str_start
370 scm_remember_upto_here_1 (buf
);
371 substr
= scm_double_cell (STRING_TAG
, SCM_UNPACK (my_buf
),
372 (scm_t_bits
) 0, (scm_t_bits
) len
);
374 scm_i_try_narrow_string (substr
);
379 scm_i_substring_shared (SCM str
, size_t start
, size_t end
)
381 if (start
== 0 && end
== STRING_LENGTH (str
))
385 size_t len
= end
- start
;
386 if (IS_SH_STRING (str
))
388 start
+= STRING_START (str
);
389 str
= SH_STRING_STRING (str
);
391 return scm_double_cell (SH_STRING_TAG
, SCM_UNPACK(str
),
392 (scm_t_bits
)start
, (scm_t_bits
) len
);
397 scm_c_substring (SCM str
, size_t start
, size_t end
)
399 validate_substring_args (str
, start
, end
);
400 return scm_i_substring (str
, start
, end
);
404 scm_c_substring_read_only (SCM str
, size_t start
, size_t end
)
406 validate_substring_args (str
, start
, end
);
407 return scm_i_substring_read_only (str
, start
, end
);
411 scm_c_substring_copy (SCM str
, size_t start
, size_t end
)
413 validate_substring_args (str
, start
, end
);
414 return scm_i_substring_copy (str
, start
, end
);
418 scm_c_substring_shared (SCM str
, size_t start
, size_t end
)
420 validate_substring_args (str
, start
, end
);
421 return scm_i_substring_shared (str
, start
, end
);
425 /* Internal accessors
428 /* Returns the number of characters in STR. This may be different
429 than the memory size of the string storage. */
431 scm_i_string_length (SCM str
)
433 return STRING_LENGTH (str
);
436 /* True if the string is 'narrow', meaning it has a 8-bit Latin-1
437 encoding. False if it is 'wide', having a 32-bit UCS-4
440 scm_i_is_narrow_string (SCM str
)
442 if (IS_SH_STRING (str
))
443 str
= SH_STRING_STRING (str
);
445 return !STRINGBUF_WIDE (STRING_STRINGBUF (str
));
448 /* Try to coerce a string to be narrow. It if is narrow already, do
449 nothing. If it is wide, shrink it to narrow if none of its
450 characters are above 0xFF. Return true if the string is narrow or
451 was made to be narrow. */
453 scm_i_try_narrow_string (SCM str
)
455 if (IS_SH_STRING (str
))
456 str
= SH_STRING_STRING (str
);
458 SET_STRING_STRINGBUF (str
, narrow_stringbuf (STRING_STRINGBUF (str
)));
460 return scm_i_is_narrow_string (str
);
463 /* Return a pointer to the raw data of the string, which can be either Latin-1
464 or UCS-4 encoded data, depending on `scm_i_is_narrow_string (STR)'. */
466 scm_i_string_data (SCM str
)
472 get_str_buf_start (&str
, &buf
, &start
);
474 data
= STRINGBUF_CONTENTS (buf
);
475 data
+= start
* (scm_i_is_narrow_string (str
) ? 1 : 4);
480 /* Returns a pointer to the 8-bit Latin-1 encoded character array of
483 scm_i_string_chars (SCM str
)
487 get_str_buf_start (&str
, &buf
, &start
);
488 if (scm_i_is_narrow_string (str
))
489 return (const char *) STRINGBUF_CHARS (buf
) + start
;
491 scm_misc_error (NULL
, "Invalid read access of chars of wide string: ~s",
496 /* Returns a pointer to the 32-bit UCS-4 encoded character array of
499 scm_i_string_wide_chars (SCM str
)
504 get_str_buf_start (&str
, &buf
, &start
);
505 if (!scm_i_is_narrow_string (str
))
506 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
) + start
;
508 scm_misc_error (NULL
, "Invalid read access of chars of narrow string: ~s",
512 /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
513 a new string buffer, so that it can be modified without modifying
514 other strings. Also, lock the string mutex. Later, one must call
515 scm_i_string_stop_writing to unlock the mutex. */
517 scm_i_string_start_writing (SCM orig_str
)
519 SCM buf
, str
= orig_str
;
522 get_str_buf_start (&str
, &buf
, &start
);
523 if (IS_RO_STRING (str
))
524 scm_misc_error (NULL
, "string is read-only: ~s", scm_list_1 (orig_str
));
526 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
527 if (STRINGBUF_SHARED (buf
))
529 /* Clone the stringbuf. */
530 size_t len
= STRING_LENGTH (str
);
533 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
535 if (scm_i_is_narrow_string (str
))
537 new_buf
= make_stringbuf (len
);
538 memcpy (STRINGBUF_CHARS (new_buf
),
539 STRINGBUF_CHARS (buf
) + STRING_START (str
), len
);
544 new_buf
= make_wide_stringbuf (len
);
545 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
546 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
)
547 + STRING_START (str
)), len
);
550 SET_STRING_STRINGBUF (str
, new_buf
);
551 start
-= STRING_START (str
);
553 /* FIXME: The following operations are not atomic, so other threads
554 looking at STR may see an inconsistent state. Nevertheless it can't
555 hurt much since (i) accessing STR while it is being mutated can't
556 yield a crash, and (ii) concurrent accesses to STR should be
557 protected by a mutex at the application level. The latter may not
558 apply when STR != ORIG_STR, though. */
559 SET_STRING_START (str
, 0);
560 SET_STRING_STRINGBUF (str
, new_buf
);
564 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
569 /* Return a pointer to the 8-bit Latin-1 chars of a string. */
571 scm_i_string_writable_chars (SCM str
)
576 get_str_buf_start (&str
, &buf
, &start
);
577 if (scm_i_is_narrow_string (str
))
578 return (char *) STRINGBUF_CHARS (buf
) + start
;
580 scm_misc_error (NULL
, "Invalid write access of chars of wide string: ~s",
585 /* Return a pointer to the UCS-4 codepoints of a string. */
587 scm_i_string_writable_wide_chars (SCM str
)
592 get_str_buf_start (&str
, &buf
, &start
);
593 if (!scm_i_is_narrow_string (str
))
594 return STRINGBUF_WIDE_CHARS (buf
) + start
;
596 scm_misc_error (NULL
, "Invalid write access of chars of narrow string: ~s",
600 /* Unlock the string mutex that was locked when
601 scm_i_string_start_writing was called. */
603 scm_i_string_stop_writing (void)
605 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
608 /* Return the Xth character of STR as a UCS-4 codepoint. */
610 scm_i_string_ref (SCM str
, size_t x
)
612 if (scm_i_is_narrow_string (str
))
613 return (scm_t_wchar
) (unsigned char) (scm_i_string_chars (str
)[x
]);
615 return scm_i_string_wide_chars (str
)[x
];
618 /* Returns index+1 of the first char in STR that matches C, or
619 0 if the char is not found. */
621 scm_i_string_contains_char (SCM str
, char ch
)
624 size_t len
= scm_i_string_length (str
);
627 if (scm_i_is_narrow_string (str
))
631 if (scm_i_string_chars (str
)[i
] == ch
)
640 if (scm_i_string_wide_chars (str
)[i
]
641 == (unsigned char) ch
)
650 scm_i_string_strcmp (SCM sstr
, size_t start_x
, const char *cstr
)
652 if (scm_i_is_narrow_string (sstr
))
654 const char *a
= scm_i_string_chars (sstr
) + start_x
;
655 const char *b
= cstr
;
656 return strncmp (a
, b
, strlen(b
));
661 const scm_t_wchar
*a
= scm_i_string_wide_chars (sstr
) + start_x
;
662 const char *b
= cstr
;
663 for (i
= 0; i
< strlen (b
); i
++)
665 if (a
[i
] != (unsigned char) b
[i
])
672 /* Set the Pth character of STR to UCS-4 codepoint CHR. */
674 scm_i_string_set_x (SCM str
, size_t p
, scm_t_wchar chr
)
676 if (IS_SH_STRING (str
))
678 p
+= STRING_START (str
);
679 str
= SH_STRING_STRING (str
);
682 if (chr
> 0xFF && scm_i_is_narrow_string (str
))
683 SET_STRING_STRINGBUF (str
, wide_stringbuf (STRING_STRINGBUF (str
)));
685 if (scm_i_is_narrow_string (str
))
687 char *dst
= scm_i_string_writable_chars (str
);
692 scm_t_wchar
*dst
= scm_i_string_writable_wide_chars (str
);
700 Basic symbol creation and accessing is done here, the rest is in
701 symbols.[hc]. This has been done to keep stringbufs and the
702 internals of strings and string-like objects confined to this file.
705 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
708 scm_i_make_symbol (SCM name
, scm_t_bits flags
,
709 unsigned long hash
, SCM props
)
712 size_t start
= STRING_START (name
);
713 size_t length
= STRING_LENGTH (name
);
715 if (IS_SH_STRING (name
))
717 name
= SH_STRING_STRING (name
);
718 start
+= STRING_START (name
);
720 buf
= SYMBOL_STRINGBUF (name
);
722 if (start
== 0 && length
== STRINGBUF_LENGTH (buf
))
725 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
726 SET_STRINGBUF_SHARED (buf
);
727 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
732 if (scm_i_is_narrow_string (name
))
734 SCM new_buf
= make_stringbuf (length
);
735 memcpy (STRINGBUF_CHARS (new_buf
),
736 STRINGBUF_CHARS (buf
) + start
, length
);
741 SCM new_buf
= make_wide_stringbuf (length
);
742 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
743 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
) + start
,
748 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
749 (scm_t_bits
) hash
, SCM_UNPACK (props
));
753 scm_i_c_make_symbol (const char *name
, size_t len
,
754 scm_t_bits flags
, unsigned long hash
, SCM props
)
756 SCM buf
= make_stringbuf (len
);
757 memcpy (STRINGBUF_CHARS (buf
), name
, len
);
759 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
760 (scm_t_bits
) hash
, SCM_UNPACK (props
));
763 /* Returns the number of characters in SYM. This may be different
764 from the memory size of SYM. */
766 scm_i_symbol_length (SCM sym
)
768 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
772 scm_c_symbol_length (SCM sym
)
773 #define FUNC_NAME "scm_c_symbol_length"
775 SCM_VALIDATE_SYMBOL (1, sym
);
777 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
781 /* True if the name of SYM is stored as a Latin-1 encoded string.
782 False if it is stored as a 32-bit UCS-4-encoded string. */
784 scm_i_is_narrow_symbol (SCM sym
)
788 buf
= SYMBOL_STRINGBUF (sym
);
789 return !STRINGBUF_WIDE (buf
);
792 /* Returns a pointer to the 8-bit Latin-1 encoded character array that
793 contains the name of SYM. */
795 scm_i_symbol_chars (SCM sym
)
799 buf
= SYMBOL_STRINGBUF (sym
);
800 if (!STRINGBUF_WIDE (buf
))
801 return (const char *) STRINGBUF_CHARS (buf
);
803 scm_misc_error (NULL
, "Invalid access of chars of a wide symbol ~S",
807 /* Return a pointer to the 32-bit UCS-4-encoded character array of a
810 scm_i_symbol_wide_chars (SCM sym
)
814 buf
= SYMBOL_STRINGBUF (sym
);
815 if (STRINGBUF_WIDE (buf
))
816 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
);
818 scm_misc_error (NULL
, "Invalid access of chars of a narrow symbol ~S",
823 scm_i_symbol_substring (SCM sym
, size_t start
, size_t end
)
825 SCM buf
= SYMBOL_STRINGBUF (sym
);
826 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
827 SET_STRINGBUF_SHARED (buf
);
828 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
829 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK (buf
),
830 (scm_t_bits
)start
, (scm_t_bits
) end
- start
);
833 /* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
835 scm_i_symbol_ref (SCM sym
, size_t x
)
837 if (scm_i_is_narrow_symbol (sym
))
838 return (scm_t_wchar
) (unsigned char) (scm_i_symbol_chars (sym
)[x
]);
840 return scm_i_symbol_wide_chars (sym
)[x
];
846 SCM_DEFINE (scm_sys_string_dump
, "%string-dump", 1, 0, 0, (SCM str
),
847 "Returns an association list containing debugging information\n"
848 "for @var{str}. The association list has the following entries."
851 "The string itself.\n"
853 "The start index of the string into its stringbuf\n"
855 "The length of the string\n"
857 "If this string is a substring, it returns its parent string.\n"
858 "Otherwise, it returns @code{#f}\n"
860 "@code{#t} if the string is read-only\n"
861 "@item stringbuf-chars\n"
862 "A new string containing this string's stringbuf's characters\n"
863 "@item stringbuf-length\n"
864 "The number of characters in this stringbuf\n"
865 "@item stringbuf-shared\n"
866 "@code{#t} if this stringbuf is shared\n"
867 "@item stringbuf-wide\n"
868 "@code{#t} if this stringbuf's characters are stored in a\n"
869 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
872 #define FUNC_NAME s_scm_sys_string_dump
874 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
;
876 SCM_VALIDATE_STRING (1, str
);
879 e1
= scm_cons (scm_from_latin1_symbol ("string"),
881 e2
= scm_cons (scm_from_latin1_symbol ("start"),
882 scm_from_size_t (STRING_START (str
)));
883 e3
= scm_cons (scm_from_latin1_symbol ("length"),
884 scm_from_size_t (STRING_LENGTH (str
)));
886 if (IS_SH_STRING (str
))
888 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
889 SH_STRING_STRING (str
));
890 buf
= STRING_STRINGBUF (SH_STRING_STRING (str
));
894 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
896 buf
= STRING_STRINGBUF (str
);
899 if (IS_RO_STRING (str
))
900 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
903 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
907 if (!STRINGBUF_WIDE (buf
))
909 size_t len
= STRINGBUF_LENGTH (buf
);
911 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
912 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
913 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
918 size_t len
= STRINGBUF_LENGTH (buf
);
920 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
921 u32_cpy ((scm_t_uint32
*) cbuf
,
922 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
923 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
926 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
927 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
928 if (STRINGBUF_SHARED (buf
))
929 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
932 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
934 if (STRINGBUF_WIDE (buf
))
935 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
938 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
941 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
, SCM_UNDEFINED
);
945 SCM_DEFINE (scm_sys_symbol_dump
, "%symbol-dump", 1, 0, 0, (SCM sym
),
946 "Returns an association list containing debugging information\n"
947 "for @var{sym}. The association list has the following entries."
950 "The symbol itself\n"
954 "@code{#t} if it is an interned symbol\n"
955 "@item stringbuf-chars\n"
956 "A new string containing this symbols's stringbuf's characters\n"
957 "@item stringbuf-length\n"
958 "The number of characters in this stringbuf\n"
959 "@item stringbuf-shared\n"
960 "@code{#t} if this stringbuf is shared\n"
961 "@item stringbuf-wide\n"
962 "@code{#t} if this stringbuf's characters are stored in a\n"
963 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
966 #define FUNC_NAME s_scm_sys_symbol_dump
968 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
;
970 SCM_VALIDATE_SYMBOL (1, sym
);
971 e1
= scm_cons (scm_from_latin1_symbol ("symbol"),
973 e2
= scm_cons (scm_from_latin1_symbol ("hash"),
974 scm_from_ulong (scm_i_symbol_hash (sym
)));
975 e3
= scm_cons (scm_from_latin1_symbol ("interned"),
976 scm_symbol_interned_p (sym
));
977 buf
= SYMBOL_STRINGBUF (sym
);
980 if (!STRINGBUF_WIDE (buf
))
982 size_t len
= STRINGBUF_LENGTH (buf
);
984 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
985 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
986 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
991 size_t len
= STRINGBUF_LENGTH (buf
);
993 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
994 u32_cpy ((scm_t_uint32
*) cbuf
,
995 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
996 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
999 e5
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
1000 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
1001 if (STRINGBUF_SHARED (buf
))
1002 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1005 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1007 if (STRINGBUF_WIDE (buf
))
1008 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1011 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1013 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, SCM_UNDEFINED
);
1018 #ifdef SCM_STRING_LENGTH_HISTOGRAM
1020 SCM_DEFINE (scm_sys_stringbuf_hist
, "%stringbuf-hist", 0, 0, 0, (void), "")
1021 #define FUNC_NAME s_scm_sys_stringbuf_hist
1024 for (i
= 0; i
< 1000; i
++)
1026 fprintf (stderr
, " %3d: %u\n", i
, lenhist
[i
]);
1027 fprintf (stderr
, ">999: %u\n", lenhist
[1000]);
1028 return SCM_UNSPECIFIED
;
1036 SCM_DEFINE (scm_string_p
, "string?", 1, 0, 0,
1038 "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
1039 #define FUNC_NAME s_scm_string_p
1041 return scm_from_bool (IS_STRING (obj
));
1046 SCM_REGISTER_PROC (s_scm_list_to_string
, "list->string", 1, 0, 0, scm_string
);
1048 SCM_DEFINE (scm_string
, "string", 0, 0, 1,
1050 "@deffnx {Scheme Procedure} list->string chrs\n"
1051 "Return a newly allocated string composed of the arguments,\n"
1053 #define FUNC_NAME s_scm_string
1055 SCM result
= SCM_BOOL_F
;
1062 /* Verify that this is a list of chars. */
1063 i
= scm_ilength (chrs
);
1064 SCM_ASSERT (i
>= 0, chrs
, SCM_ARG1
, FUNC_NAME
);
1069 while (len
> 0 && scm_is_pair (rest
))
1071 SCM elt
= SCM_CAR (rest
);
1072 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
1073 if (SCM_CHAR (elt
) > 0xFF)
1075 rest
= SCM_CDR (rest
);
1077 scm_remember_upto_here_1 (elt
);
1080 /* Construct a string containing this list of chars. */
1088 result
= scm_i_make_string (len
, NULL
, 0);
1089 result
= scm_i_string_start_writing (result
);
1090 buf
= scm_i_string_writable_chars (result
);
1091 while (len
> 0 && scm_is_pair (rest
))
1093 SCM elt
= SCM_CAR (rest
);
1094 buf
[p
] = (unsigned char) SCM_CHAR (elt
);
1096 rest
= SCM_CDR (rest
);
1098 scm_remember_upto_here_1 (elt
);
1105 result
= scm_i_make_wide_string (len
, NULL
, 0);
1106 result
= scm_i_string_start_writing (result
);
1107 buf
= scm_i_string_writable_wide_chars (result
);
1108 while (len
> 0 && scm_is_pair (rest
))
1110 SCM elt
= SCM_CAR (rest
);
1111 buf
[p
] = SCM_CHAR (elt
);
1113 rest
= SCM_CDR (rest
);
1115 scm_remember_upto_here_1 (elt
);
1118 scm_i_string_stop_writing ();
1121 scm_misc_error (NULL
, "list changed while constructing string", SCM_EOL
);
1122 if (!scm_is_null (rest
))
1123 scm_wrong_type_arg_msg (NULL
, 0, chrs
, "proper list");
1129 SCM_DEFINE (scm_make_string
, "make-string", 1, 1, 0,
1131 "Return a newly allocated string of\n"
1132 "length @var{k}. If @var{chr} is given, then all elements of\n"
1133 "the string are initialized to @var{chr}, otherwise the contents\n"
1134 "of the @var{string} are all set to @var{#\nul}.")
1135 #define FUNC_NAME s_scm_make_string
1137 return scm_c_make_string (scm_to_size_t (k
), chr
);
1142 scm_c_make_string (size_t len
, SCM chr
)
1143 #define FUNC_NAME NULL
1146 char *contents
= NULL
;
1147 SCM res
= scm_i_make_string (len
, &contents
, 0);
1149 /* If no char is given, initialize string contents to NULL. */
1150 if (SCM_UNBNDP (chr
))
1151 memset (contents
, 0, len
);
1154 SCM_VALIDATE_CHAR (0, chr
);
1155 res
= scm_i_string_start_writing (res
);
1156 for (p
= 0; p
< len
; p
++)
1157 scm_i_string_set_x (res
, p
, SCM_CHAR (chr
));
1158 scm_i_string_stop_writing ();
1165 SCM_DEFINE (scm_string_length
, "string-length", 1, 0, 0,
1167 "Return the number of characters in @var{string}.")
1168 #define FUNC_NAME s_scm_string_length
1170 SCM_VALIDATE_STRING (1, string
);
1171 return scm_from_size_t (STRING_LENGTH (string
));
1175 SCM_DEFINE (scm_string_bytes_per_char
, "string-bytes-per-char", 1, 0, 0,
1177 "Return the bytes used to represent a character in @var{string}."
1178 "This will return 1 or 4.")
1179 #define FUNC_NAME s_scm_string_bytes_per_char
1181 SCM_VALIDATE_STRING (1, string
);
1182 if (!scm_i_is_narrow_string (string
))
1183 return scm_from_int (4);
1185 return scm_from_int (1);
1190 scm_c_string_length (SCM string
)
1192 if (!IS_STRING (string
))
1193 scm_wrong_type_arg_msg (NULL
, 0, string
, "string");
1194 return STRING_LENGTH (string
);
1197 SCM_DEFINE (scm_string_ref
, "string-ref", 2, 0, 0,
1199 "Return character @var{k} of @var{str} using zero-origin\n"
1200 "indexing. @var{k} must be a valid index of @var{str}.")
1201 #define FUNC_NAME s_scm_string_ref
1206 SCM_VALIDATE_STRING (1, str
);
1208 len
= scm_i_string_length (str
);
1209 if (SCM_LIKELY (len
> 0))
1210 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1212 scm_out_of_range (NULL
, k
);
1214 if (scm_i_is_narrow_string (str
))
1215 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[idx
]);
1217 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[idx
]);
1222 scm_c_string_ref (SCM str
, size_t p
)
1224 if (p
>= scm_i_string_length (str
))
1225 scm_out_of_range (NULL
, scm_from_size_t (p
));
1226 if (scm_i_is_narrow_string (str
))
1227 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[p
]);
1229 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[p
]);
1233 SCM_DEFINE (scm_string_set_x
, "string-set!", 3, 0, 0,
1234 (SCM str
, SCM k
, SCM chr
),
1235 "Store @var{chr} in element @var{k} of @var{str} and return\n"
1236 "an unspecified value. @var{k} must be a valid index of\n"
1238 #define FUNC_NAME s_scm_string_set_x
1243 SCM_VALIDATE_STRING (1, str
);
1245 len
= scm_i_string_length (str
);
1246 if (SCM_LIKELY (len
> 0))
1247 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1249 scm_out_of_range (NULL
, k
);
1251 SCM_VALIDATE_CHAR (3, chr
);
1252 str
= scm_i_string_start_writing (str
);
1253 scm_i_string_set_x (str
, idx
, SCM_CHAR (chr
));
1254 scm_i_string_stop_writing ();
1256 return SCM_UNSPECIFIED
;
1261 scm_c_string_set_x (SCM str
, size_t p
, SCM chr
)
1263 if (p
>= scm_i_string_length (str
))
1264 scm_out_of_range (NULL
, scm_from_size_t (p
));
1265 str
= scm_i_string_start_writing (str
);
1266 scm_i_string_set_x (str
, p
, SCM_CHAR (chr
));
1267 scm_i_string_stop_writing ();
1270 SCM_DEFINE (scm_substring
, "substring", 2, 1, 0,
1271 (SCM str
, SCM start
, SCM end
),
1272 "Return a newly allocated string formed from the characters\n"
1273 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1274 "ending with index @var{end} (exclusive).\n"
1275 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1276 "exact integers satisfying:\n\n"
1277 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1278 #define FUNC_NAME s_scm_substring
1280 size_t len
, from
, to
;
1282 SCM_VALIDATE_STRING (1, str
);
1283 len
= scm_i_string_length (str
);
1284 from
= scm_to_unsigned_integer (start
, 0, len
);
1285 if (SCM_UNBNDP (end
))
1288 to
= scm_to_unsigned_integer (end
, from
, len
);
1289 return scm_i_substring (str
, from
, to
);
1293 SCM_DEFINE (scm_substring_read_only
, "substring/read-only", 2, 1, 0,
1294 (SCM str
, SCM start
, SCM end
),
1295 "Return a newly allocated string formed from the characters\n"
1296 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1297 "ending with index @var{end} (exclusive).\n"
1298 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1299 "exact integers satisfying:\n"
1301 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
1303 "The returned string is read-only.\n")
1304 #define FUNC_NAME s_scm_substring_read_only
1306 size_t len
, from
, to
;
1308 SCM_VALIDATE_STRING (1, str
);
1309 len
= scm_i_string_length (str
);
1310 from
= scm_to_unsigned_integer (start
, 0, len
);
1311 if (SCM_UNBNDP (end
))
1314 to
= scm_to_unsigned_integer (end
, from
, len
);
1315 return scm_i_substring_read_only (str
, from
, to
);
1319 SCM_DEFINE (scm_substring_copy
, "substring/copy", 2, 1, 0,
1320 (SCM str
, SCM start
, SCM end
),
1321 "Return a newly allocated string formed from the characters\n"
1322 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1323 "ending with index @var{end} (exclusive).\n"
1324 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1325 "exact integers satisfying:\n\n"
1326 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1327 #define FUNC_NAME s_scm_substring_copy
1329 /* For the Scheme version, START is mandatory, but for the C
1330 version, it is optional. See scm_string_copy in srfi-13.c for a
1336 SCM_VALIDATE_STRING (1, str
);
1337 scm_i_get_substring_spec (scm_i_string_length (str
),
1338 start
, &from
, end
, &to
);
1339 return scm_i_substring_copy (str
, from
, to
);
1343 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
1344 (SCM str
, SCM start
, SCM end
),
1345 "Return string that indirectly refers to the characters\n"
1346 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1347 "ending with index @var{end} (exclusive).\n"
1348 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1349 "exact integers satisfying:\n\n"
1350 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1351 #define FUNC_NAME s_scm_substring_shared
1353 size_t len
, from
, to
;
1355 SCM_VALIDATE_STRING (1, str
);
1356 len
= scm_i_string_length (str
);
1357 from
= scm_to_unsigned_integer (start
, 0, len
);
1358 if (SCM_UNBNDP (end
))
1361 to
= scm_to_unsigned_integer (end
, from
, len
);
1362 return scm_i_substring_shared (str
, from
, to
);
1366 SCM_DEFINE (scm_string_append
, "string-append", 0, 0, 1,
1368 "Return a newly allocated string whose characters form the\n"
1369 "concatenation of the given strings, @var{args}.")
1370 #define FUNC_NAME s_scm_string_append
1383 SCM_VALIDATE_REST_ARGUMENT (args
);
1384 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1387 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1388 len
+= scm_i_string_length (s
);
1389 if (!scm_i_is_narrow_string (s
))
1394 res
= scm_i_make_string (len
, &data
.narrow
, 0);
1396 res
= scm_i_make_wide_string (len
, &data
.wide
, 0);
1398 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1402 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1403 len
= scm_i_string_length (s
);
1406 memcpy (data
.narrow
, scm_i_string_chars (s
), len
);
1411 if (scm_i_is_narrow_string (s
))
1413 for (i
= 0; i
< scm_i_string_length (s
); i
++)
1414 data
.wide
[i
] = (unsigned char) scm_i_string_chars (s
)[i
];
1417 u32_cpy ((scm_t_uint32
*) data
.wide
,
1418 (scm_t_uint32
*) scm_i_string_wide_chars (s
), len
);
1421 scm_remember_upto_here_1 (s
);
1429 /* Charset conversion error handling. */
1431 SCM_SYMBOL (scm_encoding_error_key
, "encoding-error");
1432 SCM_SYMBOL (scm_decoding_error_key
, "decoding-error");
1434 /* Raise an exception informing that character CHR could not be written
1435 to PORT in its current encoding. */
1437 scm_encoding_error (const char *subr
, int err
, const char *message
,
1440 scm_throw (scm_encoding_error_key
,
1441 scm_list_n (scm_from_latin1_string (subr
),
1442 scm_from_latin1_string (message
),
1448 /* Raise an exception informing of an encoding error on PORT. This
1449 means that a character could not be written in PORT's encoding. */
1451 scm_decoding_error (const char *subr
, int err
, const char *message
, SCM port
)
1453 scm_throw (scm_decoding_error_key
,
1454 scm_list_n (scm_from_latin1_string (subr
),
1455 scm_from_latin1_string (message
),
1462 /* String conversion to/from C. */
1465 scm_from_stringn (const char *str
, size_t len
, const char *encoding
,
1466 scm_t_string_failed_conversion_handler handler
)
1473 /* The order of these checks is important. */
1474 if (!str
&& len
!= 0)
1475 scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL
);
1476 if (len
== (size_t) -1)
1479 if (encoding
== NULL
|| len
== 0)
1481 /* If encoding is null (or the string is empty), use Latin-1. */
1483 res
= scm_i_make_string (len
, &buf
, 0);
1484 memcpy (buf
, str
, len
);
1489 u32
= (scm_t_wchar
*) u32_conv_from_encoding (encoding
,
1490 (enum iconv_ilseq_handler
)
1496 if (SCM_UNLIKELY (u32
== NULL
))
1498 /* Raise an error and pass the raw C string as a bytevector to the `throw'
1503 buf
= scm_gc_malloc_pointerless (len
, "bytevector");
1504 memcpy (buf
, str
, len
);
1505 bv
= scm_c_take_gc_bytevector (buf
, len
);
1507 scm_decoding_error (__func__
, errno
,
1508 "input locale conversion error", bv
);
1513 if (u32
[i
++] > 0xFF)
1522 res
= scm_i_make_string (u32len
, &dst
, 0);
1523 for (i
= 0; i
< u32len
; i
++)
1524 dst
[i
] = (unsigned char) u32
[i
];
1530 res
= scm_i_make_wide_string (u32len
, &wdst
, 0);
1531 u32_cpy ((scm_t_uint32
*) wdst
, (scm_t_uint32
*) u32
, u32len
);
1540 scm_from_locale_string (const char *str
)
1542 return scm_from_locale_stringn (str
, -1);
1546 scm_from_locale_stringn (const char *str
, size_t len
)
1548 return scm_from_stringn (str
, len
, locale_charset (),
1549 scm_i_get_conversion_strategy (SCM_BOOL_F
));
1553 scm_from_latin1_string (const char *str
)
1555 return scm_from_latin1_stringn (str
, -1);
1559 scm_from_latin1_stringn (const char *str
, size_t len
)
1564 if (len
== (size_t) -1)
1567 /* Make a narrow string and copy STR as is. */
1568 result
= scm_i_make_string (len
, &buf
, 0);
1569 memcpy (buf
, str
, len
);
1575 scm_from_utf8_string (const char *str
)
1577 return scm_from_utf8_stringn (str
, -1);
1581 scm_from_utf8_stringn (const char *str
, size_t len
)
1583 return scm_from_stringn (str
, len
, "UTF-8", SCM_FAILED_CONVERSION_ERROR
);
1587 scm_from_utf32_string (const scm_t_wchar
*str
)
1589 return scm_from_utf32_stringn (str
, -1);
1593 scm_from_utf32_stringn (const scm_t_wchar
*str
, size_t len
)
1598 if (len
== (size_t) -1)
1599 len
= u32_strlen ((uint32_t *) str
);
1601 result
= scm_i_make_wide_string (len
, &buf
, 0);
1602 memcpy (buf
, str
, len
* sizeof (scm_t_wchar
));
1603 scm_i_try_narrow_string (result
);
1608 /* Create a new scheme string from the C string STR. The memory of
1609 STR may be used directly as storage for the new string. */
1610 /* FIXME: GC-wise, the only way to use the memory area pointed to by STR
1611 would be to register a finalizer to eventually free(3) STR, which isn't
1612 worth it. Should we just deprecate the `scm_take_' functions? */
1614 scm_take_locale_stringn (char *str
, size_t len
)
1618 res
= scm_from_locale_stringn (str
, len
);
1625 scm_take_locale_string (char *str
)
1627 return scm_take_locale_stringn (str
, -1);
1630 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1631 *LENP-byte locale-encoded string, to `\xXX', `\uXXXX', or `\UXXXXXX'.
1632 Set *LENP to the size of the resulting string.
1634 FIXME: This is a hack we should get rid of. See
1635 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00004.html>
1638 unistring_escapes_to_guile_escapes (char *buf
, size_t *lenp
)
1640 char *before
, *after
;
1649 if ((i
<= *lenp
- 6)
1650 && before
[i
] == '\\'
1651 && before
[i
+ 1] == 'u'
1652 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1654 /* Convert \u00NN to \xNN */
1657 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1658 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1662 else if ((i
<= *lenp
- 10)
1663 && before
[i
] == '\\'
1664 && before
[i
+ 1] == 'U'
1665 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1667 /* Convert \U00NNNNNN to \UNNNNNN */
1670 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1671 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1672 after
[j
+ 4] = tolower ((int) before
[i
+ 6]);
1673 after
[j
+ 5] = tolower ((int) before
[i
+ 7]);
1674 after
[j
+ 6] = tolower ((int) before
[i
+ 8]);
1675 after
[j
+ 7] = tolower ((int) before
[i
+ 9]);
1681 after
[j
] = before
[i
];
1689 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1690 *LENP-byte locale-encoded string, to `\xXXXX;'. Set *LEN to the size
1691 of the resulting string. BUF must be large enough to handle the
1692 worst case when `\uXXXX' escapes (6 characters) are replaced by
1693 `\xXXXX;' (7 characters). */
1695 unistring_escapes_to_r6rs_escapes (char *buf
, size_t *lenp
)
1697 char *before
, *after
;
1699 /* The worst case is if the input string contains all 4-digit hex escapes.
1700 "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */
1701 size_t max_out_len
= (*lenp
* 7) / 6 + 1;
1702 size_t nzeros
, ndigits
;
1705 after
= alloca (max_out_len
);
1710 if (((i
<= *lenp
- 6) && before
[i
] == '\\' && before
[i
+ 1] == 'u')
1711 || ((i
<= *lenp
- 10) && before
[i
] == '\\' && before
[i
+ 1] == 'U'))
1713 if (before
[i
+ 1] == 'u')
1715 else if (before
[i
+ 1] == 'U')
1720 /* Add the R6RS hex escape initial sequence. */
1724 /* Move string positions to the start of the hex numbers. */
1728 /* Find the number of initial zeros in this hex number. */
1730 while (before
[i
+ nzeros
] == '0' && nzeros
< ndigits
)
1733 /* Copy the number, skipping initial zeros, and then move the string
1735 if (nzeros
== ndigits
)
1744 for (pos
= 0; pos
< ndigits
- nzeros
; pos
++)
1745 after
[j
+ pos
] = tolower ((int) before
[i
+ nzeros
+ pos
]);
1747 j
+= (ndigits
- nzeros
);
1750 /* Add terminating semicolon. */
1756 after
[j
] = before
[i
];
1762 memcpy (before
, after
, j
);
1766 scm_to_locale_string (SCM str
)
1768 return scm_to_locale_stringn (str
, NULL
);
1772 scm_to_locale_stringn (SCM str
, size_t *lenp
)
1774 return scm_to_stringn (str
, lenp
,
1776 scm_i_get_conversion_strategy (SCM_BOOL_F
));
1780 scm_to_latin1_string (SCM str
)
1782 return scm_to_latin1_stringn (str
, NULL
);
1786 scm_to_latin1_stringn (SCM str
, size_t *lenp
)
1787 #define FUNC_NAME "scm_to_latin1_stringn"
1791 SCM_VALIDATE_STRING (1, str
);
1793 if (scm_i_is_narrow_string (str
))
1795 size_t len
= scm_i_string_length (str
);
1800 result
= scm_strndup (scm_i_string_data (str
), len
);
1803 result
= scm_to_stringn (str
, lenp
, NULL
,
1804 SCM_FAILED_CONVERSION_ERROR
);
1811 scm_to_utf8_string (SCM str
)
1813 return scm_to_utf8_stringn (str
, NULL
);
1817 scm_to_utf8_stringn (SCM str
, size_t *lenp
)
1819 return scm_to_stringn (str
, lenp
, "UTF-8", SCM_FAILED_CONVERSION_ERROR
);
1823 scm_to_utf32_string (SCM str
)
1825 return scm_to_utf32_stringn (str
, NULL
);
1829 scm_to_utf32_stringn (SCM str
, size_t *lenp
)
1830 #define FUNC_NAME "scm_to_utf32_stringn"
1832 scm_t_wchar
*result
;
1834 SCM_VALIDATE_STRING (1, str
);
1836 if (scm_i_is_narrow_string (str
))
1837 result
= (scm_t_wchar
*)
1838 scm_to_stringn (str
, lenp
, "UTF-32",
1839 SCM_FAILED_CONVERSION_ERROR
);
1844 len
= scm_i_string_length (str
);
1848 result
= scm_malloc ((len
+ 1) * sizeof (scm_t_wchar
));
1849 memcpy (result
, scm_i_string_wide_chars (str
),
1850 len
* sizeof (scm_t_wchar
));
1858 /* Return a malloc(3)-allocated buffer containing the contents of STR encoded
1859 according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
1860 the returned buffer. If the conversion to ENCODING fails, apply the strategy
1861 defined by HANDLER. */
1863 scm_to_stringn (SCM str
, size_t *lenp
, const char *encoding
,
1864 scm_t_string_failed_conversion_handler handler
)
1867 size_t ilen
, len
, i
;
1871 if (!scm_is_string (str
))
1872 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
1873 ilen
= scm_i_string_length (str
);
1877 buf
= scm_malloc (1);
1885 for (i
= 0; i
< ilen
; i
++)
1886 if (scm_i_string_ref (str
, i
) == '\0')
1887 scm_misc_error (NULL
,
1888 "string contains #\\nul character: ~S",
1891 if (scm_i_is_narrow_string (str
) && (encoding
== NULL
))
1893 /* If using native Latin-1 encoding, just copy the string
1897 buf
= scm_malloc (ilen
);
1898 memcpy (buf
, scm_i_string_chars (str
), ilen
);
1904 buf
= scm_malloc (ilen
+ 1);
1905 memcpy (buf
, scm_i_string_chars (str
), ilen
);
1917 if (scm_i_is_narrow_string (str
))
1919 ret
= mem_iconveh (scm_i_string_chars (str
), ilen
,
1921 (enum iconv_ilseq_handler
) handler
, NULL
,
1925 scm_encoding_error (__func__
, errno
,
1926 "cannot convert narrow string to output locale",
1928 /* FIXME: Faulty character unknown. */
1933 buf
= u32_conv_to_encoding (enc
,
1934 (enum iconv_ilseq_handler
) handler
,
1935 (scm_t_uint32
*) scm_i_string_wide_chars (str
),
1940 scm_encoding_error (__func__
, errno
,
1941 "cannot convert wide string to output locale",
1943 /* FIXME: Faulty character unknown. */
1946 if (handler
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
1948 if (SCM_R6RS_ESCAPES_P
)
1950 /* The worst case is if the input string contains all 4-digit
1951 hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;"
1952 (seven characters). Make BUF large enough to hold
1954 buf
= scm_realloc (buf
, (len
* 7) / 6 + 1);
1955 unistring_escapes_to_r6rs_escapes (buf
, &len
);
1958 unistring_escapes_to_guile_escapes (buf
, &len
);
1960 buf
= scm_realloc (buf
, len
);
1966 buf
= scm_realloc (buf
, len
+ 1);
1970 scm_remember_upto_here_1 (str
);
1975 scm_to_locale_stringbuf (SCM str
, char *buf
, size_t max_len
)
1978 char *result
= NULL
;
1979 if (!scm_is_string (str
))
1980 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
1981 result
= scm_to_locale_stringn (str
, &len
);
1983 memcpy (buf
, result
, (len
> max_len
) ? max_len
: len
);
1986 scm_remember_upto_here_1 (str
);
1991 /* Unicode string normalization. */
1993 /* This function is a partial clone of SCM_STRING_TO_U32_BUF from
1994 libguile/i18n.c. It would be useful to have this factored out into a more
1995 convenient location, but its use of alloca makes that tricky to do. */
1998 normalize_str (SCM string
, uninorm_t form
)
2001 scm_t_uint32
*w_str
;
2003 size_t rlen
, len
= scm_i_string_length (string
);
2005 if (scm_i_is_narrow_string (string
))
2008 const char *buf
= scm_i_string_chars (string
);
2010 w_str
= alloca (sizeof (scm_t_wchar
) * (len
+ 1));
2012 for (i
= 0; i
< len
; i
++)
2013 w_str
[i
] = (unsigned char) buf
[i
];
2017 w_str
= (scm_t_uint32
*) scm_i_string_wide_chars (string
);
2019 w_str
= u32_normalize (form
, w_str
, len
, NULL
, &rlen
);
2021 ret
= scm_i_make_wide_string (rlen
, &cbuf
, 0);
2022 u32_cpy ((scm_t_uint32
*) cbuf
, w_str
, rlen
);
2025 scm_i_try_narrow_string (ret
);
2030 SCM_DEFINE (scm_string_normalize_nfc
, "string-normalize-nfc", 1, 0, 0,
2032 "Returns the NFC normalized form of @var{string}.")
2033 #define FUNC_NAME s_scm_string_normalize_nfc
2035 SCM_VALIDATE_STRING (1, string
);
2036 return normalize_str (string
, UNINORM_NFC
);
2040 SCM_DEFINE (scm_string_normalize_nfd
, "string-normalize-nfd", 1, 0, 0,
2042 "Returns the NFD normalized form of @var{string}.")
2043 #define FUNC_NAME s_scm_string_normalize_nfd
2045 SCM_VALIDATE_STRING (1, string
);
2046 return normalize_str (string
, UNINORM_NFD
);
2050 SCM_DEFINE (scm_string_normalize_nfkc
, "string-normalize-nfkc", 1, 0, 0,
2052 "Returns the NFKC normalized form of @var{string}.")
2053 #define FUNC_NAME s_scm_string_normalize_nfkc
2055 SCM_VALIDATE_STRING (1, string
);
2056 return normalize_str (string
, UNINORM_NFKC
);
2060 SCM_DEFINE (scm_string_normalize_nfkd
, "string-normalize-nfkd", 1, 0, 0,
2062 "Returns the NFKD normalized form of @var{string}.")
2063 #define FUNC_NAME s_scm_string_normalize_nfkd
2065 SCM_VALIDATE_STRING (1, string
);
2066 return normalize_str (string
, UNINORM_NFKD
);
2070 /* converts C scm_array of strings to SCM scm_list of strings.
2071 If argc < 0, a null terminated scm_array is assumed.
2072 The current locale encoding is assumed */
2074 scm_makfromstrs (int argc
, char **argv
)
2079 for (i
= 0; argv
[i
]; i
++);
2081 lst
= scm_cons (scm_from_locale_string (argv
[i
]), lst
);
2085 /* Return a newly allocated array of char pointers to each of the strings
2086 in args, with a terminating NULL pointer. The strings are encoded using
2087 the current locale. */
2090 scm_i_allocate_string_pointers (SCM list
)
2091 #define FUNC_NAME "scm_i_allocate_string_pointers"
2094 int list_len
= scm_ilength (list
);
2098 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
2100 result
= scm_gc_malloc ((list_len
+ 1) * sizeof (char *),
2102 result
[list_len
] = NULL
;
2104 /* The list might have been modified in another thread, so
2105 we check LIST before each access.
2107 for (i
= 0; i
< list_len
&& scm_is_pair (list
); i
++)
2109 SCM str
= SCM_CAR (list
);
2110 size_t len
; /* String length in bytes */
2111 char *c_str
= scm_to_locale_stringn (str
, &len
);
2113 /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses
2114 scm_malloc to allocate the returned string, which must be
2115 explicitly deallocated. This forces us to copy the string a
2116 second time into a new buffer. Ideally there would be variants
2117 of scm_to_*_stringn that can return garbage-collected buffers. */
2119 result
[i
] = scm_gc_malloc_pointerless (len
+ 1, "string");
2120 memcpy (result
[i
], c_str
, len
);
2121 result
[i
][len
] = '\0';
2124 list
= SCM_CDR (list
);
2132 scm_i_get_substring_spec (size_t len
,
2133 SCM start
, size_t *cstart
,
2134 SCM end
, size_t *cend
)
2136 if (SCM_UNBNDP (start
))
2139 *cstart
= scm_to_unsigned_integer (start
, 0, len
);
2141 if (SCM_UNBNDP (end
))
2144 *cend
= scm_to_unsigned_integer (end
, *cstart
, len
);
2147 #if SCM_ENABLE_DEPRECATED
2149 /* When these definitions are removed, it becomes reasonable to use
2150 read-only strings for string literals. For that, change the reader
2151 to create string literals with scm_c_substring_read_only instead of
2152 with scm_c_substring_copy.
2156 scm_i_deprecated_stringp (SCM str
)
2158 scm_c_issue_deprecation_warning
2159 ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
2161 return scm_is_string (str
);
2165 scm_i_deprecated_string_chars (SCM str
)
2169 scm_c_issue_deprecation_warning
2170 ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
2172 /* We don't accept shared substrings here since they are not
2175 if (IS_SH_STRING (str
))
2176 scm_misc_error (NULL
,
2177 "SCM_STRING_CHARS does not work with shared substrings",
2180 /* We explicitly test for read-only strings to produce a better
2184 if (IS_RO_STRING (str
))
2185 scm_misc_error (NULL
,
2186 "SCM_STRING_CHARS does not work with read-only strings",
2189 /* The following is still wrong, of course...
2191 str
= scm_i_string_start_writing (str
);
2192 chars
= scm_i_string_writable_chars (str
);
2193 scm_i_string_stop_writing ();
2198 scm_i_deprecated_string_length (SCM str
)
2200 scm_c_issue_deprecation_warning
2201 ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
2202 return scm_c_string_length (str
);
2208 string_handle_ref (scm_t_array_handle
*h
, size_t index
)
2210 return scm_c_string_ref (h
->array
, index
);
2214 string_handle_set (scm_t_array_handle
*h
, size_t index
, SCM val
)
2216 scm_c_string_set_x (h
->array
, index
, val
);
2220 string_get_handle (SCM v
, scm_t_array_handle
*h
)
2226 h
->dim0
.ubnd
= scm_c_string_length (v
) - 1;
2228 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_CHAR
;
2229 h
->elements
= h
->writable_elements
= NULL
;
2232 SCM_ARRAY_IMPLEMENTATION (scm_tc7_string
, 0x7f,
2233 string_handle_ref
, string_handle_set
,
2235 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR
, scm_make_string
)
2240 scm_nullstr
= scm_i_make_string (0, NULL
, 0);
2242 #include "libguile/strings.x"