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
= SCM_PACK_POINTER (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
= SCM_PACK_POINTER (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_HAS_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 static SCM null_stringbuf
= SCM_BOOL_F
;
276 if (SCM_UNLIKELY (scm_is_false (null_stringbuf
)))
278 null_stringbuf
= make_stringbuf (0);
279 SET_STRINGBUF_SHARED (null_stringbuf
);
281 buf
= null_stringbuf
;
284 buf
= make_stringbuf (len
);
287 *charsp
= (char *) STRINGBUF_CHARS (buf
);
288 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
290 (scm_t_bits
) 0, (scm_t_bits
) len
);
294 /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
295 characters. CHARSP, if not NULL, will be set to location of the
296 character array. If READ_ONLY_P, the returned string is read-only;
297 otherwise it is writable. */
299 scm_i_make_wide_string (size_t len
, scm_t_wchar
**charsp
, int read_only_p
)
301 SCM buf
= make_wide_stringbuf (len
);
304 *charsp
= STRINGBUF_WIDE_CHARS (buf
);
305 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
307 (scm_t_bits
) 0, (scm_t_bits
) len
);
312 validate_substring_args (SCM str
, size_t start
, size_t end
)
314 if (!IS_STRING (str
))
315 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
316 if (start
> STRING_LENGTH (str
))
317 scm_out_of_range (NULL
, scm_from_size_t (start
));
318 if (end
> STRING_LENGTH (str
) || end
< start
)
319 scm_out_of_range (NULL
, scm_from_size_t (end
));
323 get_str_buf_start (SCM
*str
, SCM
*buf
, size_t *start
)
325 *start
= STRING_START (*str
);
326 if (IS_SH_STRING (*str
))
328 *str
= SH_STRING_STRING (*str
);
329 *start
+= STRING_START (*str
);
331 *buf
= STRING_STRINGBUF (*str
);
335 scm_i_substring (SCM str
, size_t start
, size_t end
)
338 return scm_i_make_string (0, NULL
, 0);
343 get_str_buf_start (&str
, &buf
, &str_start
);
344 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
345 SET_STRINGBUF_SHARED (buf
);
346 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
347 return scm_double_cell (STRING_TAG
, SCM_UNPACK(buf
),
348 (scm_t_bits
)str_start
+ start
,
349 (scm_t_bits
) end
- start
);
354 scm_i_substring_read_only (SCM str
, size_t start
, size_t end
)
357 return scm_i_make_string (0, NULL
, 1);
362 get_str_buf_start (&str
, &buf
, &str_start
);
363 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
364 SET_STRINGBUF_SHARED (buf
);
365 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
366 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK(buf
),
367 (scm_t_bits
)str_start
+ start
,
368 (scm_t_bits
) end
- start
);
373 scm_i_substring_copy (SCM str
, size_t start
, size_t end
)
375 size_t len
= end
- start
;
376 SCM buf
, my_buf
, substr
;
379 get_str_buf_start (&str
, &buf
, &str_start
);
380 if (scm_i_is_narrow_string (str
))
382 my_buf
= make_stringbuf (len
);
383 memcpy (STRINGBUF_CHARS (my_buf
),
384 STRINGBUF_CHARS (buf
) + str_start
+ start
, len
);
388 my_buf
= make_wide_stringbuf (len
);
389 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (my_buf
),
390 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
) + str_start
394 scm_remember_upto_here_1 (buf
);
395 substr
= scm_double_cell (STRING_TAG
, SCM_UNPACK (my_buf
),
396 (scm_t_bits
) 0, (scm_t_bits
) len
);
398 scm_i_try_narrow_string (substr
);
403 scm_i_substring_shared (SCM str
, size_t start
, size_t end
)
405 if (start
== 0 && end
== STRING_LENGTH (str
))
407 else if (start
== end
)
408 return scm_i_make_string (0, NULL
, 0);
411 size_t len
= end
- start
;
412 if (IS_SH_STRING (str
))
414 start
+= STRING_START (str
);
415 str
= SH_STRING_STRING (str
);
417 return scm_double_cell (SH_STRING_TAG
, SCM_UNPACK(str
),
418 (scm_t_bits
)start
, (scm_t_bits
) len
);
423 scm_c_substring (SCM str
, size_t start
, size_t end
)
425 validate_substring_args (str
, start
, end
);
426 return scm_i_substring (str
, start
, end
);
430 scm_c_substring_read_only (SCM str
, size_t start
, size_t end
)
432 validate_substring_args (str
, start
, end
);
433 return scm_i_substring_read_only (str
, start
, end
);
437 scm_c_substring_copy (SCM str
, size_t start
, size_t end
)
439 validate_substring_args (str
, start
, end
);
440 return scm_i_substring_copy (str
, start
, end
);
444 scm_c_substring_shared (SCM str
, size_t start
, size_t end
)
446 validate_substring_args (str
, start
, end
);
447 return scm_i_substring_shared (str
, start
, end
);
451 /* Internal accessors
454 /* Returns the number of characters in STR. This may be different
455 than the memory size of the string storage. */
457 scm_i_string_length (SCM str
)
459 return STRING_LENGTH (str
);
462 /* True if the string is 'narrow', meaning it has a 8-bit Latin-1
463 encoding. False if it is 'wide', having a 32-bit UCS-4
466 scm_i_is_narrow_string (SCM str
)
468 if (IS_SH_STRING (str
))
469 str
= SH_STRING_STRING (str
);
471 return !STRINGBUF_WIDE (STRING_STRINGBUF (str
));
474 /* Try to coerce a string to be narrow. It if is narrow already, do
475 nothing. If it is wide, shrink it to narrow if none of its
476 characters are above 0xFF. Return true if the string is narrow or
477 was made to be narrow. */
479 scm_i_try_narrow_string (SCM str
)
481 if (IS_SH_STRING (str
))
482 str
= SH_STRING_STRING (str
);
484 SET_STRING_STRINGBUF (str
, narrow_stringbuf (STRING_STRINGBUF (str
)));
486 return scm_i_is_narrow_string (str
);
489 /* Return a pointer to the raw data of the string, which can be either Latin-1
490 or UCS-4 encoded data, depending on `scm_i_is_narrow_string (STR)'. */
492 scm_i_string_data (SCM str
)
498 get_str_buf_start (&str
, &buf
, &start
);
500 data
= STRINGBUF_CONTENTS (buf
);
501 data
+= start
* (scm_i_is_narrow_string (str
) ? 1 : 4);
506 /* Returns a pointer to the 8-bit Latin-1 encoded character array of
509 scm_i_string_chars (SCM str
)
513 get_str_buf_start (&str
, &buf
, &start
);
514 if (scm_i_is_narrow_string (str
))
515 return (const char *) STRINGBUF_CHARS (buf
) + start
;
517 scm_misc_error (NULL
, "Invalid read access of chars of wide string: ~s",
522 /* Returns a pointer to the 32-bit UCS-4 encoded character array of
525 scm_i_string_wide_chars (SCM str
)
530 get_str_buf_start (&str
, &buf
, &start
);
531 if (!scm_i_is_narrow_string (str
))
532 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
) + start
;
534 scm_misc_error (NULL
, "Invalid read access of chars of narrow string: ~s",
538 /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
539 a new string buffer, so that it can be modified without modifying
540 other strings. Also, lock the string mutex. Later, one must call
541 scm_i_string_stop_writing to unlock the mutex. */
543 scm_i_string_start_writing (SCM orig_str
)
545 SCM buf
, str
= orig_str
;
548 get_str_buf_start (&str
, &buf
, &start
);
549 if (IS_RO_STRING (str
))
550 scm_misc_error (NULL
, "string is read-only: ~s", scm_list_1 (orig_str
));
552 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
553 if (STRINGBUF_SHARED (buf
))
555 /* Clone the stringbuf. */
556 size_t len
= STRING_LENGTH (str
);
559 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
561 if (scm_i_is_narrow_string (str
))
563 new_buf
= make_stringbuf (len
);
564 memcpy (STRINGBUF_CHARS (new_buf
),
565 STRINGBUF_CHARS (buf
) + STRING_START (str
), len
);
570 new_buf
= make_wide_stringbuf (len
);
571 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
572 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
)
573 + STRING_START (str
)), len
);
576 SET_STRING_STRINGBUF (str
, new_buf
);
577 start
-= STRING_START (str
);
579 /* FIXME: The following operations are not atomic, so other threads
580 looking at STR may see an inconsistent state. Nevertheless it can't
581 hurt much since (i) accessing STR while it is being mutated can't
582 yield a crash, and (ii) concurrent accesses to STR should be
583 protected by a mutex at the application level. The latter may not
584 apply when STR != ORIG_STR, though. */
585 SET_STRING_START (str
, 0);
586 SET_STRING_STRINGBUF (str
, new_buf
);
590 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
595 /* Return a pointer to the 8-bit Latin-1 chars of a string. */
597 scm_i_string_writable_chars (SCM str
)
602 get_str_buf_start (&str
, &buf
, &start
);
603 if (scm_i_is_narrow_string (str
))
604 return (char *) STRINGBUF_CHARS (buf
) + start
;
606 scm_misc_error (NULL
, "Invalid write access of chars of wide string: ~s",
611 /* Return a pointer to the UCS-4 codepoints of a string. */
613 scm_i_string_writable_wide_chars (SCM str
)
618 get_str_buf_start (&str
, &buf
, &start
);
619 if (!scm_i_is_narrow_string (str
))
620 return STRINGBUF_WIDE_CHARS (buf
) + start
;
622 scm_misc_error (NULL
, "Invalid write access of chars of narrow string: ~s",
626 /* Unlock the string mutex that was locked when
627 scm_i_string_start_writing was called. */
629 scm_i_string_stop_writing (void)
631 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
634 /* Return the Xth character of STR as a UCS-4 codepoint. */
636 scm_i_string_ref (SCM str
, size_t x
)
638 if (scm_i_is_narrow_string (str
))
639 return (scm_t_wchar
) (unsigned char) (scm_i_string_chars (str
)[x
]);
641 return scm_i_string_wide_chars (str
)[x
];
644 /* Returns index+1 of the first char in STR that matches C, or
645 0 if the char is not found. */
647 scm_i_string_contains_char (SCM str
, char ch
)
650 size_t len
= scm_i_string_length (str
);
653 if (scm_i_is_narrow_string (str
))
657 if (scm_i_string_chars (str
)[i
] == ch
)
666 if (scm_i_string_wide_chars (str
)[i
]
667 == (unsigned char) ch
)
676 scm_i_string_strcmp (SCM sstr
, size_t start_x
, const char *cstr
)
678 if (scm_i_is_narrow_string (sstr
))
680 const char *a
= scm_i_string_chars (sstr
) + start_x
;
681 const char *b
= cstr
;
682 return strncmp (a
, b
, strlen(b
));
687 const scm_t_wchar
*a
= scm_i_string_wide_chars (sstr
) + start_x
;
688 const char *b
= cstr
;
689 for (i
= 0; i
< strlen (b
); i
++)
691 if (a
[i
] != (unsigned char) b
[i
])
698 /* Set the Pth character of STR to UCS-4 codepoint CHR. */
700 scm_i_string_set_x (SCM str
, size_t p
, scm_t_wchar chr
)
702 if (IS_SH_STRING (str
))
704 p
+= STRING_START (str
);
705 str
= SH_STRING_STRING (str
);
708 if (chr
> 0xFF && scm_i_is_narrow_string (str
))
709 SET_STRING_STRINGBUF (str
, wide_stringbuf (STRING_STRINGBUF (str
)));
711 if (scm_i_is_narrow_string (str
))
713 char *dst
= scm_i_string_writable_chars (str
);
718 scm_t_wchar
*dst
= scm_i_string_writable_wide_chars (str
);
726 Basic symbol creation and accessing is done here, the rest is in
727 symbols.[hc]. This has been done to keep stringbufs and the
728 internals of strings and string-like objects confined to this file.
731 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
734 scm_i_make_symbol (SCM name
, scm_t_bits flags
,
735 unsigned long hash
, SCM props
)
738 size_t start
= STRING_START (name
);
739 size_t length
= STRING_LENGTH (name
);
741 if (IS_SH_STRING (name
))
743 name
= SH_STRING_STRING (name
);
744 start
+= STRING_START (name
);
746 buf
= SYMBOL_STRINGBUF (name
);
748 if (start
== 0 && length
== STRINGBUF_LENGTH (buf
))
751 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
752 SET_STRINGBUF_SHARED (buf
);
753 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
758 if (scm_i_is_narrow_string (name
))
760 SCM new_buf
= make_stringbuf (length
);
761 memcpy (STRINGBUF_CHARS (new_buf
),
762 STRINGBUF_CHARS (buf
) + start
, length
);
767 SCM new_buf
= make_wide_stringbuf (length
);
768 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
769 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
) + start
,
774 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
775 (scm_t_bits
) hash
, SCM_UNPACK (props
));
779 scm_i_c_make_symbol (const char *name
, size_t len
,
780 scm_t_bits flags
, unsigned long hash
, SCM props
)
782 SCM buf
= make_stringbuf (len
);
783 memcpy (STRINGBUF_CHARS (buf
), name
, len
);
785 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
786 (scm_t_bits
) hash
, SCM_UNPACK (props
));
789 /* Returns the number of characters in SYM. This may be different
790 from the memory size of SYM. */
792 scm_i_symbol_length (SCM sym
)
794 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
798 scm_c_symbol_length (SCM sym
)
799 #define FUNC_NAME "scm_c_symbol_length"
801 SCM_VALIDATE_SYMBOL (1, sym
);
803 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
807 /* True if the name of SYM is stored as a Latin-1 encoded string.
808 False if it is stored as a 32-bit UCS-4-encoded string. */
810 scm_i_is_narrow_symbol (SCM sym
)
814 buf
= SYMBOL_STRINGBUF (sym
);
815 return !STRINGBUF_WIDE (buf
);
818 /* Returns a pointer to the 8-bit Latin-1 encoded character array that
819 contains the name of SYM. */
821 scm_i_symbol_chars (SCM sym
)
825 buf
= SYMBOL_STRINGBUF (sym
);
826 if (!STRINGBUF_WIDE (buf
))
827 return (const char *) STRINGBUF_CHARS (buf
);
829 scm_misc_error (NULL
, "Invalid access of chars of a wide symbol ~S",
833 /* Return a pointer to the 32-bit UCS-4-encoded character array of a
836 scm_i_symbol_wide_chars (SCM sym
)
840 buf
= SYMBOL_STRINGBUF (sym
);
841 if (STRINGBUF_WIDE (buf
))
842 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
);
844 scm_misc_error (NULL
, "Invalid access of chars of a narrow symbol ~S",
849 scm_i_symbol_substring (SCM sym
, size_t start
, size_t end
)
851 SCM buf
= SYMBOL_STRINGBUF (sym
);
852 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
853 SET_STRINGBUF_SHARED (buf
);
854 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
855 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK (buf
),
856 (scm_t_bits
)start
, (scm_t_bits
) end
- start
);
859 /* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
861 scm_i_symbol_ref (SCM sym
, size_t x
)
863 if (scm_i_is_narrow_symbol (sym
))
864 return (scm_t_wchar
) (unsigned char) (scm_i_symbol_chars (sym
)[x
]);
866 return scm_i_symbol_wide_chars (sym
)[x
];
872 SCM_DEFINE (scm_sys_string_dump
, "%string-dump", 1, 0, 0, (SCM str
),
873 "Returns an association list containing debugging information\n"
874 "for @var{str}. The association list has the following entries."
877 "The string itself.\n"
879 "The start index of the string into its stringbuf\n"
881 "The length of the string\n"
883 "If this string is a substring, it returns its parent string.\n"
884 "Otherwise, it returns @code{#f}\n"
886 "@code{#t} if the string is read-only\n"
887 "@item stringbuf-chars\n"
888 "A new string containing this string's stringbuf's characters\n"
889 "@item stringbuf-length\n"
890 "The number of characters in this stringbuf\n"
891 "@item stringbuf-shared\n"
892 "@code{#t} if this stringbuf is shared\n"
893 "@item stringbuf-wide\n"
894 "@code{#t} if this stringbuf's characters are stored in a\n"
895 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
898 #define FUNC_NAME s_scm_sys_string_dump
900 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
;
902 SCM_VALIDATE_STRING (1, str
);
905 e1
= scm_cons (scm_from_latin1_symbol ("string"),
907 e2
= scm_cons (scm_from_latin1_symbol ("start"),
908 scm_from_size_t (STRING_START (str
)));
909 e3
= scm_cons (scm_from_latin1_symbol ("length"),
910 scm_from_size_t (STRING_LENGTH (str
)));
912 if (IS_SH_STRING (str
))
914 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
915 SH_STRING_STRING (str
));
916 buf
= STRING_STRINGBUF (SH_STRING_STRING (str
));
920 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
922 buf
= STRING_STRINGBUF (str
);
925 if (IS_RO_STRING (str
))
926 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
929 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
933 if (!STRINGBUF_WIDE (buf
))
935 size_t len
= STRINGBUF_LENGTH (buf
);
937 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
938 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
939 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
944 size_t len
= STRINGBUF_LENGTH (buf
);
946 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
947 u32_cpy ((scm_t_uint32
*) cbuf
,
948 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
949 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
952 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
953 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
954 if (STRINGBUF_SHARED (buf
))
955 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
958 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
960 if (STRINGBUF_WIDE (buf
))
961 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
964 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
967 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
, SCM_UNDEFINED
);
971 SCM_DEFINE (scm_sys_symbol_dump
, "%symbol-dump", 1, 0, 0, (SCM sym
),
972 "Returns an association list containing debugging information\n"
973 "for @var{sym}. The association list has the following entries."
976 "The symbol itself\n"
980 "@code{#t} if it is an interned symbol\n"
981 "@item stringbuf-chars\n"
982 "A new string containing this symbols's stringbuf's characters\n"
983 "@item stringbuf-length\n"
984 "The number of characters in this stringbuf\n"
985 "@item stringbuf-shared\n"
986 "@code{#t} if this stringbuf is shared\n"
987 "@item stringbuf-wide\n"
988 "@code{#t} if this stringbuf's characters are stored in a\n"
989 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
992 #define FUNC_NAME s_scm_sys_symbol_dump
994 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
;
996 SCM_VALIDATE_SYMBOL (1, sym
);
997 e1
= scm_cons (scm_from_latin1_symbol ("symbol"),
999 e2
= scm_cons (scm_from_latin1_symbol ("hash"),
1000 scm_from_ulong (scm_i_symbol_hash (sym
)));
1001 e3
= scm_cons (scm_from_latin1_symbol ("interned"),
1002 scm_symbol_interned_p (sym
));
1003 buf
= SYMBOL_STRINGBUF (sym
);
1005 /* Stringbuf info */
1006 if (!STRINGBUF_WIDE (buf
))
1008 size_t len
= STRINGBUF_LENGTH (buf
);
1010 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
1011 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
1012 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
1017 size_t len
= STRINGBUF_LENGTH (buf
);
1019 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
1020 u32_cpy ((scm_t_uint32
*) cbuf
,
1021 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
1022 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
1025 e5
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
1026 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
1027 if (STRINGBUF_SHARED (buf
))
1028 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1031 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1033 if (STRINGBUF_WIDE (buf
))
1034 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1037 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1039 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, SCM_UNDEFINED
);
1044 #ifdef SCM_STRING_LENGTH_HISTOGRAM
1046 SCM_DEFINE (scm_sys_stringbuf_hist
, "%stringbuf-hist", 0, 0, 0, (void), "")
1047 #define FUNC_NAME s_scm_sys_stringbuf_hist
1050 for (i
= 0; i
< 1000; i
++)
1052 fprintf (stderr
, " %3d: %u\n", i
, lenhist
[i
]);
1053 fprintf (stderr
, ">999: %u\n", lenhist
[1000]);
1054 return SCM_UNSPECIFIED
;
1062 SCM_DEFINE (scm_string_p
, "string?", 1, 0, 0,
1064 "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
1065 #define FUNC_NAME s_scm_string_p
1067 return scm_from_bool (IS_STRING (obj
));
1072 SCM_REGISTER_PROC (s_scm_list_to_string
, "list->string", 1, 0, 0, scm_string
);
1074 SCM_DEFINE (scm_string
, "string", 0, 0, 1,
1076 "@deffnx {Scheme Procedure} list->string chrs\n"
1077 "Return a newly allocated string composed of the arguments,\n"
1079 #define FUNC_NAME s_scm_string
1081 SCM result
= SCM_BOOL_F
;
1088 /* Verify that this is a list of chars. */
1089 i
= scm_ilength (chrs
);
1090 SCM_ASSERT (i
>= 0, chrs
, SCM_ARG1
, FUNC_NAME
);
1095 while (len
> 0 && scm_is_pair (rest
))
1097 SCM elt
= SCM_CAR (rest
);
1098 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
1099 if (SCM_CHAR (elt
) > 0xFF)
1101 rest
= SCM_CDR (rest
);
1103 scm_remember_upto_here_1 (elt
);
1106 /* Construct a string containing this list of chars. */
1114 result
= scm_i_make_string (len
, NULL
, 0);
1115 result
= scm_i_string_start_writing (result
);
1116 buf
= scm_i_string_writable_chars (result
);
1117 while (len
> 0 && scm_is_pair (rest
))
1119 SCM elt
= SCM_CAR (rest
);
1120 buf
[p
] = (unsigned char) SCM_CHAR (elt
);
1122 rest
= SCM_CDR (rest
);
1124 scm_remember_upto_here_1 (elt
);
1131 result
= scm_i_make_wide_string (len
, NULL
, 0);
1132 result
= scm_i_string_start_writing (result
);
1133 buf
= scm_i_string_writable_wide_chars (result
);
1134 while (len
> 0 && scm_is_pair (rest
))
1136 SCM elt
= SCM_CAR (rest
);
1137 buf
[p
] = SCM_CHAR (elt
);
1139 rest
= SCM_CDR (rest
);
1141 scm_remember_upto_here_1 (elt
);
1144 scm_i_string_stop_writing ();
1147 scm_misc_error (NULL
, "list changed while constructing string", SCM_EOL
);
1148 if (!scm_is_null (rest
))
1149 scm_wrong_type_arg_msg (NULL
, 0, chrs
, "proper list");
1155 SCM_DEFINE (scm_make_string
, "make-string", 1, 1, 0,
1157 "Return a newly allocated string of\n"
1158 "length @var{k}. If @var{chr} is given, then all elements of\n"
1159 "the string are initialized to @var{chr}, otherwise the contents\n"
1160 "of the @var{string} are all set to @var{#\nul}.")
1161 #define FUNC_NAME s_scm_make_string
1163 return scm_c_make_string (scm_to_size_t (k
), chr
);
1168 scm_c_make_string (size_t len
, SCM chr
)
1169 #define FUNC_NAME NULL
1172 char *contents
= NULL
;
1173 SCM res
= scm_i_make_string (len
, &contents
, 0);
1175 /* If no char is given, initialize string contents to NULL. */
1176 if (SCM_UNBNDP (chr
))
1177 memset (contents
, 0, len
);
1180 SCM_VALIDATE_CHAR (0, chr
);
1181 res
= scm_i_string_start_writing (res
);
1182 for (p
= 0; p
< len
; p
++)
1183 scm_i_string_set_x (res
, p
, SCM_CHAR (chr
));
1184 scm_i_string_stop_writing ();
1191 SCM_DEFINE (scm_string_length
, "string-length", 1, 0, 0,
1193 "Return the number of characters in @var{string}.")
1194 #define FUNC_NAME s_scm_string_length
1196 SCM_VALIDATE_STRING (1, string
);
1197 return scm_from_size_t (STRING_LENGTH (string
));
1201 SCM_DEFINE (scm_string_bytes_per_char
, "string-bytes-per-char", 1, 0, 0,
1203 "Return the bytes used to represent a character in @var{string}."
1204 "This will return 1 or 4.")
1205 #define FUNC_NAME s_scm_string_bytes_per_char
1207 SCM_VALIDATE_STRING (1, string
);
1208 if (!scm_i_is_narrow_string (string
))
1209 return scm_from_int (4);
1211 return scm_from_int (1);
1216 scm_c_string_length (SCM string
)
1218 if (!IS_STRING (string
))
1219 scm_wrong_type_arg_msg (NULL
, 0, string
, "string");
1220 return STRING_LENGTH (string
);
1223 SCM_DEFINE (scm_string_ref
, "string-ref", 2, 0, 0,
1225 "Return character @var{k} of @var{str} using zero-origin\n"
1226 "indexing. @var{k} must be a valid index of @var{str}.")
1227 #define FUNC_NAME s_scm_string_ref
1232 SCM_VALIDATE_STRING (1, str
);
1234 len
= scm_i_string_length (str
);
1235 if (SCM_LIKELY (len
> 0))
1236 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1238 scm_out_of_range (NULL
, k
);
1240 if (scm_i_is_narrow_string (str
))
1241 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[idx
]);
1243 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[idx
]);
1248 scm_c_string_ref (SCM str
, size_t p
)
1250 if (p
>= scm_i_string_length (str
))
1251 scm_out_of_range (NULL
, scm_from_size_t (p
));
1252 if (scm_i_is_narrow_string (str
))
1253 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[p
]);
1255 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[p
]);
1259 SCM_DEFINE (scm_string_set_x
, "string-set!", 3, 0, 0,
1260 (SCM str
, SCM k
, SCM chr
),
1261 "Store @var{chr} in element @var{k} of @var{str} and return\n"
1262 "an unspecified value. @var{k} must be a valid index of\n"
1264 #define FUNC_NAME s_scm_string_set_x
1269 SCM_VALIDATE_STRING (1, str
);
1271 len
= scm_i_string_length (str
);
1272 if (SCM_LIKELY (len
> 0))
1273 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1275 scm_out_of_range (NULL
, k
);
1277 SCM_VALIDATE_CHAR (3, chr
);
1278 str
= scm_i_string_start_writing (str
);
1279 scm_i_string_set_x (str
, idx
, SCM_CHAR (chr
));
1280 scm_i_string_stop_writing ();
1282 return SCM_UNSPECIFIED
;
1287 scm_c_string_set_x (SCM str
, size_t p
, SCM chr
)
1289 if (p
>= scm_i_string_length (str
))
1290 scm_out_of_range (NULL
, scm_from_size_t (p
));
1291 str
= scm_i_string_start_writing (str
);
1292 scm_i_string_set_x (str
, p
, SCM_CHAR (chr
));
1293 scm_i_string_stop_writing ();
1296 SCM_DEFINE (scm_substring
, "substring", 2, 1, 0,
1297 (SCM str
, SCM start
, SCM end
),
1298 "Return a newly allocated string formed from the characters\n"
1299 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1300 "ending with index @var{end} (exclusive).\n"
1301 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1302 "exact integers satisfying:\n\n"
1303 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1304 #define FUNC_NAME s_scm_substring
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 (str
, from
, to
);
1319 SCM_DEFINE (scm_substring_read_only
, "substring/read-only", 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"
1327 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
1329 "The returned string is read-only.\n")
1330 #define FUNC_NAME s_scm_substring_read_only
1332 size_t len
, from
, to
;
1334 SCM_VALIDATE_STRING (1, str
);
1335 len
= scm_i_string_length (str
);
1336 from
= scm_to_unsigned_integer (start
, 0, len
);
1337 if (SCM_UNBNDP (end
))
1340 to
= scm_to_unsigned_integer (end
, from
, len
);
1341 return scm_i_substring_read_only (str
, from
, to
);
1345 SCM_DEFINE (scm_substring_copy
, "substring/copy", 2, 1, 0,
1346 (SCM str
, SCM start
, SCM end
),
1347 "Return a newly allocated string formed from the characters\n"
1348 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1349 "ending with index @var{end} (exclusive).\n"
1350 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1351 "exact integers satisfying:\n\n"
1352 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1353 #define FUNC_NAME s_scm_substring_copy
1355 /* For the Scheme version, START is mandatory, but for the C
1356 version, it is optional. See scm_string_copy in srfi-13.c for a
1362 SCM_VALIDATE_STRING (1, str
);
1363 scm_i_get_substring_spec (scm_i_string_length (str
),
1364 start
, &from
, end
, &to
);
1365 return scm_i_substring_copy (str
, from
, to
);
1369 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
1370 (SCM str
, SCM start
, SCM end
),
1371 "Return string that indirectly refers to the characters\n"
1372 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1373 "ending with index @var{end} (exclusive).\n"
1374 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1375 "exact integers satisfying:\n\n"
1376 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1377 #define FUNC_NAME s_scm_substring_shared
1379 size_t len
, from
, to
;
1381 SCM_VALIDATE_STRING (1, str
);
1382 len
= scm_i_string_length (str
);
1383 from
= scm_to_unsigned_integer (start
, 0, len
);
1384 if (SCM_UNBNDP (end
))
1387 to
= scm_to_unsigned_integer (end
, from
, len
);
1388 return scm_i_substring_shared (str
, from
, to
);
1392 SCM_DEFINE (scm_string_append
, "string-append", 0, 0, 1,
1394 "Return a newly allocated string whose characters form the\n"
1395 "concatenation of the given strings, @var{args}.")
1396 #define FUNC_NAME s_scm_string_append
1409 SCM_VALIDATE_REST_ARGUMENT (args
);
1410 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1413 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1414 len
+= scm_i_string_length (s
);
1415 if (!scm_i_is_narrow_string (s
))
1420 res
= scm_i_make_string (len
, &data
.narrow
, 0);
1422 res
= scm_i_make_wide_string (len
, &data
.wide
, 0);
1424 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1428 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1429 len
= scm_i_string_length (s
);
1432 memcpy (data
.narrow
, scm_i_string_chars (s
), len
);
1437 if (scm_i_is_narrow_string (s
))
1439 for (i
= 0; i
< scm_i_string_length (s
); i
++)
1440 data
.wide
[i
] = (unsigned char) scm_i_string_chars (s
)[i
];
1443 u32_cpy ((scm_t_uint32
*) data
.wide
,
1444 (scm_t_uint32
*) scm_i_string_wide_chars (s
), len
);
1447 scm_remember_upto_here_1 (s
);
1455 /* Charset conversion error handling. */
1457 SCM_SYMBOL (scm_encoding_error_key
, "encoding-error");
1458 SCM_SYMBOL (scm_decoding_error_key
, "decoding-error");
1460 /* Raise an exception informing that character CHR could not be written
1461 to PORT in its current encoding. */
1463 scm_encoding_error (const char *subr
, int err
, const char *message
,
1466 scm_throw (scm_encoding_error_key
,
1467 scm_list_n (scm_from_latin1_string (subr
),
1468 scm_from_latin1_string (message
),
1474 /* Raise an exception informing of an encoding error on PORT. This
1475 means that a character could not be written in PORT's encoding. */
1477 scm_decoding_error (const char *subr
, int err
, const char *message
, SCM port
)
1479 scm_throw (scm_decoding_error_key
,
1480 scm_list_n (scm_from_latin1_string (subr
),
1481 scm_from_latin1_string (message
),
1488 /* String conversion to/from C. */
1491 decoding_error (const char *func_name
, int errno_save
,
1492 const char *str
, size_t len
)
1494 /* Raise an error and pass the raw C string as a bytevector to the `throw'
1499 buf
= scm_gc_malloc_pointerless (len
, "bytevector");
1500 memcpy (buf
, str
, len
);
1501 bv
= scm_c_take_gc_bytevector (buf
, len
, SCM_BOOL_F
);
1503 scm_decoding_error (func_name
, errno_save
,
1504 "input locale conversion error", bv
);
1508 scm_from_stringn (const char *str
, size_t len
, const char *encoding
,
1509 scm_t_string_failed_conversion_handler handler
)
1516 /* The order of these checks is important. */
1517 if (!str
&& len
!= 0)
1518 scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL
);
1519 if (len
== (size_t) -1)
1522 if (encoding
== NULL
|| len
== 0)
1524 /* If encoding is null (or the string is empty), use Latin-1. */
1526 res
= scm_i_make_string (len
, &buf
, 0);
1527 memcpy (buf
, str
, len
);
1532 u32
= (scm_t_wchar
*) u32_conv_from_encoding (encoding
,
1533 (enum iconv_ilseq_handler
)
1539 if (SCM_UNLIKELY (u32
== NULL
))
1540 decoding_error (__func__
, errno
, str
, len
);
1544 if (u32
[i
++] > 0xFF)
1553 res
= scm_i_make_string (u32len
, &dst
, 0);
1554 for (i
= 0; i
< u32len
; i
++)
1555 dst
[i
] = (unsigned char) u32
[i
];
1561 res
= scm_i_make_wide_string (u32len
, &wdst
, 0);
1562 u32_cpy ((scm_t_uint32
*) wdst
, (scm_t_uint32
*) u32
, u32len
);
1571 scm_from_locale_string (const char *str
)
1573 return scm_from_locale_stringn (str
, -1);
1577 scm_from_locale_stringn (const char *str
, size_t len
)
1579 return scm_from_stringn (str
, len
, locale_charset (),
1580 scm_i_get_conversion_strategy (SCM_BOOL_F
));
1584 scm_from_latin1_string (const char *str
)
1586 return scm_from_latin1_stringn (str
, -1);
1590 scm_from_latin1_stringn (const char *str
, size_t len
)
1595 if (len
== (size_t) -1)
1598 /* Make a narrow string and copy STR as is. */
1599 result
= scm_i_make_string (len
, &buf
, 0);
1600 memcpy (buf
, str
, len
);
1606 scm_from_utf8_string (const char *str
)
1608 return scm_from_utf8_stringn (str
, -1);
1612 scm_from_utf8_stringn (const char *str
, size_t len
)
1615 const scm_t_uint8
*ustr
= (const scm_t_uint8
*) str
;
1616 int ascii
= 1, narrow
= 1;
1619 if (len
== (size_t) -1)
1639 nbytes
= u8_mbtouc (&c
, ustr
+ i
, len
- i
);
1643 decoding_error (__func__
, errno
, str
, len
);
1656 res
= scm_i_make_string (char_len
, &dst
, 0);
1657 memcpy (dst
, str
, len
);
1665 res
= scm_i_make_string (char_len
, &dst
, 0);
1667 for (i
= 0, j
= 0; i
< len
; i
++, j
++)
1669 i
+= u8_mbtouc_unsafe (&c
, ustr
+ i
, len
- i
);
1670 dst
[j
] = (signed char) c
;
1679 res
= scm_i_make_wide_string (char_len
, &dst
, 0);
1681 for (i
= 0, j
= 0; i
< len
; i
++, j
++)
1683 i
+= u8_mbtouc_unsafe (&c
, ustr
+ i
, len
- i
);
1692 scm_from_utf32_string (const scm_t_wchar
*str
)
1694 return scm_from_utf32_stringn (str
, -1);
1698 scm_from_utf32_stringn (const scm_t_wchar
*str
, size_t len
)
1703 if (len
== (size_t) -1)
1704 len
= u32_strlen ((uint32_t *) str
);
1706 result
= scm_i_make_wide_string (len
, &buf
, 0);
1707 memcpy (buf
, str
, len
* sizeof (scm_t_wchar
));
1708 scm_i_try_narrow_string (result
);
1713 /* Create a new scheme string from the C string STR. The memory of
1714 STR may be used directly as storage for the new string. */
1715 /* FIXME: GC-wise, the only way to use the memory area pointed to by STR
1716 would be to register a finalizer to eventually free(3) STR, which isn't
1717 worth it. Should we just deprecate the `scm_take_' functions? */
1719 scm_take_locale_stringn (char *str
, size_t len
)
1723 res
= scm_from_locale_stringn (str
, len
);
1730 scm_take_locale_string (char *str
)
1732 return scm_take_locale_stringn (str
, -1);
1735 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1736 *LENP-byte locale-encoded string, to `\xXX', `\uXXXX', or `\UXXXXXX'.
1737 Set *LENP to the size of the resulting string.
1739 FIXME: This is a hack we should get rid of. See
1740 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00004.html>
1743 unistring_escapes_to_guile_escapes (char *buf
, size_t *lenp
)
1745 char *before
, *after
;
1754 if ((i
<= *lenp
- 6)
1755 && before
[i
] == '\\'
1756 && before
[i
+ 1] == 'u'
1757 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1759 /* Convert \u00NN to \xNN */
1762 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1763 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1767 else if ((i
<= *lenp
- 10)
1768 && before
[i
] == '\\'
1769 && before
[i
+ 1] == 'U'
1770 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1772 /* Convert \U00NNNNNN to \UNNNNNN */
1775 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1776 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1777 after
[j
+ 4] = tolower ((int) before
[i
+ 6]);
1778 after
[j
+ 5] = tolower ((int) before
[i
+ 7]);
1779 after
[j
+ 6] = tolower ((int) before
[i
+ 8]);
1780 after
[j
+ 7] = tolower ((int) before
[i
+ 9]);
1786 after
[j
] = before
[i
];
1794 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1795 *LENP-byte locale-encoded string, to `\xXXXX;'. Set *LEN to the size
1796 of the resulting string. BUF must be large enough to handle the
1797 worst case when `\uXXXX' escapes (6 characters) are replaced by
1798 `\xXXXX;' (7 characters). */
1800 unistring_escapes_to_r6rs_escapes (char *buf
, size_t *lenp
)
1802 char *before
, *after
;
1804 /* The worst case is if the input string contains all 4-digit hex escapes.
1805 "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */
1806 size_t max_out_len
= (*lenp
* 7) / 6 + 1;
1807 size_t nzeros
, ndigits
;
1810 after
= alloca (max_out_len
);
1815 if (((i
<= *lenp
- 6) && before
[i
] == '\\' && before
[i
+ 1] == 'u')
1816 || ((i
<= *lenp
- 10) && before
[i
] == '\\' && before
[i
+ 1] == 'U'))
1818 if (before
[i
+ 1] == 'u')
1820 else if (before
[i
+ 1] == 'U')
1825 /* Add the R6RS hex escape initial sequence. */
1829 /* Move string positions to the start of the hex numbers. */
1833 /* Find the number of initial zeros in this hex number. */
1835 while (before
[i
+ nzeros
] == '0' && nzeros
< ndigits
)
1838 /* Copy the number, skipping initial zeros, and then move the string
1840 if (nzeros
== ndigits
)
1849 for (pos
= 0; pos
< ndigits
- nzeros
; pos
++)
1850 after
[j
+ pos
] = tolower ((int) before
[i
+ nzeros
+ pos
]);
1852 j
+= (ndigits
- nzeros
);
1855 /* Add terminating semicolon. */
1861 after
[j
] = before
[i
];
1867 memcpy (before
, after
, j
);
1871 scm_to_locale_string (SCM str
)
1873 return scm_to_locale_stringn (str
, NULL
);
1877 scm_to_locale_stringn (SCM str
, size_t *lenp
)
1879 return scm_to_stringn (str
, lenp
,
1881 scm_i_get_conversion_strategy (SCM_BOOL_F
));
1885 scm_to_latin1_string (SCM str
)
1887 return scm_to_latin1_stringn (str
, NULL
);
1891 scm_to_latin1_stringn (SCM str
, size_t *lenp
)
1892 #define FUNC_NAME "scm_to_latin1_stringn"
1896 SCM_VALIDATE_STRING (1, str
);
1898 if (scm_i_is_narrow_string (str
))
1900 size_t len
= scm_i_string_length (str
);
1905 result
= scm_strndup (scm_i_string_data (str
), len
);
1908 result
= scm_to_stringn (str
, lenp
, NULL
,
1909 SCM_FAILED_CONVERSION_ERROR
);
1916 scm_to_utf8_string (SCM str
)
1918 return scm_to_utf8_stringn (str
, NULL
);
1922 scm_to_utf8_stringn (SCM str
, size_t *lenp
)
1924 return scm_to_stringn (str
, lenp
, "UTF-8", SCM_FAILED_CONVERSION_ERROR
);
1928 scm_to_utf32_string (SCM str
)
1930 return scm_to_utf32_stringn (str
, NULL
);
1934 scm_to_utf32_stringn (SCM str
, size_t *lenp
)
1935 #define FUNC_NAME "scm_to_utf32_stringn"
1937 scm_t_wchar
*result
;
1939 SCM_VALIDATE_STRING (1, str
);
1941 if (scm_i_is_narrow_string (str
))
1942 result
= (scm_t_wchar
*)
1943 scm_to_stringn (str
, lenp
, "UTF-32",
1944 SCM_FAILED_CONVERSION_ERROR
);
1949 len
= scm_i_string_length (str
);
1953 result
= scm_malloc ((len
+ 1) * sizeof (scm_t_wchar
));
1954 memcpy (result
, scm_i_string_wide_chars (str
),
1955 len
* sizeof (scm_t_wchar
));
1963 /* Return a malloc(3)-allocated buffer containing the contents of STR encoded
1964 according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
1965 the returned buffer. If the conversion to ENCODING fails, apply the strategy
1966 defined by HANDLER. */
1968 scm_to_stringn (SCM str
, size_t *lenp
, const char *encoding
,
1969 scm_t_string_failed_conversion_handler handler
)
1972 size_t ilen
, len
, i
;
1976 if (!scm_is_string (str
))
1977 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
1978 ilen
= scm_i_string_length (str
);
1982 buf
= scm_malloc (1);
1990 for (i
= 0; i
< ilen
; i
++)
1991 if (scm_i_string_ref (str
, i
) == '\0')
1992 scm_misc_error (NULL
,
1993 "string contains #\\nul character: ~S",
1996 if (scm_i_is_narrow_string (str
) && (encoding
== NULL
))
1998 /* If using native Latin-1 encoding, just copy the string
2002 buf
= scm_malloc (ilen
);
2003 memcpy (buf
, scm_i_string_chars (str
), ilen
);
2009 buf
= scm_malloc (ilen
+ 1);
2010 memcpy (buf
, scm_i_string_chars (str
), ilen
);
2022 if (scm_i_is_narrow_string (str
))
2024 ret
= mem_iconveh (scm_i_string_chars (str
), ilen
,
2026 (enum iconv_ilseq_handler
) handler
, NULL
,
2030 scm_encoding_error (__func__
, errno
,
2031 "cannot convert narrow string to output locale",
2033 /* FIXME: Faulty character unknown. */
2038 buf
= u32_conv_to_encoding (enc
,
2039 (enum iconv_ilseq_handler
) handler
,
2040 (scm_t_uint32
*) scm_i_string_wide_chars (str
),
2045 scm_encoding_error (__func__
, errno
,
2046 "cannot convert wide string to output locale",
2048 /* FIXME: Faulty character unknown. */
2051 if (handler
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
2053 if (SCM_R6RS_ESCAPES_P
)
2055 /* The worst case is if the input string contains all 4-digit
2056 hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;"
2057 (seven characters). Make BUF large enough to hold
2059 buf
= scm_realloc (buf
, (len
* 7) / 6 + 1);
2060 unistring_escapes_to_r6rs_escapes (buf
, &len
);
2063 unistring_escapes_to_guile_escapes (buf
, &len
);
2065 buf
= scm_realloc (buf
, len
);
2071 buf
= scm_realloc (buf
, len
+ 1);
2075 scm_remember_upto_here_1 (str
);
2080 scm_to_locale_stringbuf (SCM str
, char *buf
, size_t max_len
)
2083 char *result
= NULL
;
2084 if (!scm_is_string (str
))
2085 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
2086 result
= scm_to_locale_stringn (str
, &len
);
2088 memcpy (buf
, result
, (len
> max_len
) ? max_len
: len
);
2091 scm_remember_upto_here_1 (str
);
2096 /* Unicode string normalization. */
2098 /* This function is a partial clone of SCM_STRING_TO_U32_BUF from
2099 libguile/i18n.c. It would be useful to have this factored out into a more
2100 convenient location, but its use of alloca makes that tricky to do. */
2103 normalize_str (SCM string
, uninorm_t form
)
2106 scm_t_uint32
*w_str
;
2108 size_t rlen
, len
= scm_i_string_length (string
);
2110 if (scm_i_is_narrow_string (string
))
2113 const char *buf
= scm_i_string_chars (string
);
2115 w_str
= alloca (sizeof (scm_t_wchar
) * (len
+ 1));
2117 for (i
= 0; i
< len
; i
++)
2118 w_str
[i
] = (unsigned char) buf
[i
];
2122 w_str
= (scm_t_uint32
*) scm_i_string_wide_chars (string
);
2124 w_str
= u32_normalize (form
, w_str
, len
, NULL
, &rlen
);
2126 ret
= scm_i_make_wide_string (rlen
, &cbuf
, 0);
2127 u32_cpy ((scm_t_uint32
*) cbuf
, w_str
, rlen
);
2130 scm_i_try_narrow_string (ret
);
2135 SCM_DEFINE (scm_string_normalize_nfc
, "string-normalize-nfc", 1, 0, 0,
2137 "Returns the NFC normalized form of @var{string}.")
2138 #define FUNC_NAME s_scm_string_normalize_nfc
2140 SCM_VALIDATE_STRING (1, string
);
2141 return normalize_str (string
, UNINORM_NFC
);
2145 SCM_DEFINE (scm_string_normalize_nfd
, "string-normalize-nfd", 1, 0, 0,
2147 "Returns the NFD normalized form of @var{string}.")
2148 #define FUNC_NAME s_scm_string_normalize_nfd
2150 SCM_VALIDATE_STRING (1, string
);
2151 return normalize_str (string
, UNINORM_NFD
);
2155 SCM_DEFINE (scm_string_normalize_nfkc
, "string-normalize-nfkc", 1, 0, 0,
2157 "Returns the NFKC normalized form of @var{string}.")
2158 #define FUNC_NAME s_scm_string_normalize_nfkc
2160 SCM_VALIDATE_STRING (1, string
);
2161 return normalize_str (string
, UNINORM_NFKC
);
2165 SCM_DEFINE (scm_string_normalize_nfkd
, "string-normalize-nfkd", 1, 0, 0,
2167 "Returns the NFKD normalized form of @var{string}.")
2168 #define FUNC_NAME s_scm_string_normalize_nfkd
2170 SCM_VALIDATE_STRING (1, string
);
2171 return normalize_str (string
, UNINORM_NFKD
);
2175 /* converts C scm_array of strings to SCM scm_list of strings.
2176 If argc < 0, a null terminated scm_array is assumed.
2177 The current locale encoding is assumed */
2179 scm_makfromstrs (int argc
, char **argv
)
2184 for (i
= 0; argv
[i
]; i
++);
2186 lst
= scm_cons (scm_from_locale_string (argv
[i
]), lst
);
2190 /* Return a newly allocated array of char pointers to each of the strings
2191 in args, with a terminating NULL pointer. The strings are encoded using
2192 the current locale. */
2195 scm_i_allocate_string_pointers (SCM list
)
2196 #define FUNC_NAME "scm_i_allocate_string_pointers"
2199 int list_len
= scm_ilength (list
);
2203 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
2205 result
= scm_gc_malloc ((list_len
+ 1) * sizeof (char *),
2207 result
[list_len
] = NULL
;
2209 /* The list might have been modified in another thread, so
2210 we check LIST before each access.
2212 for (i
= 0; i
< list_len
&& scm_is_pair (list
); i
++)
2214 SCM str
= SCM_CAR (list
);
2215 size_t len
; /* String length in bytes */
2216 char *c_str
= scm_to_locale_stringn (str
, &len
);
2218 /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses
2219 scm_malloc to allocate the returned string, which must be
2220 explicitly deallocated. This forces us to copy the string a
2221 second time into a new buffer. Ideally there would be variants
2222 of scm_to_*_stringn that can return garbage-collected buffers. */
2224 result
[i
] = scm_gc_malloc_pointerless (len
+ 1, "string");
2225 memcpy (result
[i
], c_str
, len
);
2226 result
[i
][len
] = '\0';
2229 list
= SCM_CDR (list
);
2237 scm_i_get_substring_spec (size_t len
,
2238 SCM start
, size_t *cstart
,
2239 SCM end
, size_t *cend
)
2241 if (SCM_UNBNDP (start
))
2244 *cstart
= scm_to_unsigned_integer (start
, 0, len
);
2246 if (SCM_UNBNDP (end
))
2249 *cend
= scm_to_unsigned_integer (end
, *cstart
, len
);
2253 string_handle_ref (scm_t_array_handle
*h
, size_t index
)
2255 return scm_c_string_ref (h
->array
, index
);
2259 string_handle_set (scm_t_array_handle
*h
, size_t index
, SCM val
)
2261 scm_c_string_set_x (h
->array
, index
, val
);
2265 string_get_handle (SCM v
, scm_t_array_handle
*h
)
2271 h
->dim0
.ubnd
= scm_c_string_length (v
) - 1;
2273 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_CHAR
;
2274 h
->elements
= h
->writable_elements
= NULL
;
2277 SCM_ARRAY_IMPLEMENTATION (scm_tc7_string
, 0x7f,
2278 string_handle_ref
, string_handle_set
,
2280 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR
, scm_make_string
)
2285 scm_nullstr
= scm_i_make_string (0, NULL
, 0);
2287 #include "libguile/strings.x"