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 static SCM null_stringbuf
;
266 init_null_stringbuf (void)
268 null_stringbuf
= make_stringbuf (0);
269 SET_STRINGBUF_SHARED (null_stringbuf
);
272 /* Create a scheme string with space for LEN 8-bit Latin-1-encoded
273 characters. CHARSP, if not NULL, will be set to location of the
274 char array. If READ_ONLY_P, the returned string is read-only;
275 otherwise it is writable. */
277 scm_i_make_string (size_t len
, char **charsp
, int read_only_p
)
284 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
285 scm_i_pthread_once (&once
, init_null_stringbuf
);
286 buf
= null_stringbuf
;
289 buf
= make_stringbuf (len
);
292 *charsp
= (char *) STRINGBUF_CHARS (buf
);
293 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
295 (scm_t_bits
) 0, (scm_t_bits
) len
);
299 /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
300 characters. CHARSP, if not NULL, will be set to location of the
301 character array. If READ_ONLY_P, the returned string is read-only;
302 otherwise it is writable. */
304 scm_i_make_wide_string (size_t len
, scm_t_wchar
**charsp
, int read_only_p
)
306 SCM buf
= make_wide_stringbuf (len
);
309 *charsp
= STRINGBUF_WIDE_CHARS (buf
);
310 res
= scm_double_cell (read_only_p
? RO_STRING_TAG
: STRING_TAG
,
312 (scm_t_bits
) 0, (scm_t_bits
) len
);
317 validate_substring_args (SCM str
, size_t start
, size_t end
)
319 if (!IS_STRING (str
))
320 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
321 if (start
> STRING_LENGTH (str
))
322 scm_out_of_range (NULL
, scm_from_size_t (start
));
323 if (end
> STRING_LENGTH (str
) || end
< start
)
324 scm_out_of_range (NULL
, scm_from_size_t (end
));
328 get_str_buf_start (SCM
*str
, SCM
*buf
, size_t *start
)
330 *start
= STRING_START (*str
);
331 if (IS_SH_STRING (*str
))
333 *str
= SH_STRING_STRING (*str
);
334 *start
+= STRING_START (*str
);
336 *buf
= STRING_STRINGBUF (*str
);
340 scm_i_substring (SCM str
, size_t start
, size_t end
)
343 return scm_i_make_string (0, NULL
, 0);
348 get_str_buf_start (&str
, &buf
, &str_start
);
349 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
350 SET_STRINGBUF_SHARED (buf
);
351 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
352 return scm_double_cell (STRING_TAG
, SCM_UNPACK(buf
),
353 (scm_t_bits
)str_start
+ start
,
354 (scm_t_bits
) end
- start
);
359 scm_i_substring_read_only (SCM str
, size_t start
, size_t end
)
362 return scm_i_make_string (0, NULL
, 1);
367 get_str_buf_start (&str
, &buf
, &str_start
);
368 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
369 SET_STRINGBUF_SHARED (buf
);
370 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
371 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK(buf
),
372 (scm_t_bits
)str_start
+ start
,
373 (scm_t_bits
) end
- start
);
378 scm_i_substring_copy (SCM str
, size_t start
, size_t end
)
381 return scm_i_make_string (0, NULL
, 0);
384 size_t len
= end
- start
;
385 SCM buf
, my_buf
, substr
;
388 get_str_buf_start (&str
, &buf
, &str_start
);
389 if (scm_i_is_narrow_string (str
))
391 my_buf
= make_stringbuf (len
);
392 memcpy (STRINGBUF_CHARS (my_buf
),
393 STRINGBUF_CHARS (buf
) + str_start
+ start
, len
);
397 my_buf
= make_wide_stringbuf (len
);
398 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (my_buf
),
399 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
) + str_start
403 scm_remember_upto_here_1 (buf
);
404 substr
= scm_double_cell (STRING_TAG
, SCM_UNPACK (my_buf
),
405 (scm_t_bits
) 0, (scm_t_bits
) len
);
407 scm_i_try_narrow_string (substr
);
413 scm_i_substring_shared (SCM str
, size_t start
, size_t end
)
415 if (start
== 0 && end
== STRING_LENGTH (str
))
417 else if (start
== end
)
418 return scm_i_make_string (0, NULL
, 0);
421 size_t len
= end
- start
;
422 if (IS_SH_STRING (str
))
424 start
+= STRING_START (str
);
425 str
= SH_STRING_STRING (str
);
427 return scm_double_cell (SH_STRING_TAG
, SCM_UNPACK(str
),
428 (scm_t_bits
)start
, (scm_t_bits
) len
);
433 scm_c_substring (SCM str
, size_t start
, size_t end
)
435 validate_substring_args (str
, start
, end
);
436 return scm_i_substring (str
, start
, end
);
440 scm_c_substring_read_only (SCM str
, size_t start
, size_t end
)
442 validate_substring_args (str
, start
, end
);
443 return scm_i_substring_read_only (str
, start
, end
);
447 scm_c_substring_copy (SCM str
, size_t start
, size_t end
)
449 validate_substring_args (str
, start
, end
);
450 return scm_i_substring_copy (str
, start
, end
);
454 scm_c_substring_shared (SCM str
, size_t start
, size_t end
)
456 validate_substring_args (str
, start
, end
);
457 return scm_i_substring_shared (str
, start
, end
);
461 /* Internal accessors
464 /* Returns the number of characters in STR. This may be different
465 than the memory size of the string storage. */
467 scm_i_string_length (SCM str
)
469 return STRING_LENGTH (str
);
472 /* True if the string is 'narrow', meaning it has a 8-bit Latin-1
473 encoding. False if it is 'wide', having a 32-bit UCS-4
476 scm_i_is_narrow_string (SCM str
)
478 if (IS_SH_STRING (str
))
479 str
= SH_STRING_STRING (str
);
481 return !STRINGBUF_WIDE (STRING_STRINGBUF (str
));
484 /* Try to coerce a string to be narrow. It if is narrow already, do
485 nothing. If it is wide, shrink it to narrow if none of its
486 characters are above 0xFF. Return true if the string is narrow or
487 was made to be narrow. */
489 scm_i_try_narrow_string (SCM str
)
491 if (IS_SH_STRING (str
))
492 str
= SH_STRING_STRING (str
);
494 SET_STRING_STRINGBUF (str
, narrow_stringbuf (STRING_STRINGBUF (str
)));
496 return scm_i_is_narrow_string (str
);
499 /* Return a pointer to the raw data of the string, which can be either Latin-1
500 or UCS-4 encoded data, depending on `scm_i_is_narrow_string (STR)'. */
502 scm_i_string_data (SCM str
)
508 get_str_buf_start (&str
, &buf
, &start
);
510 data
= STRINGBUF_CONTENTS (buf
);
511 data
+= start
* (scm_i_is_narrow_string (str
) ? 1 : 4);
516 /* Returns a pointer to the 8-bit Latin-1 encoded character array of
519 scm_i_string_chars (SCM str
)
523 get_str_buf_start (&str
, &buf
, &start
);
524 if (scm_i_is_narrow_string (str
))
525 return (const char *) STRINGBUF_CHARS (buf
) + start
;
527 scm_misc_error (NULL
, "Invalid read access of chars of wide string: ~s",
532 /* Returns a pointer to the 32-bit UCS-4 encoded character array of
535 scm_i_string_wide_chars (SCM str
)
540 get_str_buf_start (&str
, &buf
, &start
);
541 if (!scm_i_is_narrow_string (str
))
542 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
) + start
;
544 scm_misc_error (NULL
, "Invalid read access of chars of narrow string: ~s",
548 /* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
549 a new string buffer, so that it can be modified without modifying
550 other strings. Also, lock the string mutex. Later, one must call
551 scm_i_string_stop_writing to unlock the mutex. */
553 scm_i_string_start_writing (SCM orig_str
)
555 SCM buf
, str
= orig_str
;
558 get_str_buf_start (&str
, &buf
, &start
);
559 if (IS_RO_STRING (str
))
560 scm_misc_error (NULL
, "string is read-only: ~s", scm_list_1 (orig_str
));
562 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
563 if (STRINGBUF_SHARED (buf
))
565 /* Clone the stringbuf. */
566 size_t len
= STRING_LENGTH (str
);
569 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
571 if (scm_i_is_narrow_string (str
))
573 new_buf
= make_stringbuf (len
);
574 memcpy (STRINGBUF_CHARS (new_buf
),
575 STRINGBUF_CHARS (buf
) + STRING_START (str
), len
);
580 new_buf
= make_wide_stringbuf (len
);
581 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
582 (scm_t_uint32
*) (STRINGBUF_WIDE_CHARS (buf
)
583 + STRING_START (str
)), len
);
586 SET_STRING_STRINGBUF (str
, new_buf
);
587 start
-= STRING_START (str
);
589 /* FIXME: The following operations are not atomic, so other threads
590 looking at STR may see an inconsistent state. Nevertheless it can't
591 hurt much since (i) accessing STR while it is being mutated can't
592 yield a crash, and (ii) concurrent accesses to STR should be
593 protected by a mutex at the application level. The latter may not
594 apply when STR != ORIG_STR, though. */
595 SET_STRING_START (str
, 0);
596 SET_STRING_STRINGBUF (str
, new_buf
);
600 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
605 /* Return a pointer to the 8-bit Latin-1 chars of a string. */
607 scm_i_string_writable_chars (SCM str
)
612 get_str_buf_start (&str
, &buf
, &start
);
613 if (scm_i_is_narrow_string (str
))
614 return (char *) STRINGBUF_CHARS (buf
) + start
;
616 scm_misc_error (NULL
, "Invalid write access of chars of wide string: ~s",
621 /* Return a pointer to the UCS-4 codepoints of a string. */
623 scm_i_string_writable_wide_chars (SCM str
)
628 get_str_buf_start (&str
, &buf
, &start
);
629 if (!scm_i_is_narrow_string (str
))
630 return STRINGBUF_WIDE_CHARS (buf
) + start
;
632 scm_misc_error (NULL
, "Invalid write access of chars of narrow string: ~s",
636 /* Unlock the string mutex that was locked when
637 scm_i_string_start_writing was called. */
639 scm_i_string_stop_writing (void)
641 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
644 /* Return the Xth character of STR as a UCS-4 codepoint. */
646 scm_i_string_ref (SCM str
, size_t x
)
648 if (scm_i_is_narrow_string (str
))
649 return (scm_t_wchar
) (unsigned char) (scm_i_string_chars (str
)[x
]);
651 return scm_i_string_wide_chars (str
)[x
];
654 /* Returns index+1 of the first char in STR that matches C, or
655 0 if the char is not found. */
657 scm_i_string_contains_char (SCM str
, char ch
)
660 size_t len
= scm_i_string_length (str
);
663 if (scm_i_is_narrow_string (str
))
667 if (scm_i_string_chars (str
)[i
] == ch
)
676 if (scm_i_string_wide_chars (str
)[i
]
677 == (unsigned char) ch
)
686 scm_i_string_strcmp (SCM sstr
, size_t start_x
, const char *cstr
)
688 if (scm_i_is_narrow_string (sstr
))
690 const char *a
= scm_i_string_chars (sstr
) + start_x
;
691 const char *b
= cstr
;
692 return strncmp (a
, b
, strlen(b
));
697 const scm_t_wchar
*a
= scm_i_string_wide_chars (sstr
) + start_x
;
698 const char *b
= cstr
;
699 for (i
= 0; i
< strlen (b
); i
++)
701 if (a
[i
] != (unsigned char) b
[i
])
708 /* Set the Pth character of STR to UCS-4 codepoint CHR. */
710 scm_i_string_set_x (SCM str
, size_t p
, scm_t_wchar chr
)
712 if (IS_SH_STRING (str
))
714 p
+= STRING_START (str
);
715 str
= SH_STRING_STRING (str
);
718 if (chr
> 0xFF && scm_i_is_narrow_string (str
))
719 SET_STRING_STRINGBUF (str
, wide_stringbuf (STRING_STRINGBUF (str
)));
721 if (scm_i_is_narrow_string (str
))
723 char *dst
= scm_i_string_writable_chars (str
);
728 scm_t_wchar
*dst
= scm_i_string_writable_wide_chars (str
);
736 Basic symbol creation and accessing is done here, the rest is in
737 symbols.[hc]. This has been done to keep stringbufs and the
738 internals of strings and string-like objects confined to this file.
741 #define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
744 scm_i_make_symbol (SCM name
, scm_t_bits flags
,
745 unsigned long hash
, SCM props
)
748 size_t start
= STRING_START (name
);
749 size_t length
= STRING_LENGTH (name
);
751 if (IS_SH_STRING (name
))
753 name
= SH_STRING_STRING (name
);
754 start
+= STRING_START (name
);
756 buf
= STRING_STRINGBUF (name
);
758 if (start
== 0 && length
== STRINGBUF_LENGTH (buf
))
761 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
762 SET_STRINGBUF_SHARED (buf
);
763 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
768 if (scm_i_is_narrow_string (name
))
770 SCM new_buf
= make_stringbuf (length
);
771 memcpy (STRINGBUF_CHARS (new_buf
),
772 STRINGBUF_CHARS (buf
) + start
, length
);
777 SCM new_buf
= make_wide_stringbuf (length
);
778 u32_cpy ((scm_t_uint32
*) STRINGBUF_WIDE_CHARS (new_buf
),
779 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
) + start
,
784 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
785 (scm_t_bits
) hash
, SCM_UNPACK (props
));
789 scm_i_c_make_symbol (const char *name
, size_t len
,
790 scm_t_bits flags
, unsigned long hash
, SCM props
)
792 SCM buf
= make_stringbuf (len
);
793 memcpy (STRINGBUF_CHARS (buf
), name
, len
);
795 return scm_double_cell (scm_tc7_symbol
| flags
, SCM_UNPACK (buf
),
796 (scm_t_bits
) hash
, SCM_UNPACK (props
));
799 /* Returns the number of characters in SYM. This may be different
800 from the memory size of SYM. */
802 scm_i_symbol_length (SCM sym
)
804 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
808 scm_c_symbol_length (SCM sym
)
809 #define FUNC_NAME "scm_c_symbol_length"
811 SCM_VALIDATE_SYMBOL (1, sym
);
813 return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym
));
817 /* True if the name of SYM is stored as a Latin-1 encoded string.
818 False if it is stored as a 32-bit UCS-4-encoded string. */
820 scm_i_is_narrow_symbol (SCM sym
)
824 buf
= SYMBOL_STRINGBUF (sym
);
825 return !STRINGBUF_WIDE (buf
);
828 /* Returns a pointer to the 8-bit Latin-1 encoded character array that
829 contains the name of SYM. */
831 scm_i_symbol_chars (SCM sym
)
835 buf
= SYMBOL_STRINGBUF (sym
);
836 if (!STRINGBUF_WIDE (buf
))
837 return (const char *) STRINGBUF_CHARS (buf
);
839 scm_misc_error (NULL
, "Invalid access of chars of a wide symbol ~S",
843 /* Return a pointer to the 32-bit UCS-4-encoded character array of a
846 scm_i_symbol_wide_chars (SCM sym
)
850 buf
= SYMBOL_STRINGBUF (sym
);
851 if (STRINGBUF_WIDE (buf
))
852 return (const scm_t_wchar
*) STRINGBUF_WIDE_CHARS (buf
);
854 scm_misc_error (NULL
, "Invalid access of chars of a narrow symbol ~S",
859 scm_i_symbol_substring (SCM sym
, size_t start
, size_t end
)
861 SCM buf
= SYMBOL_STRINGBUF (sym
);
862 scm_i_pthread_mutex_lock (&stringbuf_write_mutex
);
863 SET_STRINGBUF_SHARED (buf
);
864 scm_i_pthread_mutex_unlock (&stringbuf_write_mutex
);
865 return scm_double_cell (RO_STRING_TAG
, SCM_UNPACK (buf
),
866 (scm_t_bits
)start
, (scm_t_bits
) end
- start
);
869 /* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
871 scm_i_symbol_ref (SCM sym
, size_t x
)
873 if (scm_i_is_narrow_symbol (sym
))
874 return (scm_t_wchar
) (unsigned char) (scm_i_symbol_chars (sym
)[x
]);
876 return scm_i_symbol_wide_chars (sym
)[x
];
882 SCM_DEFINE (scm_sys_string_dump
, "%string-dump", 1, 0, 0, (SCM str
),
883 "Returns an association list containing debugging information\n"
884 "for @var{str}. The association list has the following entries."
887 "The string itself.\n"
889 "The start index of the string into its stringbuf\n"
891 "The length of the string\n"
893 "If this string is a substring, it returns its parent string.\n"
894 "Otherwise, it returns @code{#f}\n"
896 "@code{#t} if the string is read-only\n"
897 "@item stringbuf-chars\n"
898 "A new string containing this string's stringbuf's characters\n"
899 "@item stringbuf-length\n"
900 "The number of characters in this stringbuf\n"
901 "@item stringbuf-shared\n"
902 "@code{#t} if this stringbuf is shared\n"
903 "@item stringbuf-wide\n"
904 "@code{#t} if this stringbuf's characters are stored in a\n"
905 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
908 #define FUNC_NAME s_scm_sys_string_dump
910 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
;
912 SCM_VALIDATE_STRING (1, str
);
915 e1
= scm_cons (scm_from_latin1_symbol ("string"),
917 e2
= scm_cons (scm_from_latin1_symbol ("start"),
918 scm_from_size_t (STRING_START (str
)));
919 e3
= scm_cons (scm_from_latin1_symbol ("length"),
920 scm_from_size_t (STRING_LENGTH (str
)));
922 if (IS_SH_STRING (str
))
924 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
925 SH_STRING_STRING (str
));
926 buf
= STRING_STRINGBUF (SH_STRING_STRING (str
));
930 e4
= scm_cons (scm_from_latin1_symbol ("shared"),
932 buf
= STRING_STRINGBUF (str
);
935 if (IS_RO_STRING (str
))
936 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
939 e5
= scm_cons (scm_from_latin1_symbol ("read-only"),
943 if (!STRINGBUF_WIDE (buf
))
945 size_t len
= STRINGBUF_LENGTH (buf
);
947 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
948 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
949 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
954 size_t len
= STRINGBUF_LENGTH (buf
);
956 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
957 u32_cpy ((scm_t_uint32
*) cbuf
,
958 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
959 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
962 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
963 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
964 if (STRINGBUF_SHARED (buf
))
965 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
968 e8
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
970 if (STRINGBUF_WIDE (buf
))
971 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
974 e9
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
977 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, e8
, e9
, SCM_UNDEFINED
);
981 SCM_DEFINE (scm_sys_symbol_dump
, "%symbol-dump", 1, 0, 0, (SCM sym
),
982 "Returns an association list containing debugging information\n"
983 "for @var{sym}. The association list has the following entries."
986 "The symbol itself\n"
990 "@code{#t} if it is an interned symbol\n"
991 "@item stringbuf-chars\n"
992 "A new string containing this symbols's stringbuf's characters\n"
993 "@item stringbuf-length\n"
994 "The number of characters in this stringbuf\n"
995 "@item stringbuf-shared\n"
996 "@code{#t} if this stringbuf is shared\n"
997 "@item stringbuf-wide\n"
998 "@code{#t} if this stringbuf's characters are stored in a\n"
999 "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
1002 #define FUNC_NAME s_scm_sys_symbol_dump
1004 SCM e1
, e2
, e3
, e4
, e5
, e6
, e7
;
1006 SCM_VALIDATE_SYMBOL (1, sym
);
1007 e1
= scm_cons (scm_from_latin1_symbol ("symbol"),
1009 e2
= scm_cons (scm_from_latin1_symbol ("hash"),
1010 scm_from_ulong (scm_i_symbol_hash (sym
)));
1011 e3
= scm_cons (scm_from_latin1_symbol ("interned"),
1012 scm_symbol_interned_p (sym
));
1013 buf
= SYMBOL_STRINGBUF (sym
);
1015 /* Stringbuf info */
1016 if (!STRINGBUF_WIDE (buf
))
1018 size_t len
= STRINGBUF_LENGTH (buf
);
1020 SCM sbc
= scm_i_make_string (len
, &cbuf
, 0);
1021 memcpy (cbuf
, STRINGBUF_CHARS (buf
), len
);
1022 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
1027 size_t len
= STRINGBUF_LENGTH (buf
);
1029 SCM sbc
= scm_i_make_wide_string (len
, &cbuf
, 0);
1030 u32_cpy ((scm_t_uint32
*) cbuf
,
1031 (scm_t_uint32
*) STRINGBUF_WIDE_CHARS (buf
), len
);
1032 e4
= scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
1035 e5
= scm_cons (scm_from_latin1_symbol ("stringbuf-length"),
1036 scm_from_size_t (STRINGBUF_LENGTH (buf
)));
1037 if (STRINGBUF_SHARED (buf
))
1038 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1041 e6
= scm_cons (scm_from_latin1_symbol ("stringbuf-shared"),
1043 if (STRINGBUF_WIDE (buf
))
1044 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1047 e7
= scm_cons (scm_from_latin1_symbol ("stringbuf-wide"),
1049 return scm_list_n (e1
, e2
, e3
, e4
, e5
, e6
, e7
, SCM_UNDEFINED
);
1054 #ifdef SCM_STRING_LENGTH_HISTOGRAM
1056 SCM_DEFINE (scm_sys_stringbuf_hist
, "%stringbuf-hist", 0, 0, 0, (void), "")
1057 #define FUNC_NAME s_scm_sys_stringbuf_hist
1060 for (i
= 0; i
< 1000; i
++)
1062 fprintf (stderr
, " %3d: %u\n", i
, lenhist
[i
]);
1063 fprintf (stderr
, ">999: %u\n", lenhist
[1000]);
1064 return SCM_UNSPECIFIED
;
1072 SCM_DEFINE (scm_string_p
, "string?", 1, 0, 0,
1074 "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
1075 #define FUNC_NAME s_scm_string_p
1077 return scm_from_bool (IS_STRING (obj
));
1082 SCM_REGISTER_PROC (s_scm_list_to_string
, "list->string", 1, 0, 0, scm_string
);
1084 SCM_DEFINE (scm_string
, "string", 0, 0, 1,
1086 "@deffnx {Scheme Procedure} list->string chrs\n"
1087 "Return a newly allocated string composed of the arguments,\n"
1089 #define FUNC_NAME s_scm_string
1091 SCM result
= SCM_BOOL_F
;
1098 /* Verify that this is a list of chars. */
1099 i
= scm_ilength (chrs
);
1100 SCM_ASSERT (i
>= 0, chrs
, SCM_ARG1
, FUNC_NAME
);
1105 while (len
> 0 && scm_is_pair (rest
))
1107 SCM elt
= SCM_CAR (rest
);
1108 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
1109 if (SCM_CHAR (elt
) > 0xFF)
1111 rest
= SCM_CDR (rest
);
1113 scm_remember_upto_here_1 (elt
);
1116 /* Construct a string containing this list of chars. */
1124 result
= scm_i_make_string (len
, NULL
, 0);
1125 result
= scm_i_string_start_writing (result
);
1126 buf
= scm_i_string_writable_chars (result
);
1127 while (len
> 0 && scm_is_pair (rest
))
1129 SCM elt
= SCM_CAR (rest
);
1130 buf
[p
] = (unsigned char) SCM_CHAR (elt
);
1132 rest
= SCM_CDR (rest
);
1134 scm_remember_upto_here_1 (elt
);
1141 result
= scm_i_make_wide_string (len
, NULL
, 0);
1142 result
= scm_i_string_start_writing (result
);
1143 buf
= scm_i_string_writable_wide_chars (result
);
1144 while (len
> 0 && scm_is_pair (rest
))
1146 SCM elt
= SCM_CAR (rest
);
1147 buf
[p
] = SCM_CHAR (elt
);
1149 rest
= SCM_CDR (rest
);
1151 scm_remember_upto_here_1 (elt
);
1154 scm_i_string_stop_writing ();
1157 scm_misc_error (NULL
, "list changed while constructing string", SCM_EOL
);
1158 if (!scm_is_null (rest
))
1159 scm_wrong_type_arg_msg (NULL
, 0, chrs
, "proper list");
1165 SCM_DEFINE (scm_make_string
, "make-string", 1, 1, 0,
1167 "Return a newly allocated string of\n"
1168 "length @var{k}. If @var{chr} is given, then all elements of\n"
1169 "the string are initialized to @var{chr}, otherwise the contents\n"
1170 "of the string are all set to @code{#\nul}.")
1171 #define FUNC_NAME s_scm_make_string
1173 return scm_c_make_string (scm_to_size_t (k
), chr
);
1178 scm_c_make_string (size_t len
, SCM chr
)
1179 #define FUNC_NAME NULL
1182 char *contents
= NULL
;
1183 SCM res
= scm_i_make_string (len
, &contents
, 0);
1185 /* If no char is given, initialize string contents to NULL. */
1186 if (SCM_UNBNDP (chr
))
1187 memset (contents
, 0, len
);
1190 SCM_VALIDATE_CHAR (0, chr
);
1191 res
= scm_i_string_start_writing (res
);
1192 for (p
= 0; p
< len
; p
++)
1193 scm_i_string_set_x (res
, p
, SCM_CHAR (chr
));
1194 scm_i_string_stop_writing ();
1201 SCM_DEFINE (scm_string_length
, "string-length", 1, 0, 0,
1203 "Return the number of characters in @var{string}.")
1204 #define FUNC_NAME s_scm_string_length
1206 SCM_VALIDATE_STRING (1, string
);
1207 return scm_from_size_t (STRING_LENGTH (string
));
1211 SCM_DEFINE (scm_string_bytes_per_char
, "string-bytes-per-char", 1, 0, 0,
1213 "Return the bytes used to represent a character in @var{string}."
1214 "This will return 1 or 4.")
1215 #define FUNC_NAME s_scm_string_bytes_per_char
1217 SCM_VALIDATE_STRING (1, string
);
1218 if (!scm_i_is_narrow_string (string
))
1219 return scm_from_int (4);
1221 return scm_from_int (1);
1226 scm_c_string_length (SCM string
)
1228 if (!IS_STRING (string
))
1229 scm_wrong_type_arg_msg (NULL
, 0, string
, "string");
1230 return STRING_LENGTH (string
);
1233 SCM_DEFINE (scm_string_ref
, "string-ref", 2, 0, 0,
1235 "Return character @var{k} of @var{str} using zero-origin\n"
1236 "indexing. @var{k} must be a valid index of @var{str}.")
1237 #define FUNC_NAME s_scm_string_ref
1242 SCM_VALIDATE_STRING (1, str
);
1244 len
= scm_i_string_length (str
);
1245 if (SCM_LIKELY (len
> 0))
1246 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1248 scm_out_of_range (NULL
, k
);
1250 if (scm_i_is_narrow_string (str
))
1251 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[idx
]);
1253 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[idx
]);
1258 scm_c_string_ref (SCM str
, size_t p
)
1260 if (p
>= scm_i_string_length (str
))
1261 scm_out_of_range (NULL
, scm_from_size_t (p
));
1262 if (scm_i_is_narrow_string (str
))
1263 return SCM_MAKE_CHAR (scm_i_string_chars (str
)[p
]);
1265 return SCM_MAKE_CHAR (scm_i_string_wide_chars (str
)[p
]);
1269 SCM_DEFINE (scm_string_set_x
, "string-set!", 3, 0, 0,
1270 (SCM str
, SCM k
, SCM chr
),
1271 "Store @var{chr} in element @var{k} of @var{str} and return\n"
1272 "an unspecified value. @var{k} must be a valid index of\n"
1274 #define FUNC_NAME s_scm_string_set_x
1279 SCM_VALIDATE_STRING (1, str
);
1281 len
= scm_i_string_length (str
);
1282 if (SCM_LIKELY (len
> 0))
1283 idx
= scm_to_unsigned_integer (k
, 0, len
- 1);
1285 scm_out_of_range (NULL
, k
);
1287 SCM_VALIDATE_CHAR (3, chr
);
1288 str
= scm_i_string_start_writing (str
);
1289 scm_i_string_set_x (str
, idx
, SCM_CHAR (chr
));
1290 scm_i_string_stop_writing ();
1292 return SCM_UNSPECIFIED
;
1297 scm_c_string_set_x (SCM str
, size_t p
, SCM chr
)
1299 if (p
>= scm_i_string_length (str
))
1300 scm_out_of_range (NULL
, scm_from_size_t (p
));
1301 str
= scm_i_string_start_writing (str
);
1302 scm_i_string_set_x (str
, p
, SCM_CHAR (chr
));
1303 scm_i_string_stop_writing ();
1306 SCM_DEFINE (scm_substring
, "substring", 2, 1, 0,
1307 (SCM str
, SCM start
, SCM end
),
1308 "Return a newly allocated string formed from the characters\n"
1309 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1310 "ending with index @var{end} (exclusive).\n"
1311 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1312 "exact integers satisfying:\n\n"
1313 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1314 #define FUNC_NAME s_scm_substring
1316 size_t len
, from
, to
;
1318 SCM_VALIDATE_STRING (1, str
);
1319 len
= scm_i_string_length (str
);
1320 from
= scm_to_unsigned_integer (start
, 0, len
);
1321 if (SCM_UNBNDP (end
))
1324 to
= scm_to_unsigned_integer (end
, from
, len
);
1325 return scm_i_substring (str
, from
, to
);
1329 SCM_DEFINE (scm_substring_read_only
, "substring/read-only", 2, 1, 0,
1330 (SCM str
, SCM start
, SCM end
),
1331 "Return a newly allocated string formed from the characters\n"
1332 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1333 "ending with index @var{end} (exclusive).\n"
1334 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1335 "exact integers satisfying:\n"
1337 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
1339 "The returned string is read-only.\n")
1340 #define FUNC_NAME s_scm_substring_read_only
1342 size_t len
, from
, to
;
1344 SCM_VALIDATE_STRING (1, str
);
1345 len
= scm_i_string_length (str
);
1346 from
= scm_to_unsigned_integer (start
, 0, len
);
1347 if (SCM_UNBNDP (end
))
1350 to
= scm_to_unsigned_integer (end
, from
, len
);
1351 return scm_i_substring_read_only (str
, from
, to
);
1355 SCM_DEFINE (scm_substring_copy
, "substring/copy", 2, 1, 0,
1356 (SCM str
, SCM start
, SCM end
),
1357 "Return a newly allocated string formed from the characters\n"
1358 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1359 "ending with index @var{end} (exclusive).\n"
1360 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1361 "exact integers satisfying:\n\n"
1362 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1363 #define FUNC_NAME s_scm_substring_copy
1365 /* For the Scheme version, START is mandatory, but for the C
1366 version, it is optional. See scm_string_copy in srfi-13.c for a
1372 SCM_VALIDATE_STRING (1, str
);
1373 scm_i_get_substring_spec (scm_i_string_length (str
),
1374 start
, &from
, end
, &to
);
1375 return scm_i_substring_copy (str
, from
, to
);
1379 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
1380 (SCM str
, SCM start
, SCM end
),
1381 "Return string that indirectly refers to the characters\n"
1382 "of @var{str} beginning with index @var{start} (inclusive) and\n"
1383 "ending with index @var{end} (exclusive).\n"
1384 "@var{str} must be a string, @var{start} and @var{end} must be\n"
1385 "exact integers satisfying:\n\n"
1386 "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
1387 #define FUNC_NAME s_scm_substring_shared
1389 size_t len
, from
, to
;
1391 SCM_VALIDATE_STRING (1, str
);
1392 len
= scm_i_string_length (str
);
1393 from
= scm_to_unsigned_integer (start
, 0, len
);
1394 if (SCM_UNBNDP (end
))
1397 to
= scm_to_unsigned_integer (end
, from
, len
);
1398 return scm_i_substring_shared (str
, from
, to
);
1402 SCM_DEFINE (scm_string_append
, "string-append", 0, 0, 1,
1404 "Return a newly allocated string whose characters form the\n"
1405 "concatenation of the given strings, @var{args}.")
1406 #define FUNC_NAME s_scm_string_append
1420 SCM_VALIDATE_REST_ARGUMENT (args
);
1421 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1424 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1425 len
= scm_i_string_length (s
);
1426 if (((size_t) -1) - total
< len
)
1427 scm_num_overflow (s_scm_string_append
);
1429 if (!scm_i_is_narrow_string (s
))
1434 res
= scm_i_make_string (total
, &data
.narrow
, 0);
1436 res
= scm_i_make_wide_string (total
, &data
.wide
, 0);
1438 for (l
= args
; !scm_is_null (l
); l
= SCM_CDR (l
))
1442 SCM_VALIDATE_STRING (SCM_ARGn
, s
);
1443 len
= scm_i_string_length (s
);
1445 SCM_MISC_ERROR ("list changed during string-append", SCM_EOL
);
1448 memcpy (data
.narrow
, scm_i_string_chars (s
), len
);
1453 if (scm_i_is_narrow_string (s
))
1455 const char *src
= scm_i_string_chars (s
);
1456 for (i
= 0; i
< len
; i
++)
1457 data
.wide
[i
] = (unsigned char) src
[i
];
1460 u32_cpy ((scm_t_uint32
*) data
.wide
,
1461 (scm_t_uint32
*) scm_i_string_wide_chars (s
), len
);
1465 scm_remember_upto_here_1 (s
);
1468 SCM_MISC_ERROR ("list changed during string-append", SCM_EOL
);
1475 /* Charset conversion error handling. */
1477 SCM_SYMBOL (scm_encoding_error_key
, "encoding-error");
1478 SCM_SYMBOL (scm_decoding_error_key
, "decoding-error");
1480 /* Raise an exception informing that character CHR could not be written
1481 to PORT in its current encoding. */
1483 scm_encoding_error (const char *subr
, int err
, const char *message
,
1486 scm_throw (scm_encoding_error_key
,
1487 scm_list_n (scm_from_latin1_string (subr
),
1488 scm_from_latin1_string (message
),
1494 /* Raise an exception informing of an encoding error on PORT. This
1495 means that a character could not be written in PORT's encoding. */
1497 scm_decoding_error (const char *subr
, int err
, const char *message
, SCM port
)
1499 scm_throw (scm_decoding_error_key
,
1500 scm_list_n (scm_from_latin1_string (subr
),
1501 scm_from_latin1_string (message
),
1508 /* String conversion to/from C. */
1511 scm_from_stringn (const char *str
, size_t len
, const char *encoding
,
1512 scm_t_string_failed_conversion_handler handler
)
1519 /* The order of these checks is important. */
1520 if (!str
&& len
!= 0)
1521 scm_misc_error ("scm_from_stringn", "NULL string pointer", SCM_EOL
);
1522 if (len
== (size_t) -1)
1525 if (encoding
== NULL
|| len
== 0)
1527 /* If encoding is null (or the string is empty), use Latin-1. */
1529 res
= scm_i_make_string (len
, &buf
, 0);
1530 memcpy (buf
, str
, len
);
1535 u32
= (scm_t_wchar
*) u32_conv_from_encoding (encoding
,
1536 (enum iconv_ilseq_handler
)
1542 if (SCM_UNLIKELY (u32
== NULL
))
1544 /* Raise an error and pass the raw C string as a bytevector to the `throw'
1549 buf
= scm_gc_malloc_pointerless (len
, "bytevector");
1550 memcpy (buf
, str
, len
);
1551 bv
= scm_c_take_gc_bytevector (buf
, len
);
1553 scm_decoding_error (__func__
, errno
,
1554 "input locale conversion error", bv
);
1559 if (u32
[i
++] > 0xFF)
1568 res
= scm_i_make_string (u32len
, &dst
, 0);
1569 for (i
= 0; i
< u32len
; i
++)
1570 dst
[i
] = (unsigned char) u32
[i
];
1576 res
= scm_i_make_wide_string (u32len
, &wdst
, 0);
1577 u32_cpy ((scm_t_uint32
*) wdst
, (scm_t_uint32
*) u32
, u32len
);
1586 scm_from_locale_string (const char *str
)
1588 return scm_from_locale_stringn (str
, -1);
1592 scm_from_locale_stringn (const char *str
, size_t len
)
1594 return scm_from_stringn (str
, len
, locale_charset (),
1595 scm_i_default_port_conversion_handler ());
1599 scm_from_latin1_string (const char *str
)
1601 return scm_from_latin1_stringn (str
, -1);
1605 scm_from_latin1_stringn (const char *str
, size_t len
)
1610 if (len
== (size_t) -1)
1613 /* Make a narrow string and copy STR as is. */
1614 result
= scm_i_make_string (len
, &buf
, 0);
1615 memcpy (buf
, str
, len
);
1621 scm_from_utf8_string (const char *str
)
1623 return scm_from_utf8_stringn (str
, -1);
1627 scm_from_utf8_stringn (const char *str
, size_t len
)
1629 return scm_from_stringn (str
, len
, "UTF-8", SCM_FAILED_CONVERSION_ERROR
);
1633 scm_from_utf32_string (const scm_t_wchar
*str
)
1635 return scm_from_utf32_stringn (str
, -1);
1639 scm_from_utf32_stringn (const scm_t_wchar
*str
, size_t len
)
1644 if (len
== (size_t) -1)
1645 len
= u32_strlen ((uint32_t *) str
);
1647 result
= scm_i_make_wide_string (len
, &buf
, 0);
1648 memcpy (buf
, str
, len
* sizeof (scm_t_wchar
));
1649 scm_i_try_narrow_string (result
);
1654 /* Create a new scheme string from the C string STR. The memory of
1655 STR may be used directly as storage for the new string. */
1656 /* FIXME: GC-wise, the only way to use the memory area pointed to by STR
1657 would be to register a finalizer to eventually free(3) STR, which isn't
1658 worth it. Should we just deprecate the `scm_take_' functions? */
1660 scm_take_locale_stringn (char *str
, size_t len
)
1664 res
= scm_from_locale_stringn (str
, len
);
1671 scm_take_locale_string (char *str
)
1673 return scm_take_locale_stringn (str
, -1);
1676 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1677 *LENP-byte locale-encoded string, to `\xXX', `\uXXXX', or `\UXXXXXX'.
1678 Set *LENP to the size of the resulting string.
1680 FIXME: This is a hack we should get rid of. See
1681 <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00004.html>
1684 unistring_escapes_to_guile_escapes (char *buf
, size_t *lenp
)
1686 char *before
, *after
;
1695 if ((i
<= *lenp
- 6)
1696 && before
[i
] == '\\'
1697 && before
[i
+ 1] == 'u'
1698 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1700 /* Convert \u00NN to \xNN */
1703 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1704 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1708 else if ((i
<= *lenp
- 10)
1709 && before
[i
] == '\\'
1710 && before
[i
+ 1] == 'U'
1711 && before
[i
+ 2] == '0' && before
[i
+ 3] == '0')
1713 /* Convert \U00NNNNNN to \UNNNNNN */
1716 after
[j
+ 2] = tolower ((int) before
[i
+ 4]);
1717 after
[j
+ 3] = tolower ((int) before
[i
+ 5]);
1718 after
[j
+ 4] = tolower ((int) before
[i
+ 6]);
1719 after
[j
+ 5] = tolower ((int) before
[i
+ 7]);
1720 after
[j
+ 6] = tolower ((int) before
[i
+ 8]);
1721 after
[j
+ 7] = tolower ((int) before
[i
+ 9]);
1727 after
[j
] = before
[i
];
1735 /* Change libunistring escapes (`\uXXXX' and `\UXXXXXXXX') in BUF, a
1736 *LENP-byte locale-encoded string, to `\xXXXX;'. Set *LEN to the size
1737 of the resulting string. BUF must be large enough to handle the
1738 worst case when `\uXXXX' escapes (6 characters) are replaced by
1739 `\xXXXX;' (7 characters). */
1741 unistring_escapes_to_r6rs_escapes (char *buf
, size_t *lenp
)
1743 char *before
, *after
;
1745 /* The worst case is if the input string contains all 4-digit hex escapes.
1746 "\uXXXX" (six characters) becomes "\xXXXX;" (seven characters) */
1747 size_t max_out_len
= (*lenp
* 7) / 6 + 1;
1748 size_t nzeros
, ndigits
;
1751 after
= alloca (max_out_len
);
1756 if (((i
<= *lenp
- 6) && before
[i
] == '\\' && before
[i
+ 1] == 'u')
1757 || ((i
<= *lenp
- 10) && before
[i
] == '\\' && before
[i
+ 1] == 'U'))
1759 if (before
[i
+ 1] == 'u')
1761 else if (before
[i
+ 1] == 'U')
1766 /* Add the R6RS hex escape initial sequence. */
1770 /* Move string positions to the start of the hex numbers. */
1774 /* Find the number of initial zeros in this hex number. */
1776 while (before
[i
+ nzeros
] == '0' && nzeros
< ndigits
)
1779 /* Copy the number, skipping initial zeros, and then move the string
1781 if (nzeros
== ndigits
)
1790 for (pos
= 0; pos
< ndigits
- nzeros
; pos
++)
1791 after
[j
+ pos
] = tolower ((int) before
[i
+ nzeros
+ pos
]);
1793 j
+= (ndigits
- nzeros
);
1796 /* Add terminating semicolon. */
1802 after
[j
] = before
[i
];
1808 memcpy (before
, after
, j
);
1812 scm_to_locale_string (SCM str
)
1814 return scm_to_locale_stringn (str
, NULL
);
1818 scm_to_locale_stringn (SCM str
, size_t *lenp
)
1820 return scm_to_stringn (str
, lenp
,
1822 scm_i_default_port_conversion_handler ());
1826 scm_to_latin1_string (SCM str
)
1828 return scm_to_latin1_stringn (str
, NULL
);
1832 scm_to_latin1_stringn (SCM str
, size_t *lenp
)
1833 #define FUNC_NAME "scm_to_latin1_stringn"
1837 SCM_VALIDATE_STRING (1, str
);
1839 if (scm_i_is_narrow_string (str
))
1841 size_t len
= scm_i_string_length (str
);
1846 result
= scm_strndup (scm_i_string_data (str
), len
);
1849 result
= scm_to_stringn (str
, lenp
, NULL
,
1850 SCM_FAILED_CONVERSION_ERROR
);
1857 scm_to_utf8_string (SCM str
)
1859 return scm_to_utf8_stringn (str
, NULL
);
1863 latin1_u8_strlen (const scm_t_uint8
*str
, size_t len
)
1866 for (i
= 0, ret
= 0; i
< len
; i
++)
1867 ret
+= (str
[i
] < 128) ? 1 : 2;
1872 latin1_to_u8 (const scm_t_uint8
*str
, size_t latin_len
,
1873 scm_t_uint8
*u8_result
, size_t *u8_lenp
)
1876 size_t u8_len
= latin1_u8_strlen (str
, latin_len
);
1878 if (!(u8_result
&& u8_lenp
&& *u8_lenp
> u8_len
))
1879 u8_result
= scm_malloc (u8_len
+ 1);
1883 for (i
= 0, n
= 0; i
< latin_len
; i
++)
1884 n
+= u8_uctomb (u8_result
+ n
, str
[i
], u8_len
- n
);
1894 (Note that this includes code points that are not allowed by Unicode,
1895 but since this function has no way to report an error, and its
1896 purpose is to determine the size of destination buffers for
1897 libunicode conversion functions, we err on the safe side and handle
1898 everything that libunicode might conceivably handle, now or in the
1901 Char. number range | UTF-8 octet sequence
1902 (hexadecimal) | (binary)
1903 --------------------+------------------------------------------------------
1904 0000 0000-0000 007F | 0xxxxxxx
1905 0000 0080-0000 07FF | 110xxxxx 10xxxxxx
1906 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
1907 0001 0000-001F FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
1908 0020 0000-03FF FFFF | 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1909 0400 0000-7FFF FFFF | 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
1913 u32_u8_length_in_bytes (const scm_t_uint32
*str
, size_t len
)
1917 for (i
= 0, ret
= 0; i
< len
; i
++)
1919 scm_t_uint32 c
= str
[i
];
1923 else if (c
<= 0x7ff)
1925 else if (c
<= 0xffff)
1927 else if (c
<= 0x1fffff)
1929 else if (c
<= 0x3ffffff)
1939 scm_to_utf8_stringn (SCM str
, size_t *lenp
)
1940 #define FUNC_NAME "scm_to_utf8_stringn"
1942 SCM_VALIDATE_STRING (1, str
);
1944 if (scm_i_is_narrow_string (str
))
1945 return (char *) latin1_to_u8 ((scm_t_uint8
*) scm_i_string_chars (str
),
1946 scm_i_string_length (str
),
1950 scm_t_uint32
*chars
= (scm_t_uint32
*) scm_i_string_wide_chars (str
);
1951 scm_t_uint8
*buf
, *ret
;
1952 size_t num_chars
= scm_i_string_length (str
);
1953 size_t num_bytes_predicted
, num_bytes_actual
;
1955 num_bytes_predicted
= u32_u8_length_in_bytes (chars
, num_chars
);
1959 *lenp
= num_bytes_predicted
;
1960 buf
= scm_malloc (num_bytes_predicted
);
1964 buf
= scm_malloc (num_bytes_predicted
+ 1);
1965 buf
[num_bytes_predicted
] = 0;
1968 num_bytes_actual
= num_bytes_predicted
;
1969 ret
= u32_to_u8 (chars
, num_chars
, buf
, &num_bytes_actual
);
1971 if (SCM_LIKELY (ret
== buf
&& num_bytes_actual
== num_bytes_predicted
))
1972 return (char *) ret
;
1974 /* An error: a bad codepoint. */
1976 int saved_errno
= errno
;
1982 scm_decoding_error ("scm_to_utf8_stringn", errno
,
1983 "invalid codepoint in string", str
);
1993 scm_to_utf32_string (SCM str
)
1995 return scm_to_utf32_stringn (str
, NULL
);
1999 scm_to_utf32_stringn (SCM str
, size_t *lenp
)
2000 #define FUNC_NAME "scm_to_utf32_stringn"
2002 scm_t_wchar
*result
;
2004 SCM_VALIDATE_STRING (1, str
);
2006 if (scm_i_is_narrow_string (str
))
2008 scm_t_uint8
*codepoints
;
2011 codepoints
= (scm_t_uint8
*) scm_i_string_chars (str
);
2012 len
= scm_i_string_length (str
);
2016 result
= scm_malloc ((len
+ 1) * sizeof (scm_t_wchar
));
2017 for (i
= 0; i
< len
; i
++)
2018 result
[i
] = codepoints
[i
];
2025 len
= scm_i_string_length (str
);
2029 result
= scm_malloc ((len
+ 1) * sizeof (scm_t_wchar
));
2030 memcpy (result
, scm_i_string_wide_chars (str
),
2031 len
* sizeof (scm_t_wchar
));
2039 /* Return a malloc(3)-allocated buffer containing the contents of STR encoded
2040 according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
2041 the returned buffer. If the conversion to ENCODING fails, apply the strategy
2042 defined by HANDLER. */
2044 scm_to_stringn (SCM str
, size_t *lenp
, const char *encoding
,
2045 scm_t_string_failed_conversion_handler handler
)
2048 size_t ilen
, len
, i
;
2052 if (!scm_is_string (str
))
2053 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
2054 ilen
= scm_i_string_length (str
);
2058 buf
= scm_malloc (1);
2066 for (i
= 0; i
< ilen
; i
++)
2067 if (scm_i_string_ref (str
, i
) == '\0')
2068 scm_misc_error (NULL
,
2069 "string contains #\\nul character: ~S",
2072 if (scm_i_is_narrow_string (str
) && (encoding
== NULL
))
2074 /* If using native Latin-1 encoding, just copy the string
2078 buf
= scm_malloc (ilen
);
2079 memcpy (buf
, scm_i_string_chars (str
), ilen
);
2085 buf
= scm_malloc (ilen
+ 1);
2086 memcpy (buf
, scm_i_string_chars (str
), ilen
);
2098 if (scm_i_is_narrow_string (str
))
2100 ret
= mem_iconveh (scm_i_string_chars (str
), ilen
,
2102 (enum iconv_ilseq_handler
) handler
, NULL
,
2106 scm_encoding_error (__func__
, errno
,
2107 "cannot convert narrow string to output locale",
2109 /* FIXME: Faulty character unknown. */
2114 buf
= u32_conv_to_encoding (enc
,
2115 (enum iconv_ilseq_handler
) handler
,
2116 (scm_t_uint32
*) scm_i_string_wide_chars (str
),
2121 scm_encoding_error (__func__
, errno
,
2122 "cannot convert wide string to output locale",
2124 /* FIXME: Faulty character unknown. */
2127 if (handler
== SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
)
2129 if (SCM_R6RS_ESCAPES_P
)
2131 /* The worst case is if the input string contains all 4-digit
2132 hex escapes. "\uXXXX" (six characters) becomes "\xXXXX;"
2133 (seven characters). Make BUF large enough to hold
2135 buf
= scm_realloc (buf
, (len
* 7) / 6 + 1);
2136 unistring_escapes_to_r6rs_escapes (buf
, &len
);
2139 unistring_escapes_to_guile_escapes (buf
, &len
);
2141 buf
= scm_realloc (buf
, len
);
2147 buf
= scm_realloc (buf
, len
+ 1);
2151 scm_remember_upto_here_1 (str
);
2156 scm_to_locale_stringbuf (SCM str
, char *buf
, size_t max_len
)
2159 char *result
= NULL
;
2160 if (!scm_is_string (str
))
2161 scm_wrong_type_arg_msg (NULL
, 0, str
, "string");
2162 result
= scm_to_locale_stringn (str
, &len
);
2164 memcpy (buf
, result
, (len
> max_len
) ? max_len
: len
);
2167 scm_remember_upto_here_1 (str
);
2172 /* Unicode string normalization. */
2174 /* This function is a partial clone of SCM_STRING_TO_U32_BUF from
2175 libguile/i18n.c. It would be useful to have this factored out into a more
2176 convenient location, but its use of alloca makes that tricky to do. */
2179 normalize_str (SCM string
, uninorm_t form
)
2182 scm_t_uint32
*w_str
;
2184 size_t rlen
, len
= scm_i_string_length (string
);
2186 if (scm_i_is_narrow_string (string
))
2189 const char *buf
= scm_i_string_chars (string
);
2191 w_str
= alloca (sizeof (scm_t_wchar
) * (len
+ 1));
2193 for (i
= 0; i
< len
; i
++)
2194 w_str
[i
] = (unsigned char) buf
[i
];
2198 w_str
= (scm_t_uint32
*) scm_i_string_wide_chars (string
);
2200 w_str
= u32_normalize (form
, w_str
, len
, NULL
, &rlen
);
2202 ret
= scm_i_make_wide_string (rlen
, &cbuf
, 0);
2203 u32_cpy ((scm_t_uint32
*) cbuf
, w_str
, rlen
);
2206 scm_i_try_narrow_string (ret
);
2211 SCM_DEFINE (scm_string_normalize_nfc
, "string-normalize-nfc", 1, 0, 0,
2213 "Returns the NFC normalized form of @var{string}.")
2214 #define FUNC_NAME s_scm_string_normalize_nfc
2216 SCM_VALIDATE_STRING (1, string
);
2217 return normalize_str (string
, UNINORM_NFC
);
2221 SCM_DEFINE (scm_string_normalize_nfd
, "string-normalize-nfd", 1, 0, 0,
2223 "Returns the NFD normalized form of @var{string}.")
2224 #define FUNC_NAME s_scm_string_normalize_nfd
2226 SCM_VALIDATE_STRING (1, string
);
2227 return normalize_str (string
, UNINORM_NFD
);
2231 SCM_DEFINE (scm_string_normalize_nfkc
, "string-normalize-nfkc", 1, 0, 0,
2233 "Returns the NFKC normalized form of @var{string}.")
2234 #define FUNC_NAME s_scm_string_normalize_nfkc
2236 SCM_VALIDATE_STRING (1, string
);
2237 return normalize_str (string
, UNINORM_NFKC
);
2241 SCM_DEFINE (scm_string_normalize_nfkd
, "string-normalize-nfkd", 1, 0, 0,
2243 "Returns the NFKD normalized form of @var{string}.")
2244 #define FUNC_NAME s_scm_string_normalize_nfkd
2246 SCM_VALIDATE_STRING (1, string
);
2247 return normalize_str (string
, UNINORM_NFKD
);
2251 /* converts C scm_array of strings to SCM scm_list of strings.
2252 If argc < 0, a null terminated scm_array is assumed.
2253 The current locale encoding is assumed */
2255 scm_makfromstrs (int argc
, char **argv
)
2260 for (i
= 0; argv
[i
]; i
++);
2262 lst
= scm_cons (scm_from_locale_string (argv
[i
]), lst
);
2266 /* Return a newly allocated array of char pointers to each of the strings
2267 in args, with a terminating NULL pointer. The strings are encoded using
2268 the current locale. */
2271 scm_i_allocate_string_pointers (SCM list
)
2272 #define FUNC_NAME "scm_i_allocate_string_pointers"
2275 int list_len
= scm_ilength (list
);
2279 scm_wrong_type_arg_msg (NULL
, 0, list
, "proper list");
2281 result
= scm_gc_malloc ((list_len
+ 1) * sizeof (char *),
2283 result
[list_len
] = NULL
;
2285 /* The list might have been modified in another thread, so
2286 we check LIST before each access.
2288 for (i
= 0; i
< list_len
&& scm_is_pair (list
); i
++)
2290 SCM str
= SCM_CAR (list
);
2291 size_t len
; /* String length in bytes */
2292 char *c_str
= scm_to_locale_stringn (str
, &len
);
2294 /* OPTIMIZE-ME: Right now, scm_to_locale_stringn always uses
2295 scm_malloc to allocate the returned string, which must be
2296 explicitly deallocated. This forces us to copy the string a
2297 second time into a new buffer. Ideally there would be variants
2298 of scm_to_*_stringn that can return garbage-collected buffers. */
2300 result
[i
] = scm_gc_malloc_pointerless (len
+ 1, "string");
2301 memcpy (result
[i
], c_str
, len
);
2302 result
[i
][len
] = '\0';
2305 list
= SCM_CDR (list
);
2313 scm_i_get_substring_spec (size_t len
,
2314 SCM start
, size_t *cstart
,
2315 SCM end
, size_t *cend
)
2317 if (SCM_UNBNDP (start
))
2320 *cstart
= scm_to_unsigned_integer (start
, 0, len
);
2322 if (SCM_UNBNDP (end
))
2325 *cend
= scm_to_unsigned_integer (end
, *cstart
, len
);
2328 #if SCM_ENABLE_DEPRECATED
2330 /* When these definitions are removed, it becomes reasonable to use
2331 read-only strings for string literals. For that, change the reader
2332 to create string literals with scm_c_substring_read_only instead of
2333 with scm_c_substring_copy.
2337 scm_i_deprecated_stringp (SCM str
)
2339 scm_c_issue_deprecation_warning
2340 ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
2342 return scm_is_string (str
);
2346 scm_i_deprecated_string_chars (SCM str
)
2350 scm_c_issue_deprecation_warning
2351 ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
2353 /* We don't accept shared substrings here since they are not
2356 if (IS_SH_STRING (str
))
2357 scm_misc_error (NULL
,
2358 "SCM_STRING_CHARS does not work with shared substrings",
2361 /* We explicitly test for read-only strings to produce a better
2365 if (IS_RO_STRING (str
))
2366 scm_misc_error (NULL
,
2367 "SCM_STRING_CHARS does not work with read-only strings",
2370 /* The following is still wrong, of course...
2372 str
= scm_i_string_start_writing (str
);
2373 chars
= scm_i_string_writable_chars (str
);
2374 scm_i_string_stop_writing ();
2379 scm_i_deprecated_string_length (SCM str
)
2381 scm_c_issue_deprecation_warning
2382 ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
2383 return scm_c_string_length (str
);
2389 string_handle_ref (scm_t_array_handle
*h
, size_t index
)
2391 return scm_c_string_ref (h
->array
, index
);
2395 string_handle_set (scm_t_array_handle
*h
, size_t index
, SCM val
)
2397 scm_c_string_set_x (h
->array
, index
, val
);
2401 string_get_handle (SCM v
, scm_t_array_handle
*h
)
2407 h
->dim0
.ubnd
= scm_c_string_length (v
) - 1;
2409 h
->element_type
= SCM_ARRAY_ELEMENT_TYPE_CHAR
;
2410 h
->elements
= h
->writable_elements
= NULL
;
2413 SCM_ARRAY_IMPLEMENTATION (scm_tc7_string
, 0x7f,
2414 string_handle_ref
, string_handle_set
,
2416 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR
, scm_make_string
)
2421 scm_nullstr
= scm_i_make_string (0, NULL
, 0);
2423 #include "libguile/strings.x"