1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
32 #include <libguile/deprecation.h>
33 #include "libguile/srfi-13.h"
34 #include "libguile/srfi-14.h"
36 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
37 pos_start, start, c_start, \
38 pos_end, end, c_end) \
40 SCM_VALIDATE_STRING (pos_str, str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 #define REF_IN_CHARSET(s, i, cs) \
55 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
57 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
59 "Return @code{#t} if @var{str}'s length is zero, and\n"
60 "@code{#f} otherwise.\n"
62 "(string-null? \"\") @result{} #t\n"
63 "y @result{} \"foo\"\n"
64 "(string-null? y) @result{} #f\n"
66 #define FUNC_NAME s_scm_string_null_p
68 SCM_VALIDATE_STRING (1, str
);
69 return scm_from_bool (scm_i_string_length (str
) == 0);
77 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
81 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
82 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
83 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
85 "@var{char_pred} can be a character to check for any equal to that, or\n"
86 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
87 "or a predicate procedure to call.\n"
89 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
90 "successively on the characters from @var{start} to @var{end}. If\n"
91 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
92 "stops and that return value is the return from @code{string-any}. The\n"
93 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
94 "point is reached, is a tail call.\n"
96 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
97 "@var{end}) then the return is @code{#f}.\n")
98 #define FUNC_NAME s_scm_string_any
101 SCM res
= SCM_BOOL_F
;
103 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
107 if (SCM_CHARP (char_pred
))
110 for (i
= cstart
; i
< cend
; i
++)
111 if (scm_i_string_ref (s
, i
) == SCM_CHAR (char_pred
))
117 else if (SCM_CHARSETP (char_pred
))
120 for (i
= cstart
; i
< cend
; i
++)
121 if (REF_IN_CHARSET (s
, i
, char_pred
))
129 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
130 char_pred
, SCM_ARG1
, FUNC_NAME
);
132 while (cstart
< cend
)
134 res
= scm_call_1 (char_pred
,
135 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
136 if (scm_is_true (res
))
142 scm_remember_upto_here_1 (s
);
148 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
149 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
150 "Check if @var{char_pred} is true for every character in string\n"
153 "@var{char_pred} can be a character to check for every character equal\n"
154 "to that, or a character set (@pxref{Character Sets}) to check for\n"
155 "every character being in that set, or a predicate procedure to call.\n"
157 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
158 "successively on the characters from @var{start} to @var{end}. If\n"
159 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
160 "returns @code{#f}. The call on the last character (ie.@: at\n"
161 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
162 "return from that call is the return from @code{string-every}.\n"
164 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
165 "@var{end}) then the return is @code{#t}.\n")
166 #define FUNC_NAME s_scm_string_every
169 SCM res
= SCM_BOOL_T
;
171 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
174 if (SCM_CHARP (char_pred
))
177 for (i
= cstart
; i
< cend
; i
++)
178 if (scm_i_string_ref (s
, i
) != SCM_CHAR (char_pred
))
184 else if (SCM_CHARSETP (char_pred
))
187 for (i
= cstart
; i
< cend
; i
++)
188 if (!REF_IN_CHARSET (s
, i
, char_pred
))
196 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
197 char_pred
, SCM_ARG1
, FUNC_NAME
);
199 while (cstart
< cend
)
201 res
= scm_call_1 (char_pred
,
202 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
203 if (scm_is_false (res
))
209 scm_remember_upto_here_1 (s
);
215 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
217 "@var{proc} is an integer->char procedure. Construct a string\n"
218 "of size @var{len} by applying @var{proc} to each index to\n"
219 "produce the corresponding string element. The order in which\n"
220 "@var{proc} is applied to the indices is not specified.")
221 #define FUNC_NAME s_scm_string_tabulate
227 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
228 proc
, SCM_ARG1
, FUNC_NAME
);
230 SCM_ASSERT_RANGE (2, len
, scm_to_int (len
) >= 0);
231 clen
= scm_to_size_t (len
);
234 /* This function is more complicated than necessary for the sake
236 scm_t_wchar
*buf
= scm_malloc (clen
* sizeof (scm_t_wchar
));
241 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
244 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
246 if (SCM_CHAR (ch
) > 255)
248 buf
[i
] = SCM_CHAR (ch
);
253 scm_t_wchar
*wbuf
= NULL
;
254 res
= scm_i_make_wide_string (clen
, &wbuf
, 0);
255 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
261 res
= scm_i_make_string (clen
, &nbuf
, 0);
262 for (i
= 0; i
< clen
; i
++)
263 nbuf
[i
] = (unsigned char) buf
[i
];
273 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
274 (SCM str
, SCM start
, SCM end
),
275 "Convert the string @var{str} into a list of characters.")
276 #define FUNC_NAME s_scm_substring_to_list
280 SCM result
= SCM_EOL
;
282 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
286 /* This explicit narrow/wide logic (instead of just using
287 scm_i_string_ref) is for speed optimizaion. */
288 narrow
= scm_i_is_narrow_string (str
);
291 const char *buf
= scm_i_string_chars (str
);
292 while (cstart
< cend
)
295 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
300 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
301 while (cstart
< cend
)
304 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
307 scm_remember_upto_here_1 (str
);
312 /* We export scm_substring_to_list as "string->list" since it is
313 compatible and more general. This function remains for the benefit
314 of C code that used it.
318 scm_string_to_list (SCM str
)
320 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
323 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
325 "An efficient implementation of @code{(compose string->list\n"
329 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
331 #define FUNC_NAME s_scm_reverse_list_to_string
334 long i
= scm_ilength (chrs
), j
;
338 SCM_WRONG_TYPE_ARG (1, chrs
);
339 result
= scm_i_make_string (i
, &data
, 0);
345 while (j
< i
&& scm_is_pair (rest
))
347 SCM elt
= SCM_CAR (rest
);
348 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
350 rest
= SCM_CDR (rest
);
354 result
= scm_i_string_start_writing (result
);
355 while (j
> 0 && scm_is_pair (rest
))
357 SCM elt
= SCM_CAR (rest
);
358 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
359 rest
= SCM_CDR (rest
);
362 scm_i_string_stop_writing ();
370 SCM_SYMBOL (scm_sym_infix
, "infix");
371 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
372 SCM_SYMBOL (scm_sym_suffix
, "suffix");
373 SCM_SYMBOL (scm_sym_prefix
, "prefix");
375 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
376 (SCM ls
, SCM delimiter
, SCM grammar
),
377 "Append the string in the string list @var{ls}, using the string\n"
378 "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
379 "@var{grammar} is a symbol which specifies how the delimiter is\n"
380 "placed between the strings, and defaults to the symbol\n"
385 "Insert the separator between list elements. An empty string\n"
386 "will produce an empty list.\n"
387 "@item string-infix\n"
388 "Like @code{infix}, but will raise an error if given the empty\n"
391 "Insert the separator after every list element.\n"
393 "Insert the separator before each list element.\n"
395 #define FUNC_NAME s_scm_string_join
398 #define GRAM_STRICT_INFIX 1
399 #define GRAM_SUFFIX 2
400 #define GRAM_PREFIX 3
403 int gram
= GRAM_INFIX
;
405 long strings
= scm_ilength (ls
);
407 /* Validate the string list. */
409 SCM_WRONG_TYPE_ARG (1, ls
);
411 /* Validate the delimiter and record its length. */
412 if (SCM_UNBNDP (delimiter
))
414 delimiter
= scm_from_locale_string (" ");
419 SCM_VALIDATE_STRING (2, delimiter
);
420 del_len
= scm_i_string_length (delimiter
);
423 /* Validate the grammar symbol and remember the grammar. */
424 if (SCM_UNBNDP (grammar
))
426 else if (scm_is_eq (grammar
, scm_sym_infix
))
428 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
429 gram
= GRAM_STRICT_INFIX
;
430 else if (scm_is_eq (grammar
, scm_sym_suffix
))
432 else if (scm_is_eq (grammar
, scm_sym_prefix
))
435 SCM_WRONG_TYPE_ARG (3, grammar
);
437 /* Check grammar constraints. */
438 if (strings
== 0 && gram
== GRAM_STRICT_INFIX
)
439 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
442 result
= scm_i_make_string (0, NULL
, 0);
448 case GRAM_STRICT_INFIX
:
449 while (scm_is_pair (tmp
))
451 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
452 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
453 result
= scm_string_append (scm_list_2 (result
, delimiter
));
458 while (scm_is_pair (tmp
))
460 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
462 result
= scm_string_append (scm_list_2 (result
, delimiter
));
467 while (scm_is_pair (tmp
))
470 result
= scm_string_append (scm_list_2 (result
, delimiter
));
471 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
479 #undef GRAM_STRICT_INFIX
486 /* There are a number of functions to consider here for Scheme and C:
488 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
489 substring/copy STR start [end] ;; Guile variant of R5RS substring
491 scm_string_copy (str) ;; Old function from Guile
492 scm_substring_copy (str, [start, [end]])
493 ;; C version of SRFI-13 string-copy
494 ;; and C version of substring/copy
496 The C function underlying string-copy is not exported to C
497 programs. scm_substring_copy is defined in strings.c as the
498 underlying function of substring/copy and allows an optional START
502 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
504 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
505 (SCM str
, SCM start
, SCM end
),
506 "Return a freshly allocated copy of the string @var{str}. If\n"
507 "given, @var{start} and @var{end} delimit the portion of\n"
508 "@var{str} which is copied.")
509 #define FUNC_NAME s_scm_srfi13_substring_copy
513 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
516 return scm_i_substring_copy (str
, cstart
, cend
);
521 scm_string_copy (SCM str
)
523 if (!scm_is_string (str
))
524 scm_wrong_type_arg ("scm_string_copy", 0, str
);
526 return scm_i_substring (str
, 0, scm_i_string_length (str
));
529 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
530 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
531 "Copy the sequence of characters from index range [@var{start},\n"
532 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
533 "at index @var{tstart}. The characters are copied left-to-right\n"
534 "or right-to-left as needed -- the copy is guaranteed to work,\n"
535 "even if @var{target} and @var{s} are the same string. It is an\n"
536 "error if the copy operation runs off the end of the target\n"
538 #define FUNC_NAME s_scm_string_copy_x
540 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
541 SCM sdummy
= SCM_UNDEFINED
;
543 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
546 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
552 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
554 target
= scm_i_string_start_writing (target
);
555 for (i
= 0; i
< cend
- cstart
; i
++)
557 scm_i_string_set_x (target
, ctstart
+ i
,
558 scm_i_string_ref (s
, cstart
+ i
));
560 scm_i_string_stop_writing ();
561 scm_remember_upto_here_1 (target
);
564 return SCM_UNSPECIFIED
;
568 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
569 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
570 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
571 "into @var{str2} beginning at position @var{start2}.\n"
572 "@var{str1} and @var{str2} can be the same string.")
573 #define FUNC_NAME s_scm_substring_move_x
575 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
579 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
581 "Return the @var{n} first characters of @var{s}.")
582 #define FUNC_NAME s_scm_string_take
584 return scm_substring (s
, SCM_INUM0
, n
);
589 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
591 "Return all but the first @var{n} characters of @var{s}.")
592 #define FUNC_NAME s_scm_string_drop
594 return scm_substring (s
, n
, SCM_UNDEFINED
);
599 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
601 "Return the @var{n} last characters of @var{s}.")
602 #define FUNC_NAME s_scm_string_take_right
604 return scm_substring (s
,
605 scm_difference (scm_string_length (s
), n
),
611 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
613 "Return all but the last @var{n} characters of @var{s}.")
614 #define FUNC_NAME s_scm_string_drop_right
616 return scm_substring (s
,
618 scm_difference (scm_string_length (s
), n
));
623 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
624 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
625 "Take that characters from @var{start} to @var{end} from the\n"
626 "string @var{s} and return a new string, right-padded by the\n"
627 "character @var{chr} to length @var{len}. If the resulting\n"
628 "string is longer than @var{len}, it is truncated on the right.")
629 #define FUNC_NAME s_scm_string_pad
631 size_t cstart
, cend
, clen
;
633 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
636 clen
= scm_to_size_t (len
);
638 if (SCM_UNBNDP (chr
))
639 chr
= SCM_MAKE_CHAR (' ');
642 SCM_VALIDATE_CHAR (3, chr
);
644 if (clen
< (cend
- cstart
))
645 return scm_i_substring (s
, cend
- clen
, cend
);
649 result
= (scm_string_append
650 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
651 scm_i_substring (s
, cstart
, cend
))));
658 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
659 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
660 "Take that characters from @var{start} to @var{end} from the\n"
661 "string @var{s} and return a new string, left-padded by the\n"
662 "character @var{chr} to length @var{len}. If the resulting\n"
663 "string is longer than @var{len}, it is truncated on the left.")
664 #define FUNC_NAME s_scm_string_pad_right
666 size_t cstart
, cend
, clen
;
668 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
671 clen
= scm_to_size_t (len
);
673 if (SCM_UNBNDP (chr
))
674 chr
= SCM_MAKE_CHAR (' ');
677 SCM_VALIDATE_CHAR (3, chr
);
679 if (clen
< (cend
- cstart
))
680 return scm_i_substring (s
, cstart
, cstart
+ clen
);
685 result
= (scm_string_append
686 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
687 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
695 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
696 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
697 "Trim @var{s} by skipping over all characters on the left\n"
698 "that satisfy the parameter @var{char_pred}:\n"
702 "if it is the character @var{ch}, characters equal to\n"
703 "@var{ch} are trimmed,\n"
706 "if it is a procedure @var{pred} characters that\n"
707 "satisfy @var{pred} are trimmed,\n"
710 "if it is a character set, characters in that set are trimmed.\n"
713 "If called without a @var{char_pred} argument, all whitespace is\n"
715 #define FUNC_NAME s_scm_string_trim
719 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
722 if (SCM_UNBNDP (char_pred
))
724 while (cstart
< cend
)
726 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
731 else if (SCM_CHARP (char_pred
))
733 while (cstart
< cend
)
735 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
740 else if (SCM_CHARSETP (char_pred
))
742 while (cstart
< cend
)
744 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
751 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
752 char_pred
, SCM_ARG2
, FUNC_NAME
);
754 while (cstart
< cend
)
758 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
759 if (scm_is_false (res
))
764 return scm_i_substring (s
, cstart
, cend
);
769 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
770 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
771 "Trim @var{s} by skipping over all characters on the right\n"
772 "that satisfy the parameter @var{char_pred}:\n"
776 "if it is the character @var{ch}, characters equal to @var{ch}\n"
780 "if it is a procedure @var{pred} characters that satisfy\n"
781 "@var{pred} are trimmed,\n"
784 "if it is a character sets, all characters in that set are\n"
788 "If called without a @var{char_pred} argument, all whitespace is\n"
790 #define FUNC_NAME s_scm_string_trim_right
794 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
797 if (SCM_UNBNDP (char_pred
))
799 while (cstart
< cend
)
801 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
806 else if (SCM_CHARP (char_pred
))
808 while (cstart
< cend
)
810 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
815 else if (SCM_CHARSETP (char_pred
))
817 while (cstart
< cend
)
819 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
826 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
827 char_pred
, SCM_ARG2
, FUNC_NAME
);
829 while (cstart
< cend
)
833 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
834 if (scm_is_false (res
))
839 return scm_i_substring (s
, cstart
, cend
);
844 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
845 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
846 "Trim @var{s} by skipping over all characters on both sides of\n"
847 "the string that satisfy the parameter @var{char_pred}:\n"
851 "if it is the character @var{ch}, characters equal to @var{ch}\n"
855 "if it is a procedure @var{pred} characters that satisfy\n"
856 "@var{pred} are trimmed,\n"
859 "if it is a character set, the characters in the set are\n"
863 "If called without a @var{char_pred} argument, all whitespace is\n"
865 #define FUNC_NAME s_scm_string_trim_both
869 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
872 if (SCM_UNBNDP (char_pred
))
874 while (cstart
< cend
)
876 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
880 while (cstart
< cend
)
882 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
887 else if (SCM_CHARP (char_pred
))
889 while (cstart
< cend
)
891 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
895 while (cstart
< cend
)
897 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
902 else if (SCM_CHARSETP (char_pred
))
904 while (cstart
< cend
)
906 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
910 while (cstart
< cend
)
912 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
919 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
920 char_pred
, SCM_ARG2
, FUNC_NAME
);
922 while (cstart
< cend
)
926 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
927 if (scm_is_false (res
))
931 while (cstart
< cend
)
935 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
936 if (scm_is_false (res
))
941 return scm_i_substring (s
, cstart
, cend
);
946 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
947 (SCM str
, SCM chr
, SCM start
, SCM end
),
948 "Stores @var{chr} in every element of the given @var{str} and\n"
949 "returns an unspecified value.")
950 #define FUNC_NAME s_scm_substring_fill_x
955 /* Older versions of Guile provided the function
956 scm_substring_fill_x with the following order of arguments:
960 We accomodate this here by detecting such a usage and reordering
971 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
974 SCM_VALIDATE_CHAR (2, chr
);
978 str
= scm_i_string_start_writing (str
);
979 for (k
= cstart
; k
< cend
; k
++)
980 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
981 scm_i_string_stop_writing ();
984 return SCM_UNSPECIFIED
;
989 scm_string_fill_x (SCM str
, SCM chr
)
991 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
994 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
995 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
996 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
997 "mismatch index, depending upon whether @var{s1} is less than,\n"
998 "equal to, or greater than @var{s2}. The mismatch index is the\n"
999 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1000 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1001 "@var{i} is the first position that does not match.")
1002 #define FUNC_NAME s_scm_string_compare
1004 size_t cstart1
, cend1
, cstart2
, cend2
;
1007 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1010 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1013 SCM_VALIDATE_PROC (3, proc_lt
);
1014 SCM_VALIDATE_PROC (4, proc_eq
);
1015 SCM_VALIDATE_PROC (5, proc_gt
);
1017 while (cstart1
< cend1
&& cstart2
< cend2
)
1019 if (scm_i_string_ref (s1
, cstart1
)
1020 < scm_i_string_ref (s2
, cstart2
))
1025 else if (scm_i_string_ref (s1
, cstart1
)
1026 > scm_i_string_ref (s2
, cstart2
))
1034 if (cstart1
< cend1
)
1036 else if (cstart2
< cend2
)
1042 scm_remember_upto_here_2 (s1
, s2
);
1043 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1048 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1049 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1050 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1051 "mismatch index, depending upon whether @var{s1} is less than,\n"
1052 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1053 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1054 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1055 "@var{i} is the first position where the lowercased letters \n"
1057 #define FUNC_NAME s_scm_string_compare_ci
1059 size_t cstart1
, cend1
, cstart2
, cend2
;
1062 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1065 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1068 SCM_VALIDATE_PROC (3, proc_lt
);
1069 SCM_VALIDATE_PROC (4, proc_eq
);
1070 SCM_VALIDATE_PROC (5, proc_gt
);
1072 while (cstart1
< cend1
&& cstart2
< cend2
)
1074 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1075 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1080 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1081 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1090 if (cstart1
< cend1
)
1092 else if (cstart2
< cend2
)
1098 scm_remember_upto_here (s1
, s2
);
1099 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1103 /* This function compares two substrings, S1 from START1 to END1 and
1104 S2 from START2 to END2, possibly case insensitively, and returns
1105 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1106 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1107 longer, or equal. */
1109 compare_strings (const char *fname
, int case_insensitive
,
1110 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1111 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1113 size_t cstart1
, cend1
, cstart2
, cend2
;
1117 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1120 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1124 while (cstart1
< cend1
&& cstart2
< cend2
)
1126 if (case_insensitive
)
1128 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1129 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1133 a
= scm_i_string_ref (s1
, cstart1
);
1134 b
= scm_i_string_ref (s2
, cstart2
);
1149 if (cstart1
< cend1
)
1154 else if (cstart2
< cend2
)
1166 scm_remember_upto_here_2 (s1
, s2
);
1171 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1172 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1173 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1175 #define FUNC_NAME s_scm_string_eq
1177 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1178 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1179 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1180 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1182 /* Fast path for this common case, which avoids the repeated calls to
1183 `scm_i_string_ref'. */
1186 len1
= scm_i_string_length (s1
);
1187 len2
= scm_i_string_length (s2
);
1193 if (!scm_i_is_narrow_string (s1
))
1196 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1197 scm_i_string_data (s2
),
1202 return compare_strings (FUNC_NAME
, 0,
1203 s1
, s2
, start1
, end1
, start2
, end2
,
1204 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1209 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1210 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1211 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1213 #define FUNC_NAME s_scm_string_neq
1215 return compare_strings (FUNC_NAME
, 0,
1216 s1
, s2
, start1
, end1
, start2
, end2
,
1217 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1222 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1223 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1224 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1225 "true value otherwise.")
1226 #define FUNC_NAME s_scm_string_lt
1228 return compare_strings (FUNC_NAME
, 0,
1229 s1
, s2
, start1
, end1
, start2
, end2
,
1230 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1235 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1236 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1237 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1238 "true value otherwise.")
1239 #define FUNC_NAME s_scm_string_gt
1241 return compare_strings (FUNC_NAME
, 0,
1242 s1
, s2
, start1
, end1
, start2
, end2
,
1243 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1248 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1249 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1250 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1252 #define FUNC_NAME s_scm_string_le
1254 return compare_strings (FUNC_NAME
, 0,
1255 s1
, s2
, start1
, end1
, start2
, end2
,
1256 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1261 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1262 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1263 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1265 #define FUNC_NAME s_scm_string_ge
1267 return compare_strings (FUNC_NAME
, 0,
1268 s1
, s2
, start1
, end1
, start2
, end2
,
1269 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1274 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1275 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1276 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1277 "value otherwise. The character comparison is done\n"
1278 "case-insensitively.")
1279 #define FUNC_NAME s_scm_string_ci_eq
1281 return compare_strings (FUNC_NAME
, 1,
1282 s1
, s2
, start1
, end1
, start2
, end2
,
1283 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1288 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1289 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1290 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1291 "value otherwise. The character comparison is done\n"
1292 "case-insensitively.")
1293 #define FUNC_NAME s_scm_string_ci_neq
1295 return compare_strings (FUNC_NAME
, 1,
1296 s1
, s2
, start1
, end1
, start2
, end2
,
1297 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1302 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1303 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1304 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1305 "true value otherwise. The character comparison is done\n"
1306 "case-insensitively.")
1307 #define FUNC_NAME s_scm_string_ci_lt
1309 return compare_strings (FUNC_NAME
, 1,
1310 s1
, s2
, start1
, end1
, start2
, end2
,
1311 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1316 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1317 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1318 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1319 "true value otherwise. The character comparison is done\n"
1320 "case-insensitively.")
1321 #define FUNC_NAME s_scm_string_ci_gt
1323 return compare_strings (FUNC_NAME
, 1,
1324 s1
, s2
, start1
, end1
, start2
, end2
,
1325 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1330 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1331 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1332 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1333 "value otherwise. The character comparison is done\n"
1334 "case-insensitively.")
1335 #define FUNC_NAME s_scm_string_ci_le
1337 return compare_strings (FUNC_NAME
, 1,
1338 s1
, s2
, start1
, end1
, start2
, end2
,
1339 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1344 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1345 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1346 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1347 "otherwise. The character comparison is done\n"
1348 "case-insensitively.")
1349 #define FUNC_NAME s_scm_string_ci_ge
1351 return compare_strings (FUNC_NAME
, 1,
1352 s1
, s2
, start1
, end1
, start2
, end2
,
1353 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1357 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1358 (SCM s
, SCM bound
, SCM start
, SCM end
),
1359 "Compute a hash value for @var{s}. the optional argument "
1360 "@var{bound} is a non-negative exact "
1361 "integer specifying the range of the hash function. "
1362 "A positive value restricts the return value to the "
1364 #define FUNC_NAME s_scm_substring_hash
1366 if (SCM_UNBNDP (bound
))
1367 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1368 if (SCM_UNBNDP (start
))
1370 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1374 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1375 (SCM s
, SCM bound
, SCM start
, SCM end
),
1376 "Compute a hash value for @var{s}. the optional argument "
1377 "@var{bound} is a non-negative exact "
1378 "integer specifying the range of the hash function. "
1379 "A positive value restricts the return value to the "
1381 #define FUNC_NAME s_scm_substring_hash_ci
1383 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1385 SCM_UNDEFINED
, SCM_UNDEFINED
);
1389 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1390 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1391 "Return the length of the longest common prefix of the two\n"
1393 #define FUNC_NAME s_scm_string_prefix_length
1395 size_t cstart1
, cend1
, cstart2
, cend2
;
1398 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1401 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1405 while (cstart1
< cend1
&& cstart2
< cend2
)
1407 if (scm_i_string_ref (s1
, cstart1
)
1408 != scm_i_string_ref (s2
, cstart2
))
1416 scm_remember_upto_here_2 (s1
, s2
);
1417 return scm_from_size_t (len
);
1422 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1423 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1424 "Return the length of the longest common prefix of the two\n"
1425 "strings, ignoring character case.")
1426 #define FUNC_NAME s_scm_string_prefix_length_ci
1428 size_t cstart1
, cend1
, cstart2
, cend2
;
1431 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1434 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1437 while (cstart1
< cend1
&& cstart2
< cend2
)
1439 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1440 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1448 scm_remember_upto_here_2 (s1
, s2
);
1449 return scm_from_size_t (len
);
1454 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1455 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1456 "Return the length of the longest common suffix of the two\n"
1458 #define FUNC_NAME s_scm_string_suffix_length
1460 size_t cstart1
, cend1
, cstart2
, cend2
;
1463 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1466 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1469 while (cstart1
< cend1
&& cstart2
< cend2
)
1473 if (scm_i_string_ref (s1
, cend1
)
1474 != scm_i_string_ref (s2
, cend2
))
1480 scm_remember_upto_here_2 (s1
, s2
);
1481 return scm_from_size_t (len
);
1486 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1487 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1488 "Return the length of the longest common suffix of the two\n"
1489 "strings, ignoring character case.")
1490 #define FUNC_NAME s_scm_string_suffix_length_ci
1492 size_t cstart1
, cend1
, cstart2
, cend2
;
1495 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1498 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1501 while (cstart1
< cend1
&& cstart2
< cend2
)
1505 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1506 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1512 scm_remember_upto_here_2 (s1
, s2
);
1513 return scm_from_size_t (len
);
1518 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1519 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1520 "Is @var{s1} a prefix of @var{s2}?")
1521 #define FUNC_NAME s_scm_string_prefix_p
1523 size_t cstart1
, cend1
, cstart2
, cend2
;
1524 size_t len
= 0, len1
;
1526 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1529 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1532 len1
= cend1
- cstart1
;
1533 while (cstart1
< cend1
&& cstart2
< cend2
)
1535 if (scm_i_string_ref (s1
, cstart1
)
1536 != scm_i_string_ref (s2
, cstart2
))
1544 scm_remember_upto_here_2 (s1
, s2
);
1545 return scm_from_bool (len
== len1
);
1550 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1551 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1552 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1553 #define FUNC_NAME s_scm_string_prefix_ci_p
1555 size_t cstart1
, cend1
, cstart2
, cend2
;
1556 size_t len
= 0, len1
;
1558 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1561 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1564 len1
= cend1
- cstart1
;
1565 while (cstart1
< cend1
&& cstart2
< cend2
)
1567 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1568 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1577 scm_remember_upto_here_2 (s1
, s2
);
1578 return scm_from_bool (len
== len1
);
1583 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1584 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1585 "Is @var{s1} a suffix of @var{s2}?")
1586 #define FUNC_NAME s_scm_string_suffix_p
1588 size_t cstart1
, cend1
, cstart2
, cend2
;
1589 size_t len
= 0, len1
;
1591 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1594 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1597 len1
= cend1
- cstart1
;
1598 while (cstart1
< cend1
&& cstart2
< cend2
)
1602 if (scm_i_string_ref (s1
, cend1
)
1603 != scm_i_string_ref (s2
, cend2
))
1609 scm_remember_upto_here_2 (s1
, s2
);
1610 return scm_from_bool (len
== len1
);
1615 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1616 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1617 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1618 #define FUNC_NAME s_scm_string_suffix_ci_p
1620 size_t cstart1
, cend1
, cstart2
, cend2
;
1621 size_t len
= 0, len1
;
1623 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1626 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1629 len1
= cend1
- cstart1
;
1630 while (cstart1
< cend1
&& cstart2
< cend2
)
1634 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1635 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1641 scm_remember_upto_here_2 (s1
, s2
);
1642 return scm_from_bool (len
== len1
);
1647 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1648 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1649 "Search through the string @var{s} from left to right, returning\n"
1650 "the index of the first occurrence of a character which\n"
1652 "@itemize @bullet\n"
1654 "equals @var{char_pred}, if it is character,\n"
1657 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1660 "is in the set @var{char_pred}, if it is a character set.\n"
1662 "Return @code{#f} if no match is found.")
1663 #define FUNC_NAME s_scm_string_index
1665 size_t cstart
, cend
;
1667 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1670 if (SCM_CHARP (char_pred
))
1672 while (cstart
< cend
)
1674 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1679 else if (SCM_CHARSETP (char_pred
))
1681 while (cstart
< cend
)
1683 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1690 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1691 char_pred
, SCM_ARG2
, FUNC_NAME
);
1693 while (cstart
< cend
)
1696 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1697 if (scm_is_true (res
))
1703 scm_remember_upto_here_1 (s
);
1707 scm_remember_upto_here_1 (s
);
1708 return scm_from_size_t (cstart
);
1712 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1713 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1714 "Search through the string @var{s} from right to left, returning\n"
1715 "the index of the last occurrence of a character which\n"
1717 "@itemize @bullet\n"
1719 "equals @var{char_pred}, if it is character,\n"
1722 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1725 "is in the set if @var{char_pred} is a character set.\n"
1727 "Return @code{#f} if no match is found.")
1728 #define FUNC_NAME s_scm_string_index_right
1730 size_t cstart
, cend
;
1732 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1735 if (SCM_CHARP (char_pred
))
1737 while (cstart
< cend
)
1740 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1744 else if (SCM_CHARSETP (char_pred
))
1746 while (cstart
< cend
)
1749 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1755 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1756 char_pred
, SCM_ARG2
, FUNC_NAME
);
1758 while (cstart
< cend
)
1762 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1763 if (scm_is_true (res
))
1768 scm_remember_upto_here_1 (s
);
1772 scm_remember_upto_here_1 (s
);
1773 return scm_from_size_t (cend
);
1777 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1778 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1779 "Search through the string @var{s} from right to left, returning\n"
1780 "the index of the last occurrence of a character which\n"
1782 "@itemize @bullet\n"
1784 "equals @var{char_pred}, if it is character,\n"
1787 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1790 "is in the set if @var{char_pred} is a character set.\n"
1792 "Return @code{#f} if no match is found.")
1793 #define FUNC_NAME s_scm_string_rindex
1795 return scm_string_index_right (s
, char_pred
, start
, end
);
1799 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1800 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1801 "Search through the string @var{s} from left to right, returning\n"
1802 "the index of the first occurrence of a character which\n"
1804 "@itemize @bullet\n"
1806 "does not equal @var{char_pred}, if it is character,\n"
1809 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1813 "is not in the set if @var{char_pred} is a character set.\n"
1815 #define FUNC_NAME s_scm_string_skip
1817 size_t cstart
, cend
;
1819 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1822 if (SCM_CHARP (char_pred
))
1824 while (cstart
< cend
)
1826 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1831 else if (SCM_CHARSETP (char_pred
))
1833 while (cstart
< cend
)
1835 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1842 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1843 char_pred
, SCM_ARG2
, FUNC_NAME
);
1845 while (cstart
< cend
)
1848 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1849 if (scm_is_false (res
))
1855 scm_remember_upto_here_1 (s
);
1859 scm_remember_upto_here_1 (s
);
1860 return scm_from_size_t (cstart
);
1865 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1866 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1867 "Search through the string @var{s} from right to left, returning\n"
1868 "the index of the last occurrence of a character which\n"
1870 "@itemize @bullet\n"
1872 "does not equal @var{char_pred}, if it is character,\n"
1875 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1879 "is not in the set if @var{char_pred} is a character set.\n"
1881 #define FUNC_NAME s_scm_string_skip_right
1883 size_t cstart
, cend
;
1885 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1888 if (SCM_CHARP (char_pred
))
1890 while (cstart
< cend
)
1893 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1897 else if (SCM_CHARSETP (char_pred
))
1899 while (cstart
< cend
)
1902 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1908 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1909 char_pred
, SCM_ARG2
, FUNC_NAME
);
1911 while (cstart
< cend
)
1915 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1916 if (scm_is_false (res
))
1921 scm_remember_upto_here_1 (s
);
1925 scm_remember_upto_here_1 (s
);
1926 return scm_from_size_t (cend
);
1932 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1933 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1934 "Return the count of the number of characters in the string\n"
1937 "@itemize @bullet\n"
1939 "equals @var{char_pred}, if it is character,\n"
1942 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1945 "is in the set @var{char_pred}, if it is a character set.\n"
1947 #define FUNC_NAME s_scm_string_count
1949 size_t cstart
, cend
;
1952 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1955 if (SCM_CHARP (char_pred
))
1957 while (cstart
< cend
)
1959 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1964 else if (SCM_CHARSETP (char_pred
))
1966 while (cstart
< cend
)
1968 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1975 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1976 char_pred
, SCM_ARG2
, FUNC_NAME
);
1978 while (cstart
< cend
)
1981 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1982 if (scm_is_true (res
))
1988 scm_remember_upto_here_1 (s
);
1989 return scm_from_size_t (count
);
1994 /* FIXME::martin: This should definitely get implemented more
1995 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1997 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1998 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1999 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2000 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2001 "The optional start/end indices restrict the operation to the\n"
2002 "indicated substrings.")
2003 #define FUNC_NAME s_scm_string_contains
2005 size_t cstart1
, cend1
, cstart2
, cend2
;
2008 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2011 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2014 len2
= cend2
- cstart2
;
2015 if (cend1
- cstart1
>= len2
)
2016 while (cstart1
<= cend1
- len2
)
2022 && (scm_i_string_ref (s1
, i
)
2023 == scm_i_string_ref (s2
, j
)))
2030 scm_remember_upto_here_2 (s1
, s2
);
2031 return scm_from_size_t (cstart1
);
2036 scm_remember_upto_here_2 (s1
, s2
);
2042 /* FIXME::martin: This should definitely get implemented more
2043 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2045 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2046 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2047 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2048 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2049 "The optional start/end indices restrict the operation to the\n"
2050 "indicated substrings. Character comparison is done\n"
2051 "case-insensitively.")
2052 #define FUNC_NAME s_scm_string_contains_ci
2054 size_t cstart1
, cend1
, cstart2
, cend2
;
2057 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2060 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2063 len2
= cend2
- cstart2
;
2064 if (cend1
- cstart1
>= len2
)
2065 while (cstart1
<= cend1
- len2
)
2071 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2072 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2079 scm_remember_upto_here_2 (s1
, s2
);
2080 return scm_from_size_t (cstart1
);
2085 scm_remember_upto_here_2 (s1
, s2
);
2091 /* Helper function for the string uppercase conversion functions. */
2093 string_upcase_x (SCM v
, size_t start
, size_t end
)
2099 v
= scm_i_string_start_writing (v
);
2100 for (k
= start
; k
< end
; ++k
)
2101 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2102 scm_i_string_stop_writing ();
2103 scm_remember_upto_here_1 (v
);
2109 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2110 (SCM str
, SCM start
, SCM end
),
2111 "Destructively upcase every character in @code{str}.\n"
2114 "(string-upcase! y)\n"
2115 "@result{} \"ARRDEFG\"\n"
2117 "@result{} \"ARRDEFG\"\n"
2119 #define FUNC_NAME s_scm_substring_upcase_x
2121 size_t cstart
, cend
;
2123 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2126 return string_upcase_x (str
, cstart
, cend
);
2131 scm_string_upcase_x (SCM str
)
2133 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2136 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2137 (SCM str
, SCM start
, SCM end
),
2138 "Upcase every character in @code{str}.")
2139 #define FUNC_NAME s_scm_substring_upcase
2141 size_t cstart
, cend
;
2143 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2146 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2151 scm_string_upcase (SCM str
)
2153 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2156 /* Helper function for the string lowercase conversion functions.
2157 * No argument checking is performed. */
2159 string_downcase_x (SCM v
, size_t start
, size_t end
)
2165 v
= scm_i_string_start_writing (v
);
2166 for (k
= start
; k
< end
; ++k
)
2167 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2168 scm_i_string_stop_writing ();
2169 scm_remember_upto_here_1 (v
);
2175 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2176 (SCM str
, SCM start
, SCM end
),
2177 "Destructively downcase every character in @var{str}.\n"
2181 "@result{} \"ARRDEFG\"\n"
2182 "(string-downcase! y)\n"
2183 "@result{} \"arrdefg\"\n"
2185 "@result{} \"arrdefg\"\n"
2187 #define FUNC_NAME s_scm_substring_downcase_x
2189 size_t cstart
, cend
;
2191 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2194 return string_downcase_x (str
, cstart
, cend
);
2199 scm_string_downcase_x (SCM str
)
2201 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2204 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2205 (SCM str
, SCM start
, SCM end
),
2206 "Downcase every character in @var{str}.")
2207 #define FUNC_NAME s_scm_substring_downcase
2209 size_t cstart
, cend
;
2211 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2214 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2219 scm_string_downcase (SCM str
)
2221 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2224 /* Helper function for the string capitalization functions.
2225 * No argument checking is performed. */
2227 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2235 str
= scm_i_string_start_writing (str
);
2236 for(i
= start
; i
< end
; i
++)
2238 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2239 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2243 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2248 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2254 scm_i_string_stop_writing ();
2255 scm_remember_upto_here_1 (str
);
2262 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2263 (SCM str
, SCM start
, SCM end
),
2264 "Destructively titlecase every first character in a word in\n"
2266 #define FUNC_NAME s_scm_string_titlecase_x
2268 size_t cstart
, cend
;
2270 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2273 return string_titlecase_x (str
, cstart
, cend
);
2278 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2279 (SCM str
, SCM start
, SCM end
),
2280 "Titlecase every first character in a word in @var{str}.")
2281 #define FUNC_NAME s_scm_string_titlecase
2283 size_t cstart
, cend
;
2285 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2288 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2292 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2294 "Upcase the first character of every word in @var{str}\n"
2295 "destructively and return @var{str}.\n"
2298 "y @result{} \"hello world\"\n"
2299 "(string-capitalize! y) @result{} \"Hello World\"\n"
2300 "y @result{} \"Hello World\"\n"
2302 #define FUNC_NAME s_scm_string_capitalize_x
2304 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2309 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2311 "Return a freshly allocated string with the characters in\n"
2312 "@var{str}, where the first character of every word is\n"
2314 #define FUNC_NAME s_scm_string_capitalize
2316 return scm_string_capitalize_x (scm_string_copy (str
));
2321 /* Reverse the portion of @var{str} between str[cstart] (including)
2322 and str[cend] excluding. */
2324 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2328 str
= scm_i_string_start_writing (str
);
2334 while (cstart
< cend
)
2336 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2337 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2338 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2343 scm_i_string_stop_writing ();
2348 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2349 (SCM str
, SCM start
, SCM end
),
2350 "Reverse the string @var{str}. The optional arguments\n"
2351 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2353 #define FUNC_NAME s_scm_string_reverse
2355 size_t cstart
, cend
;
2358 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2361 result
= scm_string_copy (str
);
2362 string_reverse_x (result
, cstart
, cend
);
2363 scm_remember_upto_here_1 (str
);
2369 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2370 (SCM str
, SCM start
, SCM end
),
2371 "Reverse the string @var{str} in-place. The optional arguments\n"
2372 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2373 "operate on. The return value is unspecified.")
2374 #define FUNC_NAME s_scm_string_reverse_x
2376 size_t cstart
, cend
;
2378 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2382 string_reverse_x (str
, cstart
, cend
);
2383 scm_remember_upto_here_1 (str
);
2384 return SCM_UNSPECIFIED
;
2389 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2391 "Like @code{string-append}, but the result may share memory\n"
2392 "with the argument strings.")
2393 #define FUNC_NAME s_scm_string_append_shared
2395 /* If "rest" contains just one non-empty string, return that.
2396 If it's entirely empty strings, then return scm_nullstr.
2397 Otherwise use scm_string_concatenate. */
2399 SCM ret
= scm_nullstr
;
2400 int seen_nonempty
= 0;
2403 SCM_VALIDATE_REST_ARGUMENT (rest
);
2405 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2408 if (!scm_is_string (s
))
2409 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2410 if (scm_i_string_length (s
) != 0)
2413 /* two or more non-empty strings, need full concat */
2414 return scm_string_append (rest
);
2425 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2427 "Append the elements of @var{ls} (which must be strings)\n"
2428 "together into a single string. Guaranteed to return a freshly\n"
2429 "allocated string.")
2430 #define FUNC_NAME s_scm_string_concatenate
2432 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2433 return scm_string_append (ls
);
2438 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2439 (SCM ls
, SCM final_string
, SCM end
),
2440 "Without optional arguments, this procedure is equivalent to\n"
2443 "(string-concatenate (reverse ls))\n"
2446 "If the optional argument @var{final_string} is specified, it is\n"
2447 "consed onto the beginning to @var{ls} before performing the\n"
2448 "list-reverse and string-concatenate operations. If @var{end}\n"
2449 "is given, only the characters of @var{final_string} up to index\n"
2450 "@var{end} are used.\n"
2452 "Guaranteed to return a freshly allocated string.")
2453 #define FUNC_NAME s_scm_string_concatenate_reverse
2455 if (!SCM_UNBNDP (end
))
2456 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2458 if (!SCM_UNBNDP (final_string
))
2459 ls
= scm_cons (final_string
, ls
);
2461 return scm_string_concatenate (scm_reverse (ls
));
2466 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2468 "Like @code{string-concatenate}, but the result may share memory\n"
2469 "with the strings in the list @var{ls}.")
2470 #define FUNC_NAME s_scm_string_concatenate_shared
2472 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2473 return scm_string_append_shared (ls
);
2478 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2479 (SCM ls
, SCM final_string
, SCM end
),
2480 "Like @code{string-concatenate-reverse}, but the result may\n"
2481 "share memory with the strings in the @var{ls} arguments.")
2482 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2484 /* Just call the non-sharing version. */
2485 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2490 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2491 (SCM proc
, SCM s
, SCM start
, SCM end
),
2492 "@var{proc} is a char->char procedure, it is mapped over\n"
2493 "@var{s}. The order in which the procedure is applied to the\n"
2494 "string elements is not specified.")
2495 #define FUNC_NAME s_scm_string_map
2498 size_t cstart
, cend
;
2501 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2502 proc
, SCM_ARG1
, FUNC_NAME
);
2503 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2506 result
= scm_i_make_string (cend
- cstart
, NULL
, 0);
2508 while (cstart
< cend
)
2510 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2511 if (!SCM_CHARP (ch
))
2512 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2514 result
= scm_i_string_start_writing (result
);
2515 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2516 scm_i_string_stop_writing ();
2525 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2526 (SCM proc
, SCM s
, SCM start
, SCM end
),
2527 "@var{proc} is a char->char procedure, it is mapped over\n"
2528 "@var{s}. The order in which the procedure is applied to the\n"
2529 "string elements is not specified. The string @var{s} is\n"
2530 "modified in-place, the return value is not specified.")
2531 #define FUNC_NAME s_scm_string_map_x
2533 size_t cstart
, cend
;
2535 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2536 proc
, SCM_ARG1
, FUNC_NAME
);
2537 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2540 while (cstart
< cend
)
2542 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2543 if (!SCM_CHARP (ch
))
2544 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2545 s
= scm_i_string_start_writing (s
);
2546 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2547 scm_i_string_stop_writing ();
2550 return SCM_UNSPECIFIED
;
2555 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2556 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2557 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2558 "as the terminating element, from left to right. @var{kons}\n"
2559 "must expect two arguments: The actual character and the last\n"
2560 "result of @var{kons}' application.")
2561 #define FUNC_NAME s_scm_string_fold
2563 size_t cstart
, cend
;
2566 SCM_VALIDATE_PROC (1, kons
);
2567 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2571 while (cstart
< cend
)
2573 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2577 scm_remember_upto_here_1 (s
);
2583 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2584 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2585 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2586 "as the terminating element, from right to left. @var{kons}\n"
2587 "must expect two arguments: The actual character and the last\n"
2588 "result of @var{kons}' application.")
2589 #define FUNC_NAME s_scm_string_fold_right
2591 size_t cstart
, cend
;
2594 SCM_VALIDATE_PROC (1, kons
);
2595 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2599 while (cstart
< cend
)
2601 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2605 scm_remember_upto_here_1 (s
);
2611 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2612 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2613 "@itemize @bullet\n"
2614 "@item @var{g} is used to generate a series of @emph{seed}\n"
2615 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2616 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2618 "@item @var{p} tells us when to stop -- when it returns true\n"
2619 "when applied to one of these seed values.\n"
2620 "@item @var{f} maps each seed value to the corresponding\n"
2621 "character in the result string. These chars are assembled\n"
2622 "into the string in a left-to-right order.\n"
2623 "@item @var{base} is the optional initial/leftmost portion\n"
2624 "of the constructed string; it default to the empty\n"
2626 "@item @var{make_final} is applied to the terminal seed\n"
2627 "value (on which @var{p} returns true) to produce\n"
2628 "the final/rightmost portion of the constructed string.\n"
2629 "It defaults to @code{(lambda (x) "")}.\n"
2631 #define FUNC_NAME s_scm_string_unfold
2635 SCM_VALIDATE_PROC (1, p
);
2636 SCM_VALIDATE_PROC (2, f
);
2637 SCM_VALIDATE_PROC (3, g
);
2638 if (!SCM_UNBNDP (base
))
2640 SCM_VALIDATE_STRING (5, base
);
2644 ans
= scm_i_make_string (0, NULL
, 0);
2645 if (!SCM_UNBNDP (make_final
))
2646 SCM_VALIDATE_PROC (6, make_final
);
2648 res
= scm_call_1 (p
, seed
);
2649 while (scm_is_false (res
))
2653 SCM ch
= scm_call_1 (f
, seed
);
2654 if (!SCM_CHARP (ch
))
2655 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2656 str
= scm_i_make_string (1, NULL
, 0);
2657 str
= scm_i_string_start_writing (str
);
2658 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2659 scm_i_string_stop_writing ();
2662 ans
= scm_string_append (scm_list_2 (ans
, str
));
2663 seed
= scm_call_1 (g
, seed
);
2664 res
= scm_call_1 (p
, seed
);
2666 if (!SCM_UNBNDP (make_final
))
2668 res
= scm_call_1 (make_final
, seed
);
2669 return scm_string_append (scm_list_2 (ans
, res
));
2677 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2678 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2679 "@itemize @bullet\n"
2680 "@item @var{g} is used to generate a series of @emph{seed}\n"
2681 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2682 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2684 "@item @var{p} tells us when to stop -- when it returns true\n"
2685 "when applied to one of these seed values.\n"
2686 "@item @var{f} maps each seed value to the corresponding\n"
2687 "character in the result string. These chars are assembled\n"
2688 "into the string in a right-to-left order.\n"
2689 "@item @var{base} is the optional initial/rightmost portion\n"
2690 "of the constructed string; it default to the empty\n"
2692 "@item @var{make_final} is applied to the terminal seed\n"
2693 "value (on which @var{p} returns true) to produce\n"
2694 "the final/leftmost portion of the constructed string.\n"
2695 "It defaults to @code{(lambda (x) "")}.\n"
2697 #define FUNC_NAME s_scm_string_unfold_right
2701 SCM_VALIDATE_PROC (1, p
);
2702 SCM_VALIDATE_PROC (2, f
);
2703 SCM_VALIDATE_PROC (3, g
);
2704 if (!SCM_UNBNDP (base
))
2706 SCM_VALIDATE_STRING (5, base
);
2710 ans
= scm_i_make_string (0, NULL
, 0);
2711 if (!SCM_UNBNDP (make_final
))
2712 SCM_VALIDATE_PROC (6, make_final
);
2714 res
= scm_call_1 (p
, seed
);
2715 while (scm_is_false (res
))
2719 SCM ch
= scm_call_1 (f
, seed
);
2720 if (!SCM_CHARP (ch
))
2721 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2722 str
= scm_i_make_string (1, NULL
, 0);
2723 str
= scm_i_string_start_writing (str
);
2724 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2725 scm_i_string_stop_writing ();
2728 ans
= scm_string_append (scm_list_2 (str
, ans
));
2729 seed
= scm_call_1 (g
, seed
);
2730 res
= scm_call_1 (p
, seed
);
2732 if (!SCM_UNBNDP (make_final
))
2734 res
= scm_call_1 (make_final
, seed
);
2735 return scm_string_append (scm_list_2 (res
, ans
));
2743 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2744 (SCM proc
, SCM s
, SCM start
, SCM end
),
2745 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2746 "return value is not specified.")
2747 #define FUNC_NAME s_scm_string_for_each
2749 size_t cstart
, cend
;
2751 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2752 proc
, SCM_ARG1
, FUNC_NAME
);
2753 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2756 while (cstart
< cend
)
2758 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2762 scm_remember_upto_here_1 (s
);
2763 return SCM_UNSPECIFIED
;
2767 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2768 (SCM proc
, SCM s
, SCM start
, SCM end
),
2769 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2772 "For example, to change characters to alternately upper and\n"
2776 "(define str (string-copy \"studly\"))\n"
2777 "(string-for-each-index\n"
2779 " (string-set! str i\n"
2780 " ((if (even? i) char-upcase char-downcase)\n"
2781 " (string-ref str i))))\n"
2783 "str @result{} \"StUdLy\"\n"
2785 #define FUNC_NAME s_scm_string_for_each_index
2787 size_t cstart
, cend
;
2789 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2790 proc
, SCM_ARG1
, FUNC_NAME
);
2791 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2795 while (cstart
< cend
)
2797 scm_call_1 (proc
, scm_from_size_t (cstart
));
2801 scm_remember_upto_here_1 (s
);
2802 return SCM_UNSPECIFIED
;
2806 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2807 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2808 "This is the @emph{extended substring} procedure that implements\n"
2809 "replicated copying of a substring of some string.\n"
2811 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2812 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2813 "0 and the length of @var{s}. Replicate this substring up and\n"
2814 "down index space, in both the positive and negative directions.\n"
2815 "@code{xsubstring} returns the substring of this string\n"
2816 "beginning at index @var{from}, and ending at @var{to}, which\n"
2817 "defaults to @var{from} + (@var{end} - @var{start}).")
2818 #define FUNC_NAME s_scm_xsubstring
2821 size_t cstart
, cend
;
2825 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2829 cfrom
= scm_to_int (from
);
2830 if (SCM_UNBNDP (to
))
2831 cto
= cfrom
+ (cend
- cstart
);
2833 cto
= scm_to_int (to
);
2834 if (cstart
== cend
&& cfrom
!= cto
)
2835 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2837 result
= scm_i_make_string (cto
- cfrom
, NULL
, 0);
2838 result
= scm_i_string_start_writing (result
);
2843 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2845 scm_i_string_set_x (result
, p
,
2846 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2848 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2852 scm_i_string_stop_writing ();
2854 scm_remember_upto_here_1 (s
);
2860 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2861 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2862 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2863 "is written into the string @var{target} starting at index\n"
2864 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2865 "@var{target} @var{s})} or these arguments share storage -- you\n"
2866 "cannot copy a string on top of itself.")
2867 #define FUNC_NAME s_scm_string_xcopy_x
2870 size_t ctstart
, cstart
, cend
;
2872 SCM dummy
= SCM_UNDEFINED
;
2875 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2878 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2881 csfrom
= scm_to_int (sfrom
);
2882 if (SCM_UNBNDP (sto
))
2883 csto
= csfrom
+ (cend
- cstart
);
2885 csto
= scm_to_int (sto
);
2889 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2890 SCM_ASSERT_RANGE (1, tstart
,
2891 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2894 target
= scm_i_string_start_writing (target
);
2895 while (csfrom
< csto
)
2897 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2899 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2901 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2905 scm_i_string_stop_writing ();
2907 scm_remember_upto_here_2 (target
, s
);
2909 return SCM_UNSPECIFIED
;
2914 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2915 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2916 "Return the string @var{s1}, but with the characters\n"
2917 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2918 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2919 #define FUNC_NAME s_scm_string_replace
2921 size_t cstart1
, cend1
, cstart2
, cend2
;
2924 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2927 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2930 return (scm_string_append
2931 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2932 scm_i_substring (s2
, cstart2
, cend2
),
2933 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2939 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2940 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2941 "Split the string @var{s} into a list of substrings, where each\n"
2942 "substring is a maximal non-empty contiguous sequence of\n"
2943 "characters from the character set @var{token_set}, which\n"
2944 "defaults to @code{char-set:graphic}.\n"
2945 "If @var{start} or @var{end} indices are provided, they restrict\n"
2946 "@code{string-tokenize} to operating on the indicated substring\n"
2948 #define FUNC_NAME s_scm_string_tokenize
2950 size_t cstart
, cend
;
2951 SCM result
= SCM_EOL
;
2953 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2957 if (SCM_UNBNDP (token_set
))
2958 token_set
= scm_char_set_graphic
;
2960 if (SCM_CHARSETP (token_set
))
2964 while (cstart
< cend
)
2966 while (cstart
< cend
)
2968 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2975 while (cstart
< cend
)
2977 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2981 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2985 SCM_WRONG_TYPE_ARG (2, token_set
);
2987 scm_remember_upto_here_1 (s
);
2992 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2994 "Split the string @var{str} into a list of the substrings delimited\n"
2995 "by appearances of the character @var{chr}. Note that an empty substring\n"
2996 "between separator characters will result in an empty string in the\n"
3000 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3002 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3004 "(string-split \"::\" #\\:)\n"
3006 "(\"\" \"\" \"\")\n"
3008 "(string-split \"\" #\\:)\n"
3012 #define FUNC_NAME s_scm_string_split
3018 SCM_VALIDATE_STRING (1, str
);
3019 SCM_VALIDATE_CHAR (2, chr
);
3021 /* This is explicit wide/narrow logic (instead of using
3022 scm_i_string_ref) is a speed optimization. */
3023 idx
= scm_i_string_length (str
);
3024 narrow
= scm_i_is_narrow_string (str
);
3027 const char *buf
= scm_i_string_chars (str
);
3031 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
3035 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3042 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3046 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3050 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3055 scm_remember_upto_here_1 (str
);
3061 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3062 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3063 "Filter the string @var{s}, retaining only those characters\n"
3064 "which satisfy @var{char_pred}.\n"
3066 "If @var{char_pred} is a procedure, it is applied to each\n"
3067 "character as a predicate, if it is a character, it is tested\n"
3068 "for equality and if it is a character set, it is tested for\n"
3070 #define FUNC_NAME s_scm_string_filter
3072 size_t cstart
, cend
;
3076 #if SCM_ENABLE_DEPRECATED == 1
3077 if (scm_is_string (char_pred
))
3081 scm_c_issue_deprecation_warning
3082 ("Guile used to use the wrong argument order for string-filter.\n"
3083 "This call to string-filter had the arguments in the wrong order.\n"
3084 "See SRFI-13 for more details. At some point we will remove this hack.");
3092 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3096 /* The explicit loops below stripping leading and trailing non-matches
3097 mean we can return a substring if those are the only deletions, making
3098 string-filter as efficient as string-trim-both in that case. */
3100 if (SCM_CHARP (char_pred
))
3104 /* strip leading non-matches by incrementing cstart */
3105 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3108 /* strip trailing non-matches by decrementing cend */
3109 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3112 /* count chars to keep */
3114 for (idx
= cstart
; idx
< cend
; idx
++)
3115 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3118 if (count
== cend
- cstart
)
3120 /* whole of cstart to cend is to be kept, return a copy-on-write
3123 result
= scm_i_substring (s
, cstart
, cend
);
3126 result
= scm_c_make_string (count
, char_pred
);
3128 else if (SCM_CHARSETP (char_pred
))
3132 /* strip leading non-matches by incrementing cstart */
3133 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3136 /* strip trailing non-matches by decrementing cend */
3137 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3140 /* count chars to be kept */
3142 for (idx
= cstart
; idx
< cend
; idx
++)
3143 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3146 /* if whole of start to end kept then return substring */
3147 if (count
== cend
- cstart
)
3148 goto result_substring
;
3152 result
= scm_i_make_string (count
, NULL
, 0);
3153 result
= scm_i_string_start_writing (result
);
3155 /* decrement "count" in this loop as well as using idx, so that if
3156 another thread is simultaneously changing "s" there's no chance
3157 it'll make us copy more than count characters */
3158 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3160 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3162 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3167 scm_i_string_stop_writing ();
3174 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3175 char_pred
, SCM_ARG1
, FUNC_NAME
);
3180 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3181 res
= scm_call_1 (char_pred
, ch
);
3182 if (scm_is_true (res
))
3183 ls
= scm_cons (ch
, ls
);
3186 result
= scm_reverse_list_to_string (ls
);
3189 scm_remember_upto_here_1 (s
);
3195 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3196 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3197 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3199 "If @var{char_pred} is a procedure, it is applied to each\n"
3200 "character as a predicate, if it is a character, it is tested\n"
3201 "for equality and if it is a character set, it is tested for\n"
3203 #define FUNC_NAME s_scm_string_delete
3205 size_t cstart
, cend
;
3209 #if SCM_ENABLE_DEPRECATED == 1
3210 if (scm_is_string (char_pred
))
3214 scm_c_issue_deprecation_warning
3215 ("Guile used to use the wrong argument order for string-delete.\n"
3216 "This call to string-filter had the arguments in the wrong order.\n"
3217 "See SRFI-13 for more details. At some point we will remove this hack.");
3225 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3229 /* The explicit loops below stripping leading and trailing matches mean we
3230 can return a substring if those are the only deletions, making
3231 string-delete as efficient as string-trim-both in that case. */
3233 if (SCM_CHARP (char_pred
))
3237 /* strip leading matches by incrementing cstart */
3238 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3241 /* strip trailing matches by decrementing cend */
3242 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3245 /* count chars to be kept */
3247 for (idx
= cstart
; idx
< cend
; idx
++)
3248 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3251 if (count
== cend
- cstart
)
3253 /* whole of cstart to cend is to be kept, return a copy-on-write
3256 result
= scm_i_substring (s
, cstart
, cend
);
3261 /* new string for retained portion */
3262 result
= scm_i_make_string (count
, NULL
, 0);
3263 result
= scm_i_string_start_writing (result
);
3264 /* decrement "count" in this loop as well as using idx, so that if
3265 another thread is simultaneously changing "s" there's no chance
3266 it'll make us copy more than count characters */
3267 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3269 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3270 if (c
!= SCM_CHAR (char_pred
))
3272 scm_i_string_set_x (result
, i
, c
);
3277 scm_i_string_stop_writing ();
3280 else if (SCM_CHARSETP (char_pred
))
3284 /* strip leading matches by incrementing cstart */
3285 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3288 /* strip trailing matches by decrementing cend */
3289 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3292 /* count chars to be kept */
3294 for (idx
= cstart
; idx
< cend
; idx
++)
3295 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3298 if (count
== cend
- cstart
)
3299 goto result_substring
;
3303 /* new string for retained portion */
3304 result
= scm_i_make_string (count
, NULL
, 0);
3305 result
= scm_i_string_start_writing (result
);
3307 /* decrement "count" in this loop as well as using idx, so that if
3308 another thread is simultaneously changing "s" there's no chance
3309 it'll make us copy more than count characters */
3310 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3312 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3314 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3319 scm_i_string_stop_writing ();
3325 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3326 char_pred
, SCM_ARG1
, FUNC_NAME
);
3331 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3332 res
= scm_call_1 (char_pred
, ch
);
3333 if (scm_is_false (res
))
3334 ls
= scm_cons (ch
, ls
);
3337 result
= scm_reverse_list_to_string (ls
);
3340 scm_remember_upto_here_1 (s
);
3346 scm_init_srfi_13 (void)
3348 #include "libguile/srfi-13.x"
3351 /* End of srfi-13.c. */