1 /*===========================================================================
2 * Filename : string-procedure.c
3 * About : Non-core procedures of R5RS strings
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include <string.h>
41 #include <stdlib.h>
42 #if (HAVE_STRCASECMP && HAVE_STRINGS_H)
43 #include <strings.h>
44 #endif
45
46 #include "sigscheme.h"
47 #include "sigschemeinternal.h"
48
49 /*=======================================
50 File Local Macro Definitions
51 =======================================*/
52 #define STRING_CMP(str1, str2) \
53 (string_cmp(SCM_MANGLE(name), (str1), (str2), scm_false))
54 #define STRING_CI_CMP(str1, str2) \
55 (string_cmp(SCM_MANGLE(name), (str1), (str2), scm_true))
56
57 /*=======================================
58 File Local Type Definitions
59 =======================================*/
60
61 /*=======================================
62 Variable Definitions
63 =======================================*/
64
65 /*=======================================
66 File Local Function Declarations
67 =======================================*/
68 static int string_cmp(const char *funcname,
69 ScmObj str1, ScmObj str2, scm_bool case_insensitive);
70
71 /*=======================================
72 Function Definitions
73 =======================================*/
74 /*===========================================================================
75 R5RS : 6.3 Other data types : 6.3.5 Strings
76 ===========================================================================*/
77 SCM_EXPORT ScmObj
scm_p_make_string(ScmObj length,ScmObj args)78 scm_p_make_string(ScmObj length, ScmObj args)
79 {
80 ScmObj filler;
81 scm_ichar_t filler_val;
82 ssize_t len;
83 int ch_len;
84 char *str, *dst;
85 #if SCM_USE_MULTIBYTE_CHAR
86 const char *next;
87 char ch_buf[SCM_MB_CHAR_BUF_SIZE];
88 #endif
89 DECLARE_FUNCTION("make-string", procedure_variadic_1);
90
91 #if SCM_USE_MULTIBYTE_CHAR
92 ENSURE_STATELESS_CODEC(scm_current_char_codec);
93 #endif
94 ENSURE_INT(length);
95 len = SCM_INT_VALUE(length);
96 if (len == 0)
97 return MAKE_STRING_COPYING("", 0);
98 if (len < 0)
99 ERR_OBJ("length must be a non-negative integer", length);
100
101 /* extract filler */
102 if (NULLP(args)) {
103 /* To avoid assuming implicit filler value (such as space) by users,
104 * SigScheme fills '?' into the result string to indicate the filler
105 * value is undefined in R5RS.
106 *
107 * R5RS: If char is given, then all elements of the string are
108 * initialized to char, otherwise the contents of the string are
109 * unspecified. */
110 filler_val = '?';
111 ch_len = sizeof((char)'?');
112 } else {
113 filler = POP(args);
114 ASSERT_NO_MORE_ARG(args);
115 ENSURE_CHAR(filler);
116 filler_val = SCM_CHAR_VALUE(filler);
117 #if SCM_USE_MULTIBYTE_CHAR
118 ch_len = SCM_CHARCODEC_CHAR_LEN(scm_current_char_codec, filler_val);
119 #endif
120 }
121 #if !SCM_USE_NULL_CAPABLE_STRING
122 if (filler_val == '\0')
123 ERR(SCM_ERRMSG_NULL_IN_STRING);
124 #endif
125
126 #if SCM_USE_MULTIBYTE_CHAR
127 next = SCM_CHARCODEC_INT2STR(scm_current_char_codec, ch_buf, filler_val,
128 SCM_MB_STATELESS);
129 if (!next)
130 ERR("invalid char 0x~MX for encoding ~S",
131 (scm_int_t)filler_val,
132 SCM_CHARCODEC_ENCODING(scm_current_char_codec));
133
134 str = scm_malloc(ch_len * len + sizeof(""));
135 for (dst = str; dst < &str[ch_len * len]; dst += ch_len)
136 memcpy(dst, ch_buf, ch_len);
137 #else
138 SCM_ASSERT(ICHAR_SINGLEBYTEP(filler_val));
139 str = scm_malloc(len + sizeof(""));
140 for (dst = str; dst < &str[len];)
141 *dst++ = filler_val;
142 #endif
143 *dst = '\0';
144
145 return MAKE_STRING(str, len);
146 }
147
148 SCM_EXPORT ScmObj
scm_p_string(ScmObj args)149 scm_p_string(ScmObj args)
150 {
151 DECLARE_FUNCTION("string", procedure_variadic_0);
152
153 return scm_p_list2string(args);
154 }
155
156 SCM_EXPORT ScmObj
scm_p_string_ref(ScmObj str,ScmObj k)157 scm_p_string_ref(ScmObj str, ScmObj k)
158 {
159 scm_int_t idx;
160 scm_ichar_t ch;
161 #if SCM_USE_MULTIBYTE_CHAR
162 ScmMultibyteString mbs;
163 #endif
164 DECLARE_FUNCTION("string-ref", procedure_fixed_2);
165
166 ENSURE_STRING(str);
167 ENSURE_INT(k);
168
169 idx = SCM_INT_VALUE(k);
170 if (idx < 0 || SCM_STRING_LEN(str) <= idx)
171 ERR_OBJ("index out of range", k);
172
173 #if SCM_USE_MULTIBYTE_CHAR
174 SCM_MBS_INIT2(mbs, SCM_STRING_STR(str), strlen(SCM_STRING_STR(str)));
175 mbs = scm_mb_strref(scm_current_char_codec, mbs, idx);
176
177 ch = SCM_CHARCODEC_STR2INT(scm_current_char_codec, SCM_MBS_GET_STR(mbs),
178 SCM_MBS_GET_SIZE(mbs), SCM_MBS_GET_STATE(mbs));
179 if (ch == SCM_ICHAR_EOF)
180 ERR("invalid char sequence");
181 #else
182 ch = ((unsigned char *)SCM_STRING_STR(str))[idx];
183 #endif
184
185 return MAKE_CHAR(ch);
186 }
187
188 SCM_EXPORT ScmObj
scm_p_string_setx(ScmObj str,ScmObj k,ScmObj ch)189 scm_p_string_setx(ScmObj str, ScmObj k, ScmObj ch)
190 {
191 scm_int_t idx;
192 scm_ichar_t ch_val;
193 char *c_str;
194 #if SCM_USE_MULTIBYTE_CHAR
195 int ch_len, orig_ch_len;
196 size_t prefix_len, suffix_len, new_str_len;
197 const char *suffix_src, *ch_end;
198 char *new_str, *suffix_dst;
199 char ch_buf[SCM_MB_CHAR_BUF_SIZE];
200 ScmMultibyteString mbs_ch;
201 #endif
202 DECLARE_FUNCTION("string-set!", procedure_fixed_3);
203
204 #if SCM_USE_MULTIBYTE_CHAR
205 ENSURE_STATELESS_CODEC(scm_current_char_codec);
206 #endif
207 ENSURE_STRING(str);
208 ENSURE_MUTABLE_STRING(str);
209 ENSURE_INT(k);
210 ENSURE_CHAR(ch);
211
212 idx = SCM_INT_VALUE(k);
213 c_str = SCM_STRING_STR(str);
214 if (idx < 0 || SCM_STRING_LEN(str) <= idx)
215 ERR_OBJ("index out of range", k);
216
217 #if SCM_USE_MULTIBYTE_CHAR
218 /* point at the char that to be replaced */
219 SCM_MBS_INIT2(mbs_ch, c_str, strlen(c_str));
220 mbs_ch = scm_mb_strref(scm_current_char_codec, mbs_ch, idx);
221 orig_ch_len = SCM_MBS_GET_SIZE(mbs_ch);
222 prefix_len = SCM_MBS_GET_STR(mbs_ch) - c_str;
223
224 /* prepare new char */
225 ch_val = SCM_CHAR_VALUE(ch);
226 ch_end = SCM_CHARCODEC_INT2STR(scm_current_char_codec, ch_buf, ch_val,
227 SCM_MB_STATELESS);
228 if (!ch_end)
229 ERR("invalid char 0x~MX for encoding ~S",
230 (scm_int_t)ch_val, SCM_CHARCODEC_ENCODING(scm_current_char_codec));
231 ch_len = ch_end - ch_buf;
232
233 /* prepare the space for new char */
234 if (ch_len == orig_ch_len) {
235 new_str = c_str;
236 } else {
237 suffix_src = &SCM_MBS_GET_STR(mbs_ch)[orig_ch_len];
238 suffix_len = strlen(suffix_src);
239
240 new_str_len = prefix_len + ch_len + suffix_len;
241 if (ch_len > orig_ch_len) {
242 new_str = scm_realloc(c_str, new_str_len + sizeof(""));
243 } else {
244 new_str = c_str;
245 }
246 suffix_src = &new_str[prefix_len + orig_ch_len];
247 suffix_dst = &new_str[prefix_len + ch_len];
248 memmove(suffix_dst, suffix_src, suffix_len);
249 new_str[new_str_len] = '\0';
250 }
251
252 /* set new char */
253 memcpy(&new_str[prefix_len], ch_buf, ch_len);
254
255 SCM_STRING_SET_STR(str, new_str);
256 #else
257 ch_val = SCM_CHAR_VALUE(ch);
258 SCM_ASSERT(ICHAR_SINGLEBYTEP(ch_val));
259 c_str[idx] = ch_val;
260 #endif
261
262 return SCM_UNDEF;
263 }
264
265 /* Upper case letters are less than lower. */
266 static int
string_cmp(const char * funcname,ScmObj str1,ScmObj str2,scm_bool case_insensitive)267 string_cmp(const char *funcname,
268 ScmObj str1, ScmObj str2, scm_bool case_insensitive)
269 {
270 const char *c_str1, *c_str2;
271 #if SCM_USE_MULTIBYTE_CHAR
272 scm_ichar_t c1, c2;
273 ScmMultibyteString mbs1, mbs2;
274 #endif
275 DECLARE_INTERNAL_FUNCTION("string_cmp");
276
277 /* dirty hack to replace internal function name */
278 SCM_MANGLE(name) = funcname;
279
280 ENSURE_STRING(str1);
281 ENSURE_STRING(str2);
282
283 c_str1 = SCM_STRING_STR(str1);
284 c_str2 = SCM_STRING_STR(str2);
285 #if SCM_USE_MULTIBYTE_CHAR
286 SCM_MBS_INIT2(mbs1, c_str1, strlen(c_str1));
287 SCM_MBS_INIT2(mbs2, c_str2, strlen(c_str2));
288 for (;;) {
289 if (SCM_MBS_GET_SIZE(mbs1) && !SCM_MBS_GET_SIZE(mbs2))
290 return 1;
291 if (!SCM_MBS_GET_SIZE(mbs1) && SCM_MBS_GET_SIZE(mbs2))
292 return -1;
293 if (!SCM_MBS_GET_SIZE(mbs1) && !SCM_MBS_GET_SIZE(mbs2))
294 return 0;
295
296 c1 = SCM_CHARCODEC_READ_CHAR(scm_current_char_codec, mbs1);
297 c2 = SCM_CHARCODEC_READ_CHAR(scm_current_char_codec, mbs2);
298 if (case_insensitive) {
299 c1 = ICHAR_FOLDCASE(c1);
300 c2 = ICHAR_FOLDCASE(c2);
301 }
302
303 if (c1 > c2)
304 return 1;
305 if (c1 < c2)
306 return -1;
307 }
308 #else /* SCM_USE_MULTIBYTE_CHAR */
309 if (case_insensitive) {
310 return strcasecmp(c_str1, c_str2);
311 } else {
312 return strcmp(c_str1, c_str2);
313 }
314 #endif /* SCM_USE_MULTIBYTE_CHAR */
315 }
316
317 SCM_EXPORT ScmObj
scm_p_string_ci_equalp(ScmObj str1,ScmObj str2)318 scm_p_string_ci_equalp(ScmObj str1, ScmObj str2)
319 {
320 DECLARE_FUNCTION("string-ci=?", procedure_fixed_2);
321
322 ENSURE_STRING(str1);
323 ENSURE_STRING(str2);
324
325 return MAKE_BOOL(EQ((str1), (str2))
326 || (SCM_STRING_LEN(str1) == SCM_STRING_LEN(str2)
327 && STRING_CI_CMP(str1, str2) == 0));
328 }
329
330 SCM_EXPORT ScmObj
scm_p_string_greaterp(ScmObj str1,ScmObj str2)331 scm_p_string_greaterp(ScmObj str1, ScmObj str2)
332 {
333 DECLARE_FUNCTION("string>?", procedure_fixed_2);
334
335 return MAKE_BOOL(STRING_CMP(str1, str2) > 0);
336 }
337
338 SCM_EXPORT ScmObj
scm_p_string_lessp(ScmObj str1,ScmObj str2)339 scm_p_string_lessp(ScmObj str1, ScmObj str2)
340 {
341 DECLARE_FUNCTION("string<?", procedure_fixed_2);
342
343 return MAKE_BOOL(STRING_CMP(str1, str2) < 0);
344 }
345
346 SCM_EXPORT ScmObj
scm_p_string_greater_equalp(ScmObj str1,ScmObj str2)347 scm_p_string_greater_equalp(ScmObj str1, ScmObj str2)
348 {
349 DECLARE_FUNCTION("string>=?", procedure_fixed_2);
350
351 return MAKE_BOOL(STRING_CMP(str1, str2) >= 0);
352 }
353
354 SCM_EXPORT ScmObj
scm_p_string_less_equalp(ScmObj str1,ScmObj str2)355 scm_p_string_less_equalp(ScmObj str1, ScmObj str2)
356 {
357 DECLARE_FUNCTION("string<=?", procedure_fixed_2);
358
359 return MAKE_BOOL(STRING_CMP(str1, str2) <= 0);
360 }
361
362 SCM_EXPORT ScmObj
scm_p_string_ci_greaterp(ScmObj str1,ScmObj str2)363 scm_p_string_ci_greaterp(ScmObj str1, ScmObj str2)
364 {
365 DECLARE_FUNCTION("string-ci>?", procedure_fixed_2);
366
367 return MAKE_BOOL(STRING_CI_CMP(str1, str2) > 0);
368 }
369
370 SCM_EXPORT ScmObj
scm_p_string_ci_lessp(ScmObj str1,ScmObj str2)371 scm_p_string_ci_lessp(ScmObj str1, ScmObj str2)
372 {
373 DECLARE_FUNCTION("string-ci<?", procedure_fixed_2);
374
375 return MAKE_BOOL(STRING_CI_CMP(str1, str2) < 0);
376 }
377
378 SCM_EXPORT ScmObj
scm_p_string_ci_greater_equalp(ScmObj str1,ScmObj str2)379 scm_p_string_ci_greater_equalp(ScmObj str1, ScmObj str2)
380 {
381 DECLARE_FUNCTION("string-ci>=?", procedure_fixed_2);
382
383 return MAKE_BOOL(STRING_CI_CMP(str1, str2) >= 0);
384 }
385
386 SCM_EXPORT ScmObj
scm_p_string_ci_less_equalp(ScmObj str1,ScmObj str2)387 scm_p_string_ci_less_equalp(ScmObj str1, ScmObj str2)
388 {
389 DECLARE_FUNCTION("string-ci<=?", procedure_fixed_2);
390
391 return MAKE_BOOL(STRING_CI_CMP(str1, str2) <= 0);
392 }
393
394 SCM_EXPORT ScmObj
scm_p_substring(ScmObj str,ScmObj start,ScmObj end)395 scm_p_substring(ScmObj str, ScmObj start, ScmObj end)
396 {
397 scm_int_t c_start, c_end, len, sub_len;
398 const char *c_str;
399 char *new_str;
400 #if SCM_USE_MULTIBYTE_CHAR
401 ScmMultibyteString mbs;
402 #endif
403 DECLARE_FUNCTION("substring", procedure_fixed_3);
404
405 ENSURE_STRING(str);
406 ENSURE_INT(start);
407 ENSURE_INT(end);
408
409 c_start = SCM_INT_VALUE(start);
410 c_end = SCM_INT_VALUE(end);
411 len = SCM_STRING_LEN(str);
412
413 if (c_start < 0 || len < c_start)
414 ERR_OBJ("start index out of range", start);
415 if (c_end < 0 || len < c_end)
416 ERR_OBJ("end index out of range", end);
417 if (c_start > c_end)
418 ERR_OBJ("start index exceeded end index", LIST_2(start, end));
419
420 c_str = SCM_STRING_STR(str);
421 sub_len = c_end - c_start;
422
423 #if SCM_USE_MULTIBYTE_CHAR
424 /* substring */
425 SCM_MBS_INIT2(mbs, c_str, strlen(c_str));
426 mbs = scm_mb_substring(scm_current_char_codec, mbs, c_start, sub_len);
427
428 /* copy the substring */
429 new_str = scm_malloc(SCM_MBS_GET_SIZE(mbs) + sizeof(""));
430 memcpy(new_str, SCM_MBS_GET_STR(mbs), SCM_MBS_GET_SIZE(mbs));
431 new_str[SCM_MBS_GET_SIZE(mbs)] = '\0';
432 #else
433 new_str = scm_malloc(sub_len + sizeof(""));
434 memcpy(new_str, &c_str[c_start], sub_len);
435 new_str[sub_len] = '\0';
436 #endif
437
438 #if SCM_USE_NULL_CAPABLE_STRING
439 /* FIXME: the result is truncated at null and incorrect */
440 return MAKE_STRING(new_str, STRLEN_UNKNOWN);
441 #else
442 return MAKE_STRING(new_str, sub_len);
443 #endif
444 }
445
446 SCM_EXPORT ScmObj
scm_p_string2list(ScmObj str)447 scm_p_string2list(ScmObj str)
448 {
449 #if SCM_USE_MULTIBYTE_CHAR
450 ScmMultibyteString mbs;
451 ScmQueue q;
452 #endif
453 ScmObj ret;
454 scm_ichar_t ch;
455 scm_int_t mb_len;
456 const char *c_str;
457 DECLARE_FUNCTION("string->list", procedure_fixed_1);
458
459 ENSURE_STRING(str);
460
461 c_str = SCM_STRING_STR(str);
462 mb_len = SCM_STRING_LEN(str);
463
464 ret = SCM_NULL;
465 #if SCM_USE_MULTIBYTE_CHAR
466 SCM_QUEUE_POINT_TO(q, ret);
467 SCM_MBS_INIT2(mbs, c_str, strlen(c_str));
468 while (mb_len--) {
469 if (SCM_MBS_GET_SIZE(mbs)) {
470 ch = SCM_CHARCODEC_READ_CHAR(scm_current_char_codec, mbs);
471 } else {
472 #if SCM_USE_NULL_CAPABLE_STRING
473 /* CAUTION: this code may crash when (scm_current_char_codec !=
474 * orig_codec) */
475 ch = '\0';
476 c_str = &SCM_MBS_GET_STR(mbs)[1];
477 SCM_MBS_INIT2(mbs, c_str, strlen(c_str));
478 #else
479 break;
480 #endif /* SCM_USE_NULL_CAPABLE_STRING */
481 }
482 SCM_QUEUE_ADD(q, MAKE_CHAR(ch));
483 }
484 #else /* SCM_USE_MULTIBYTE_CHAR */
485 while (mb_len) {
486 ch = ((unsigned char *)c_str)[--mb_len];
487 ret = CONS(MAKE_CHAR(ch), ret);
488 }
489 #endif /* SCM_USE_MULTIBYTE_CHAR */
490
491 return ret;
492 }
493
494 SCM_EXPORT ScmObj
scm_p_list2string(ScmObj lst)495 scm_p_list2string(ScmObj lst)
496 {
497 ScmObj rest, ch;
498 size_t str_size;
499 scm_int_t len;
500 char *str, *dst;
501 #if SCM_USE_MULTIBYTE_CHAR
502 scm_ichar_t ch_val;
503 #endif
504 DECLARE_FUNCTION("list->string", procedure_fixed_1);
505
506 #if SCM_USE_MULTIBYTE_CHAR
507 ENSURE_STATELESS_CODEC(scm_current_char_codec);
508 #endif
509 #if SCM_STRICT_ARGCHECK
510 len = scm_length(lst);
511 if (!SCM_LISTLEN_PROPERP(len))
512 ERR_OBJ("proper list required but got", lst);
513 #else
514 ENSURE_LIST(lst);
515 #endif
516
517 if (NULLP(lst))
518 return MAKE_STRING_COPYING("", 0);
519
520 str_size = sizeof("");
521 rest = lst;
522 len = 0;
523 FOR_EACH (ch, rest) {
524 ENSURE_CHAR(ch);
525 #if SCM_USE_MULTIBYTE_CHAR
526 ch_val = SCM_CHAR_VALUE(ch);
527 str_size += SCM_CHARCODEC_CHAR_LEN(scm_current_char_codec, ch_val);
528 #else
529 str_size++;
530 #endif
531 len++;
532 }
533 ENSURE_PROPER_LIST_TERMINATION(rest, lst);
534
535 dst = str = scm_malloc(str_size);
536 FOR_EACH (ch, lst) {
537 #if !SCM_USE_NULL_CAPABLE_STRING
538 if (ch == '\0')
539 ERR(SCM_ERRMSG_NULL_IN_STRING);
540 #endif
541 #if SCM_USE_MULTIBYTE_CHAR
542 dst = SCM_CHARCODEC_INT2STR(scm_current_char_codec, dst,
543 SCM_CHAR_VALUE(ch), SCM_MB_STATELESS);
544 #else
545 *dst++ = SCM_CHAR_VALUE(ch);
546 #endif
547 }
548 #if !SCM_USE_MULTIBYTE_CHAR
549 *dst = '\0';
550 #endif
551
552 return MAKE_STRING(str, len);
553 }
554
555 SCM_EXPORT ScmObj
scm_p_string_fillx(ScmObj str,ScmObj ch)556 scm_p_string_fillx(ScmObj str, ScmObj ch)
557 {
558 size_t str_len;
559 char *dst;
560 #if SCM_USE_MULTIBYTE_CHAR
561 int ch_len;
562 char *new_str;
563 char ch_buf[SCM_MB_CHAR_BUF_SIZE];
564 const char *next;
565 #else
566 scm_ichar_t ch_val;
567 char *c_str;
568 #endif
569 DECLARE_FUNCTION("string-fill!", procedure_fixed_2);
570
571 #if SCM_USE_MULTIBYTE_CHAR
572 ENSURE_STATELESS_CODEC(scm_current_char_codec);
573 #endif
574 ENSURE_STRING(str);
575 ENSURE_MUTABLE_STRING(str);
576 ENSURE_CHAR(ch);
577
578 str_len = SCM_STRING_LEN(str);
579 if (str_len == 0)
580 return MAKE_STRING_COPYING("", 0);
581
582 #if SCM_USE_MULTIBYTE_CHAR
583 next = SCM_CHARCODEC_INT2STR(scm_current_char_codec, ch_buf,
584 SCM_CHAR_VALUE(ch), SCM_MB_STATELESS);
585 if (!next)
586 ERR("invalid char 0x~MX for encoding ~S",
587 (scm_int_t)SCM_CHAR_VALUE(ch),
588 SCM_CHARCODEC_ENCODING(scm_current_char_codec));
589
590 /* create new str */
591 ch_len = next - ch_buf;
592 new_str = scm_realloc(SCM_STRING_STR(str), str_len * ch_len + sizeof(""));
593 for (dst = new_str; dst < &new_str[ch_len * str_len]; dst += ch_len)
594 memcpy(dst, ch_buf, ch_len);
595 *dst = '\0';
596
597 SCM_STRING_SET_STR(str, new_str);
598 #else
599 ch_val = SCM_CHAR_VALUE(ch);
600 SCM_ASSERT(ICHAR_SINGLEBYTEP(ch_val));
601 c_str = SCM_STRING_STR(str);
602 for (dst = c_str; dst < &c_str[str_len]; dst++)
603 *dst = ch_val;
604 #endif
605
606 return SCM_UNDEF;
607 }
608
609 /* This procedure should rightfully be written in module-sscm-ext.c, but since
610 * SigScheme's function table generator isn't supporting #if -surrounded
611 * procedure, it packed into this file. */
612 SCM_EXPORT ScmObj
scm_p_string_mutablep(ScmObj str)613 scm_p_string_mutablep(ScmObj str)
614 {
615 DECLARE_FUNCTION("%%string-mutable?", procedure_fixed_1);
616
617 ENSURE_STRING(str);
618
619 return MAKE_BOOL(SCM_STRING_MUTABLEP(str));
620 }
621
622 SCM_EXPORT ScmObj
scm_p_string_reconstructx(ScmObj str)623 scm_p_string_reconstructx(ScmObj str)
624 {
625 scm_int_t len;
626 DECLARE_FUNCTION("%%string-reconstruct!", procedure_fixed_1);
627
628 ENSURE_STRING(str);
629 ENSURE_MUTABLE_STRING(str);
630
631 /* recount string length in current char codec */
632 #if SCM_USE_MULTIBYTE_CHAR
633 len = scm_mb_bare_c_strlen(scm_current_char_codec, SCM_STRING_STR(str));
634 SCM_STRING_SET_LEN(str, len);
635 #endif
636
637 return str;
638 }
639