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
);
255 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
261 res
= scm_i_make_string (clen
, &nbuf
);
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
);
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{delim} 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
);
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
,
550 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
552 target
= scm_i_string_start_writing (target
);
553 for (i
= 0; i
< cend
- cstart
; i
++)
555 scm_i_string_set_x (target
, ctstart
+ i
,
556 scm_i_string_ref (s
, cstart
+ i
));
558 scm_i_string_stop_writing ();
559 scm_remember_upto_here_1 (target
);
561 return SCM_UNSPECIFIED
;
565 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
566 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
567 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
568 "into @var{str2} beginning at position @var{start2}.\n"
569 "@var{str1} and @var{str2} can be the same string.")
570 #define FUNC_NAME s_scm_substring_move_x
572 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
576 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
578 "Return the @var{n} first characters of @var{s}.")
579 #define FUNC_NAME s_scm_string_take
581 return scm_substring (s
, SCM_INUM0
, n
);
586 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
588 "Return all but the first @var{n} characters of @var{s}.")
589 #define FUNC_NAME s_scm_string_drop
591 return scm_substring (s
, n
, SCM_UNDEFINED
);
596 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
598 "Return the @var{n} last characters of @var{s}.")
599 #define FUNC_NAME s_scm_string_take_right
601 return scm_substring (s
,
602 scm_difference (scm_string_length (s
), n
),
608 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
610 "Return all but the last @var{n} characters of @var{s}.")
611 #define FUNC_NAME s_scm_string_drop_right
613 return scm_substring (s
,
615 scm_difference (scm_string_length (s
), n
));
620 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
621 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
622 "Take that characters from @var{start} to @var{end} from the\n"
623 "string @var{s} and return a new string, right-padded by the\n"
624 "character @var{chr} to length @var{len}. If the resulting\n"
625 "string is longer than @var{len}, it is truncated on the right.")
626 #define FUNC_NAME s_scm_string_pad
628 size_t cstart
, cend
, clen
;
630 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
633 clen
= scm_to_size_t (len
);
635 if (SCM_UNBNDP (chr
))
636 chr
= SCM_MAKE_CHAR (' ');
639 SCM_VALIDATE_CHAR (3, chr
);
641 if (clen
< (cend
- cstart
))
642 return scm_i_substring (s
, cend
- clen
, cend
);
646 result
= (scm_string_append
647 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
648 scm_i_substring (s
, cstart
, cend
))));
655 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
656 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
657 "Take that characters from @var{start} to @var{end} from the\n"
658 "string @var{s} and return a new string, left-padded by the\n"
659 "character @var{chr} to length @var{len}. If the resulting\n"
660 "string is longer than @var{len}, it is truncated on the left.")
661 #define FUNC_NAME s_scm_string_pad_right
663 size_t cstart
, cend
, clen
;
665 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
668 clen
= scm_to_size_t (len
);
670 if (SCM_UNBNDP (chr
))
671 chr
= SCM_MAKE_CHAR (' ');
674 SCM_VALIDATE_CHAR (3, chr
);
676 if (clen
< (cend
- cstart
))
677 return scm_i_substring (s
, cstart
, cstart
+ clen
);
682 result
= (scm_string_append
683 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
684 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
692 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
693 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
694 "Trim @var{s} by skipping over all characters on the left\n"
695 "that satisfy the parameter @var{char_pred}:\n"
699 "if it is the character @var{ch}, characters equal to\n"
700 "@var{ch} are trimmed,\n"
703 "if it is a procedure @var{pred} characters that\n"
704 "satisfy @var{pred} are trimmed,\n"
707 "if it is a character set, characters in that set are trimmed.\n"
710 "If called without a @var{char_pred} argument, all whitespace is\n"
712 #define FUNC_NAME s_scm_string_trim
716 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
719 if (SCM_UNBNDP (char_pred
))
721 while (cstart
< cend
)
723 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
728 else if (SCM_CHARP (char_pred
))
730 while (cstart
< cend
)
732 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
737 else if (SCM_CHARSETP (char_pred
))
739 while (cstart
< cend
)
741 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
748 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
749 char_pred
, SCM_ARG2
, FUNC_NAME
);
751 while (cstart
< cend
)
755 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
756 if (scm_is_false (res
))
761 return scm_i_substring (s
, cstart
, cend
);
766 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
767 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
768 "Trim @var{s} by skipping over all characters on the right\n"
769 "that satisfy the parameter @var{char_pred}:\n"
773 "if it is the character @var{ch}, characters equal to @var{ch}\n"
777 "if it is a procedure @var{pred} characters that satisfy\n"
778 "@var{pred} are trimmed,\n"
781 "if it is a character sets, all characters in that set are\n"
785 "If called without a @var{char_pred} argument, all whitespace is\n"
787 #define FUNC_NAME s_scm_string_trim_right
791 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
794 if (SCM_UNBNDP (char_pred
))
796 while (cstart
< cend
)
798 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
803 else if (SCM_CHARP (char_pred
))
805 while (cstart
< cend
)
807 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
812 else if (SCM_CHARSETP (char_pred
))
814 while (cstart
< cend
)
816 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
823 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
824 char_pred
, SCM_ARG2
, FUNC_NAME
);
826 while (cstart
< cend
)
830 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
831 if (scm_is_false (res
))
836 return scm_i_substring (s
, cstart
, cend
);
841 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
842 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
843 "Trim @var{s} by skipping over all characters on both sides of\n"
844 "the string that satisfy the parameter @var{char_pred}:\n"
848 "if it is the character @var{ch}, characters equal to @var{ch}\n"
852 "if it is a procedure @var{pred} characters that satisfy\n"
853 "@var{pred} are trimmed,\n"
856 "if it is a character set, the characters in the set are\n"
860 "If called without a @var{char_pred} argument, all whitespace is\n"
862 #define FUNC_NAME s_scm_string_trim_both
866 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
869 if (SCM_UNBNDP (char_pred
))
871 while (cstart
< cend
)
873 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
877 while (cstart
< cend
)
879 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
884 else if (SCM_CHARP (char_pred
))
886 while (cstart
< cend
)
888 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
892 while (cstart
< cend
)
894 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
899 else if (SCM_CHARSETP (char_pred
))
901 while (cstart
< cend
)
903 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
907 while (cstart
< cend
)
909 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
916 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
917 char_pred
, SCM_ARG2
, FUNC_NAME
);
919 while (cstart
< cend
)
923 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
924 if (scm_is_false (res
))
928 while (cstart
< cend
)
932 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
933 if (scm_is_false (res
))
938 return scm_i_substring (s
, cstart
, cend
);
943 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
944 (SCM str
, SCM chr
, SCM start
, SCM end
),
945 "Stores @var{chr} in every element of the given @var{str} and\n"
946 "returns an unspecified value.")
947 #define FUNC_NAME s_scm_substring_fill_x
952 /* Older versions of Guile provided the function
953 scm_substring_fill_x with the following order of arguments:
957 We accomodate this here by detecting such a usage and reordering
968 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
971 SCM_VALIDATE_CHAR (2, chr
);
974 str
= scm_i_string_start_writing (str
);
975 for (k
= cstart
; k
< cend
; k
++)
976 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
977 scm_i_string_stop_writing ();
979 return SCM_UNSPECIFIED
;
984 scm_string_fill_x (SCM str
, SCM chr
)
986 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
989 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
990 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
991 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
992 "mismatch index, depending upon whether @var{s1} is less than,\n"
993 "equal to, or greater than @var{s2}. The mismatch index is the\n"
994 "largest index @var{i} such that for every 0 <= @var{j} <\n"
995 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
996 "@var{i} is the first position that does not match.")
997 #define FUNC_NAME s_scm_string_compare
999 size_t cstart1
, cend1
, cstart2
, cend2
;
1002 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1005 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1008 SCM_VALIDATE_PROC (3, proc_lt
);
1009 SCM_VALIDATE_PROC (4, proc_eq
);
1010 SCM_VALIDATE_PROC (5, proc_gt
);
1012 while (cstart1
< cend1
&& cstart2
< cend2
)
1014 if (scm_i_string_ref (s1
, cstart1
)
1015 < scm_i_string_ref (s2
, cstart2
))
1020 else if (scm_i_string_ref (s1
, cstart1
)
1021 > scm_i_string_ref (s2
, cstart2
))
1029 if (cstart1
< cend1
)
1031 else if (cstart2
< cend2
)
1037 scm_remember_upto_here_2 (s1
, s2
);
1038 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1043 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1044 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1045 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1046 "mismatch index, depending upon whether @var{s1} is less than,\n"
1047 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1048 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1049 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1050 "@var{i} is the first position where the lowercased letters \n"
1052 #define FUNC_NAME s_scm_string_compare_ci
1054 size_t cstart1
, cend1
, cstart2
, cend2
;
1057 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1060 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1063 SCM_VALIDATE_PROC (3, proc_lt
);
1064 SCM_VALIDATE_PROC (4, proc_eq
);
1065 SCM_VALIDATE_PROC (5, proc_gt
);
1067 while (cstart1
< cend1
&& cstart2
< cend2
)
1069 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1070 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1075 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1076 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1085 if (cstart1
< cend1
)
1087 else if (cstart2
< cend2
)
1093 scm_remember_upto_here (s1
, s2
);
1094 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1098 /* This function compares two substrings, S1 from START1 to END1 and
1099 S2 from START2 to END2, possibly case insensitively, and returns
1100 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1101 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1102 longer, or equal. */
1104 compare_strings (const char *fname
, int case_insensitive
,
1105 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1106 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1108 size_t cstart1
, cend1
, cstart2
, cend2
;
1112 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1115 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1119 while (cstart1
< cend1
&& cstart2
< cend2
)
1121 if (case_insensitive
)
1123 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1124 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1128 a
= scm_i_string_ref (s1
, cstart1
);
1129 b
= scm_i_string_ref (s2
, cstart2
);
1144 if (cstart1
< cend1
)
1149 else if (cstart2
< cend2
)
1161 scm_remember_upto_here_2 (s1
, s2
);
1166 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1167 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1168 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1170 #define FUNC_NAME s_scm_string_eq
1172 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1173 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1174 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1175 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1177 /* Fast path for this common case, which avoids the repeated calls to
1178 `scm_i_string_ref'. */
1181 len1
= scm_i_string_length (s1
);
1182 len2
= scm_i_string_length (s2
);
1184 if (SCM_LIKELY (len1
== len2
))
1186 if (!scm_i_is_narrow_string (s1
))
1189 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1190 scm_i_string_data (s2
),
1195 return compare_strings (FUNC_NAME
, 0,
1196 s1
, s2
, start1
, end1
, start2
, end2
,
1197 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1202 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1203 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1204 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1206 #define FUNC_NAME s_scm_string_neq
1208 return compare_strings (FUNC_NAME
, 0,
1209 s1
, s2
, start1
, end1
, start2
, end2
,
1210 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1215 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1216 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1217 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1218 "true value otherwise.")
1219 #define FUNC_NAME s_scm_string_lt
1221 return compare_strings (FUNC_NAME
, 0,
1222 s1
, s2
, start1
, end1
, start2
, end2
,
1223 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1228 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1229 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1230 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1231 "true value otherwise.")
1232 #define FUNC_NAME s_scm_string_gt
1234 return compare_strings (FUNC_NAME
, 0,
1235 s1
, s2
, start1
, end1
, start2
, end2
,
1236 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1241 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1242 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1243 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1245 #define FUNC_NAME s_scm_string_le
1247 return compare_strings (FUNC_NAME
, 0,
1248 s1
, s2
, start1
, end1
, start2
, end2
,
1249 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1254 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1255 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1256 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1258 #define FUNC_NAME s_scm_string_ge
1260 return compare_strings (FUNC_NAME
, 0,
1261 s1
, s2
, start1
, end1
, start2
, end2
,
1262 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1267 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1268 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1269 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1270 "value otherwise. The character comparison is done\n"
1271 "case-insensitively.")
1272 #define FUNC_NAME s_scm_string_ci_eq
1274 return compare_strings (FUNC_NAME
, 1,
1275 s1
, s2
, start1
, end1
, start2
, end2
,
1276 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1281 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1282 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1283 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1284 "value otherwise. The character comparison is done\n"
1285 "case-insensitively.")
1286 #define FUNC_NAME s_scm_string_ci_neq
1288 return compare_strings (FUNC_NAME
, 1,
1289 s1
, s2
, start1
, end1
, start2
, end2
,
1290 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1295 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1296 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1297 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1298 "true value otherwise. The character comparison is done\n"
1299 "case-insensitively.")
1300 #define FUNC_NAME s_scm_string_ci_lt
1302 return compare_strings (FUNC_NAME
, 1,
1303 s1
, s2
, start1
, end1
, start2
, end2
,
1304 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1309 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1310 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1311 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1312 "true value otherwise. The character comparison is done\n"
1313 "case-insensitively.")
1314 #define FUNC_NAME s_scm_string_ci_gt
1316 return compare_strings (FUNC_NAME
, 1,
1317 s1
, s2
, start1
, end1
, start2
, end2
,
1318 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1323 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1324 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1325 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1326 "value otherwise. The character comparison is done\n"
1327 "case-insensitively.")
1328 #define FUNC_NAME s_scm_string_ci_le
1330 return compare_strings (FUNC_NAME
, 1,
1331 s1
, s2
, start1
, end1
, start2
, end2
,
1332 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1337 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1338 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1339 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1340 "otherwise. The character comparison is done\n"
1341 "case-insensitively.")
1342 #define FUNC_NAME s_scm_string_ci_ge
1344 return compare_strings (FUNC_NAME
, 1,
1345 s1
, s2
, start1
, end1
, start2
, end2
,
1346 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1350 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1351 (SCM s
, SCM bound
, SCM start
, SCM end
),
1352 "Compute a hash value for @var{S}. the optional argument "
1353 "@var{bound} is a non-negative exact "
1354 "integer specifying the range of the hash function. "
1355 "A positive value restricts the return value to the "
1357 #define FUNC_NAME s_scm_substring_hash
1359 if (SCM_UNBNDP (bound
))
1360 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1361 if (SCM_UNBNDP (start
))
1363 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1367 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1368 (SCM s
, SCM bound
, SCM start
, SCM end
),
1369 "Compute a hash value for @var{S}. the optional argument "
1370 "@var{bound} is a non-negative exact "
1371 "integer specifying the range of the hash function. "
1372 "A positive value restricts the return value to the "
1374 #define FUNC_NAME s_scm_substring_hash_ci
1376 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1378 SCM_UNDEFINED
, SCM_UNDEFINED
);
1382 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1383 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1384 "Return the length of the longest common prefix of the two\n"
1386 #define FUNC_NAME s_scm_string_prefix_length
1388 size_t cstart1
, cend1
, cstart2
, cend2
;
1391 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1394 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1398 while (cstart1
< cend1
&& cstart2
< cend2
)
1400 if (scm_i_string_ref (s1
, cstart1
)
1401 != scm_i_string_ref (s2
, cstart2
))
1409 scm_remember_upto_here_2 (s1
, s2
);
1410 return scm_from_size_t (len
);
1415 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1416 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1417 "Return the length of the longest common prefix of the two\n"
1418 "strings, ignoring character case.")
1419 #define FUNC_NAME s_scm_string_prefix_length_ci
1421 size_t cstart1
, cend1
, cstart2
, cend2
;
1424 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1427 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1430 while (cstart1
< cend1
&& cstart2
< cend2
)
1432 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1433 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1441 scm_remember_upto_here_2 (s1
, s2
);
1442 return scm_from_size_t (len
);
1447 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1448 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1449 "Return the length of the longest common suffix of the two\n"
1451 #define FUNC_NAME s_scm_string_suffix_length
1453 size_t cstart1
, cend1
, cstart2
, cend2
;
1456 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1459 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1462 while (cstart1
< cend1
&& cstart2
< cend2
)
1466 if (scm_i_string_ref (s1
, cend1
)
1467 != scm_i_string_ref (s2
, cend2
))
1473 scm_remember_upto_here_2 (s1
, s2
);
1474 return scm_from_size_t (len
);
1479 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1480 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1481 "Return the length of the longest common suffix of the two\n"
1482 "strings, ignoring character case.")
1483 #define FUNC_NAME s_scm_string_suffix_length_ci
1485 size_t cstart1
, cend1
, cstart2
, cend2
;
1488 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1491 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1494 while (cstart1
< cend1
&& cstart2
< cend2
)
1498 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1499 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1505 scm_remember_upto_here_2 (s1
, s2
);
1506 return scm_from_size_t (len
);
1511 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1512 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1513 "Is @var{s1} a prefix of @var{s2}?")
1514 #define FUNC_NAME s_scm_string_prefix_p
1516 size_t cstart1
, cend1
, cstart2
, cend2
;
1517 size_t len
= 0, len1
;
1519 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1522 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1525 len1
= cend1
- cstart1
;
1526 while (cstart1
< cend1
&& cstart2
< cend2
)
1528 if (scm_i_string_ref (s1
, cstart1
)
1529 != scm_i_string_ref (s2
, cstart2
))
1537 scm_remember_upto_here_2 (s1
, s2
);
1538 return scm_from_bool (len
== len1
);
1543 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1544 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1545 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1546 #define FUNC_NAME s_scm_string_prefix_ci_p
1548 size_t cstart1
, cend1
, cstart2
, cend2
;
1549 size_t len
= 0, len1
;
1551 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1554 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1557 len1
= cend1
- cstart1
;
1558 while (cstart1
< cend1
&& cstart2
< cend2
)
1560 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1561 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1570 scm_remember_upto_here_2 (s1
, s2
);
1571 return scm_from_bool (len
== len1
);
1576 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1577 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1578 "Is @var{s1} a suffix of @var{s2}?")
1579 #define FUNC_NAME s_scm_string_suffix_p
1581 size_t cstart1
, cend1
, cstart2
, cend2
;
1582 size_t len
= 0, len1
;
1584 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1587 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1590 len1
= cend1
- cstart1
;
1591 while (cstart1
< cend1
&& cstart2
< cend2
)
1595 if (scm_i_string_ref (s1
, cend1
)
1596 != scm_i_string_ref (s2
, cend2
))
1602 scm_remember_upto_here_2 (s1
, s2
);
1603 return scm_from_bool (len
== len1
);
1608 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1609 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1610 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1611 #define FUNC_NAME s_scm_string_suffix_ci_p
1613 size_t cstart1
, cend1
, cstart2
, cend2
;
1614 size_t len
= 0, len1
;
1616 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1619 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1622 len1
= cend1
- cstart1
;
1623 while (cstart1
< cend1
&& cstart2
< cend2
)
1627 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1628 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1634 scm_remember_upto_here_2 (s1
, s2
);
1635 return scm_from_bool (len
== len1
);
1640 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1641 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1642 "Search through the string @var{s} from left to right, returning\n"
1643 "the index of the first occurrence of a character which\n"
1645 "@itemize @bullet\n"
1647 "equals @var{char_pred}, if it is character,\n"
1650 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1653 "is in the set @var{char_pred}, if it is a character set.\n"
1655 "Return @code{#f} if no match is found.")
1656 #define FUNC_NAME s_scm_string_index
1658 size_t cstart
, cend
;
1660 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1663 if (SCM_CHARP (char_pred
))
1665 while (cstart
< cend
)
1667 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1672 else if (SCM_CHARSETP (char_pred
))
1674 while (cstart
< cend
)
1676 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1683 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1684 char_pred
, SCM_ARG2
, FUNC_NAME
);
1686 while (cstart
< cend
)
1689 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1690 if (scm_is_true (res
))
1696 scm_remember_upto_here_1 (s
);
1700 scm_remember_upto_here_1 (s
);
1701 return scm_from_size_t (cstart
);
1705 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1706 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1707 "Search through the string @var{s} from right to left, returning\n"
1708 "the index of the last occurrence of a character which\n"
1710 "@itemize @bullet\n"
1712 "equals @var{char_pred}, if it is character,\n"
1715 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1718 "is in the set if @var{char_pred} is a character set.\n"
1720 "Return @code{#f} if no match is found.")
1721 #define FUNC_NAME s_scm_string_index_right
1723 size_t cstart
, cend
;
1725 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1728 if (SCM_CHARP (char_pred
))
1730 while (cstart
< cend
)
1733 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1737 else if (SCM_CHARSETP (char_pred
))
1739 while (cstart
< cend
)
1742 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1748 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1749 char_pred
, SCM_ARG2
, FUNC_NAME
);
1751 while (cstart
< cend
)
1755 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1756 if (scm_is_true (res
))
1761 scm_remember_upto_here_1 (s
);
1765 scm_remember_upto_here_1 (s
);
1766 return scm_from_size_t (cend
);
1770 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1771 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1772 "Search through the string @var{s} from right to left, returning\n"
1773 "the index of the last occurrence of a character which\n"
1775 "@itemize @bullet\n"
1777 "equals @var{char_pred}, if it is character,\n"
1780 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1783 "is in the set if @var{char_pred} is a character set.\n"
1785 "Return @code{#f} if no match is found.")
1786 #define FUNC_NAME s_scm_string_rindex
1788 return scm_string_index_right (s
, char_pred
, start
, end
);
1792 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1793 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1794 "Search through the string @var{s} from left to right, returning\n"
1795 "the index of the first occurrence of a character which\n"
1797 "@itemize @bullet\n"
1799 "does not equal @var{char_pred}, if it is character,\n"
1802 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1806 "is not in the set if @var{char_pred} is a character set.\n"
1808 #define FUNC_NAME s_scm_string_skip
1810 size_t cstart
, cend
;
1812 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1815 if (SCM_CHARP (char_pred
))
1817 while (cstart
< cend
)
1819 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1824 else if (SCM_CHARSETP (char_pred
))
1826 while (cstart
< cend
)
1828 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1835 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1836 char_pred
, SCM_ARG2
, FUNC_NAME
);
1838 while (cstart
< cend
)
1841 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1842 if (scm_is_false (res
))
1848 scm_remember_upto_here_1 (s
);
1852 scm_remember_upto_here_1 (s
);
1853 return scm_from_size_t (cstart
);
1858 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1859 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1860 "Search through the string @var{s} from right to left, returning\n"
1861 "the index of the last occurrence of a character which\n"
1863 "@itemize @bullet\n"
1865 "does not equal @var{char_pred}, if it is character,\n"
1868 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1872 "is not in the set if @var{char_pred} is a character set.\n"
1874 #define FUNC_NAME s_scm_string_skip_right
1876 size_t cstart
, cend
;
1878 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1881 if (SCM_CHARP (char_pred
))
1883 while (cstart
< cend
)
1886 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1890 else if (SCM_CHARSETP (char_pred
))
1892 while (cstart
< cend
)
1895 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1901 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1902 char_pred
, SCM_ARG2
, FUNC_NAME
);
1904 while (cstart
< cend
)
1908 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1909 if (scm_is_false (res
))
1914 scm_remember_upto_here_1 (s
);
1918 scm_remember_upto_here_1 (s
);
1919 return scm_from_size_t (cend
);
1925 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1926 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1927 "Return the count of the number of characters in the string\n"
1930 "@itemize @bullet\n"
1932 "equals @var{char_pred}, if it is character,\n"
1935 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1938 "is in the set @var{char_pred}, if it is a character set.\n"
1940 #define FUNC_NAME s_scm_string_count
1942 size_t cstart
, cend
;
1945 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1948 if (SCM_CHARP (char_pred
))
1950 while (cstart
< cend
)
1952 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1957 else if (SCM_CHARSETP (char_pred
))
1959 while (cstart
< cend
)
1961 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1968 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1969 char_pred
, SCM_ARG2
, FUNC_NAME
);
1971 while (cstart
< cend
)
1974 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1975 if (scm_is_true (res
))
1981 scm_remember_upto_here_1 (s
);
1982 return scm_from_size_t (count
);
1987 /* FIXME::martin: This should definitely get implemented more
1988 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1990 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1991 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1992 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1993 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1994 "The optional start/end indices restrict the operation to the\n"
1995 "indicated substrings.")
1996 #define FUNC_NAME s_scm_string_contains
1998 size_t cstart1
, cend1
, cstart2
, cend2
;
2001 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2004 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2007 len2
= cend2
- cstart2
;
2008 if (cend1
- cstart1
>= len2
)
2009 while (cstart1
<= cend1
- len2
)
2015 && (scm_i_string_ref (s1
, i
)
2016 == scm_i_string_ref (s2
, j
)))
2023 scm_remember_upto_here_2 (s1
, s2
);
2024 return scm_from_size_t (cstart1
);
2029 scm_remember_upto_here_2 (s1
, s2
);
2035 /* FIXME::martin: This should definitely get implemented more
2036 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2038 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2039 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2040 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2041 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2042 "The optional start/end indices restrict the operation to the\n"
2043 "indicated substrings. Character comparison is done\n"
2044 "case-insensitively.")
2045 #define FUNC_NAME s_scm_string_contains_ci
2047 size_t cstart1
, cend1
, cstart2
, cend2
;
2050 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2053 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2056 len2
= cend2
- cstart2
;
2057 if (cend1
- cstart1
>= len2
)
2058 while (cstart1
<= cend1
- len2
)
2064 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2065 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2072 scm_remember_upto_here_2 (s1
, s2
);
2073 return scm_from_size_t (cstart1
);
2078 scm_remember_upto_here_2 (s1
, s2
);
2084 /* Helper function for the string uppercase conversion functions. */
2086 string_upcase_x (SCM v
, size_t start
, size_t end
)
2090 v
= scm_i_string_start_writing (v
);
2091 for (k
= start
; k
< end
; ++k
)
2092 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2093 scm_i_string_stop_writing ();
2094 scm_remember_upto_here_1 (v
);
2099 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2100 (SCM str
, SCM start
, SCM end
),
2101 "Destructively upcase every character in @code{str}.\n"
2104 "(string-upcase! y)\n"
2105 "@result{} \"ARRDEFG\"\n"
2107 "@result{} \"ARRDEFG\"\n"
2109 #define FUNC_NAME s_scm_substring_upcase_x
2111 size_t cstart
, cend
;
2113 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2116 return string_upcase_x (str
, cstart
, cend
);
2121 scm_string_upcase_x (SCM str
)
2123 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2126 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2127 (SCM str
, SCM start
, SCM end
),
2128 "Upcase every character in @code{str}.")
2129 #define FUNC_NAME s_scm_substring_upcase
2131 size_t cstart
, cend
;
2133 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2136 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2141 scm_string_upcase (SCM str
)
2143 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2146 /* Helper function for the string lowercase conversion functions.
2147 * No argument checking is performed. */
2149 string_downcase_x (SCM v
, size_t start
, size_t end
)
2153 v
= scm_i_string_start_writing (v
);
2154 for (k
= start
; k
< end
; ++k
)
2155 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2156 scm_i_string_stop_writing ();
2157 scm_remember_upto_here_1 (v
);
2162 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2163 (SCM str
, SCM start
, SCM end
),
2164 "Destructively downcase every character in @var{str}.\n"
2168 "@result{} \"ARRDEFG\"\n"
2169 "(string-downcase! y)\n"
2170 "@result{} \"arrdefg\"\n"
2172 "@result{} \"arrdefg\"\n"
2174 #define FUNC_NAME s_scm_substring_downcase_x
2176 size_t cstart
, cend
;
2178 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2181 return string_downcase_x (str
, cstart
, cend
);
2186 scm_string_downcase_x (SCM str
)
2188 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2191 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2192 (SCM str
, SCM start
, SCM end
),
2193 "Downcase every character in @var{str}.")
2194 #define FUNC_NAME s_scm_substring_downcase
2196 size_t cstart
, cend
;
2198 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2201 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2206 scm_string_downcase (SCM str
)
2208 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2211 /* Helper function for the string capitalization functions.
2212 * No argument checking is performed. */
2214 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2220 str
= scm_i_string_start_writing (str
);
2221 for(i
= start
; i
< end
; i
++)
2223 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2224 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2228 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2233 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2239 scm_i_string_stop_writing ();
2240 scm_remember_upto_here_1 (str
);
2246 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2247 (SCM str
, SCM start
, SCM end
),
2248 "Destructively titlecase every first character in a word in\n"
2250 #define FUNC_NAME s_scm_string_titlecase_x
2252 size_t cstart
, cend
;
2254 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2257 return string_titlecase_x (str
, cstart
, cend
);
2262 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2263 (SCM str
, SCM start
, SCM end
),
2264 "Titlecase every first character in a word in @var{str}.")
2265 #define FUNC_NAME s_scm_string_titlecase
2267 size_t cstart
, cend
;
2269 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2272 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2276 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2278 "Upcase the first character of every word in @var{str}\n"
2279 "destructively and return @var{str}.\n"
2282 "y @result{} \"hello world\"\n"
2283 "(string-capitalize! y) @result{} \"Hello World\"\n"
2284 "y @result{} \"Hello World\"\n"
2286 #define FUNC_NAME s_scm_string_capitalize_x
2288 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2293 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2295 "Return a freshly allocated string with the characters in\n"
2296 "@var{str}, where the first character of every word is\n"
2298 #define FUNC_NAME s_scm_string_capitalize
2300 return scm_string_capitalize_x (scm_string_copy (str
));
2305 /* Reverse the portion of @var{str} between str[cstart] (including)
2306 and str[cend] excluding. */
2308 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2312 str
= scm_i_string_start_writing (str
);
2316 while (cstart
< cend
)
2318 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2319 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2320 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2325 scm_i_string_stop_writing ();
2329 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2330 (SCM str
, SCM start
, SCM end
),
2331 "Reverse the string @var{str}. The optional arguments\n"
2332 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2334 #define FUNC_NAME s_scm_string_reverse
2336 size_t cstart
, cend
;
2339 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2342 result
= scm_string_copy (str
);
2343 string_reverse_x (result
, cstart
, cend
);
2344 scm_remember_upto_here_1 (str
);
2350 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2351 (SCM str
, SCM start
, SCM end
),
2352 "Reverse the string @var{str} in-place. The optional arguments\n"
2353 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2354 "operate on. The return value is unspecified.")
2355 #define FUNC_NAME s_scm_string_reverse_x
2357 size_t cstart
, cend
;
2359 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2363 string_reverse_x (str
, cstart
, cend
);
2364 scm_remember_upto_here_1 (str
);
2365 return SCM_UNSPECIFIED
;
2370 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2372 "Like @code{string-append}, but the result may share memory\n"
2373 "with the argument strings.")
2374 #define FUNC_NAME s_scm_string_append_shared
2376 /* If "rest" contains just one non-empty string, return that.
2377 If it's entirely empty strings, then return scm_nullstr.
2378 Otherwise use scm_string_concatenate. */
2380 SCM ret
= scm_nullstr
;
2381 int seen_nonempty
= 0;
2384 SCM_VALIDATE_REST_ARGUMENT (rest
);
2386 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2389 if (!scm_is_string (s
))
2390 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2391 if (scm_i_string_length (s
) != 0)
2394 /* two or more non-empty strings, need full concat */
2395 return scm_string_append (rest
);
2406 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2408 "Append the elements of @var{ls} (which must be strings)\n"
2409 "together into a single string. Guaranteed to return a freshly\n"
2410 "allocated string.")
2411 #define FUNC_NAME s_scm_string_concatenate
2413 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2414 return scm_string_append (ls
);
2419 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2420 (SCM ls
, SCM final_string
, SCM end
),
2421 "Without optional arguments, this procedure is equivalent to\n"
2424 "(string-concatenate (reverse ls))\n"
2427 "If the optional argument @var{final_string} is specified, it is\n"
2428 "consed onto the beginning to @var{ls} before performing the\n"
2429 "list-reverse and string-concatenate operations. If @var{end}\n"
2430 "is given, only the characters of @var{final_string} up to index\n"
2431 "@var{end} are used.\n"
2433 "Guaranteed to return a freshly allocated string.")
2434 #define FUNC_NAME s_scm_string_concatenate_reverse
2436 if (!SCM_UNBNDP (end
))
2437 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2439 if (!SCM_UNBNDP (final_string
))
2440 ls
= scm_cons (final_string
, ls
);
2442 return scm_string_concatenate (scm_reverse (ls
));
2447 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2449 "Like @code{string-concatenate}, but the result may share memory\n"
2450 "with the strings in the list @var{ls}.")
2451 #define FUNC_NAME s_scm_string_concatenate_shared
2453 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2454 return scm_string_append_shared (ls
);
2459 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2460 (SCM ls
, SCM final_string
, SCM end
),
2461 "Like @code{string-concatenate-reverse}, but the result may\n"
2462 "share memory with the strings in the @var{ls} arguments.")
2463 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2465 /* Just call the non-sharing version. */
2466 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2471 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2472 (SCM proc
, SCM s
, SCM start
, SCM end
),
2473 "@var{proc} is a char->char procedure, it is mapped over\n"
2474 "@var{s}. The order in which the procedure is applied to the\n"
2475 "string elements is not specified.")
2476 #define FUNC_NAME s_scm_string_map
2479 size_t cstart
, cend
;
2482 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2483 proc
, SCM_ARG1
, FUNC_NAME
);
2484 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2487 result
= scm_i_make_string (cend
- cstart
, NULL
);
2489 while (cstart
< cend
)
2491 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2492 if (!SCM_CHARP (ch
))
2493 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2495 result
= scm_i_string_start_writing (result
);
2496 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2497 scm_i_string_stop_writing ();
2506 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2507 (SCM proc
, SCM s
, SCM start
, SCM end
),
2508 "@var{proc} is a char->char procedure, it is mapped over\n"
2509 "@var{s}. The order in which the procedure is applied to the\n"
2510 "string elements is not specified. The string @var{s} is\n"
2511 "modified in-place, the return value is not specified.")
2512 #define FUNC_NAME s_scm_string_map_x
2514 size_t cstart
, cend
;
2516 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2517 proc
, SCM_ARG1
, FUNC_NAME
);
2518 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2521 while (cstart
< cend
)
2523 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2524 if (!SCM_CHARP (ch
))
2525 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2526 s
= scm_i_string_start_writing (s
);
2527 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2528 scm_i_string_stop_writing ();
2531 return SCM_UNSPECIFIED
;
2536 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2537 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2538 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2539 "as the terminating element, from left to right. @var{kons}\n"
2540 "must expect two arguments: The actual character and the last\n"
2541 "result of @var{kons}' application.")
2542 #define FUNC_NAME s_scm_string_fold
2544 size_t cstart
, cend
;
2547 SCM_VALIDATE_PROC (1, kons
);
2548 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2552 while (cstart
< cend
)
2554 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2558 scm_remember_upto_here_1 (s
);
2564 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2565 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2566 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2567 "as the terminating element, from right to left. @var{kons}\n"
2568 "must expect two arguments: The actual character and the last\n"
2569 "result of @var{kons}' application.")
2570 #define FUNC_NAME s_scm_string_fold_right
2572 size_t cstart
, cend
;
2575 SCM_VALIDATE_PROC (1, kons
);
2576 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2580 while (cstart
< cend
)
2582 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2586 scm_remember_upto_here_1 (s
);
2592 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2593 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2594 "@itemize @bullet\n"
2595 "@item @var{g} is used to generate a series of @emph{seed}\n"
2596 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2597 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2599 "@item @var{p} tells us when to stop -- when it returns true\n"
2600 "when applied to one of these seed values.\n"
2601 "@item @var{f} maps each seed value to the corresponding\n"
2602 "character in the result string. These chars are assembled\n"
2603 "into the string in a left-to-right order.\n"
2604 "@item @var{base} is the optional initial/leftmost portion\n"
2605 "of the constructed string; it default to the empty\n"
2607 "@item @var{make_final} is applied to the terminal seed\n"
2608 "value (on which @var{p} returns true) to produce\n"
2609 "the final/rightmost portion of the constructed string.\n"
2610 "It defaults to @code{(lambda (x) "")}.\n"
2612 #define FUNC_NAME s_scm_string_unfold
2616 SCM_VALIDATE_PROC (1, p
);
2617 SCM_VALIDATE_PROC (2, f
);
2618 SCM_VALIDATE_PROC (3, g
);
2619 if (!SCM_UNBNDP (base
))
2621 SCM_VALIDATE_STRING (5, base
);
2625 ans
= scm_i_make_string (0, NULL
);
2626 if (!SCM_UNBNDP (make_final
))
2627 SCM_VALIDATE_PROC (6, make_final
);
2629 res
= scm_call_1 (p
, seed
);
2630 while (scm_is_false (res
))
2634 SCM ch
= scm_call_1 (f
, seed
);
2635 if (!SCM_CHARP (ch
))
2636 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2637 str
= scm_i_make_string (1, NULL
);
2638 str
= scm_i_string_start_writing (str
);
2639 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2640 scm_i_string_stop_writing ();
2643 ans
= scm_string_append (scm_list_2 (ans
, str
));
2644 seed
= scm_call_1 (g
, seed
);
2645 res
= scm_call_1 (p
, seed
);
2647 if (!SCM_UNBNDP (make_final
))
2649 res
= scm_call_1 (make_final
, seed
);
2650 return scm_string_append (scm_list_2 (ans
, res
));
2658 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2659 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2660 "@itemize @bullet\n"
2661 "@item @var{g} is used to generate a series of @emph{seed}\n"
2662 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2663 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2665 "@item @var{p} tells us when to stop -- when it returns true\n"
2666 "when applied to one of these seed values.\n"
2667 "@item @var{f} maps each seed value to the corresponding\n"
2668 "character in the result string. These chars are assembled\n"
2669 "into the string in a right-to-left order.\n"
2670 "@item @var{base} is the optional initial/rightmost portion\n"
2671 "of the constructed string; it default to the empty\n"
2673 "@item @var{make_final} is applied to the terminal seed\n"
2674 "value (on which @var{p} returns true) to produce\n"
2675 "the final/leftmost portion of the constructed string.\n"
2676 "It defaults to @code{(lambda (x) "")}.\n"
2678 #define FUNC_NAME s_scm_string_unfold_right
2682 SCM_VALIDATE_PROC (1, p
);
2683 SCM_VALIDATE_PROC (2, f
);
2684 SCM_VALIDATE_PROC (3, g
);
2685 if (!SCM_UNBNDP (base
))
2687 SCM_VALIDATE_STRING (5, base
);
2691 ans
= scm_i_make_string (0, NULL
);
2692 if (!SCM_UNBNDP (make_final
))
2693 SCM_VALIDATE_PROC (6, make_final
);
2695 res
= scm_call_1 (p
, seed
);
2696 while (scm_is_false (res
))
2700 SCM ch
= scm_call_1 (f
, seed
);
2701 if (!SCM_CHARP (ch
))
2702 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2703 str
= scm_i_make_string (1, NULL
);
2704 str
= scm_i_string_start_writing (str
);
2705 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2706 scm_i_string_stop_writing ();
2709 ans
= scm_string_append (scm_list_2 (str
, ans
));
2710 seed
= scm_call_1 (g
, seed
);
2711 res
= scm_call_1 (p
, seed
);
2713 if (!SCM_UNBNDP (make_final
))
2715 res
= scm_call_1 (make_final
, seed
);
2716 return scm_string_append (scm_list_2 (res
, ans
));
2724 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2725 (SCM proc
, SCM s
, SCM start
, SCM end
),
2726 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2727 "return value is not specified.")
2728 #define FUNC_NAME s_scm_string_for_each
2730 size_t cstart
, cend
;
2732 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2733 proc
, SCM_ARG1
, FUNC_NAME
);
2734 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2737 while (cstart
< cend
)
2739 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2743 scm_remember_upto_here_1 (s
);
2744 return SCM_UNSPECIFIED
;
2748 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2749 (SCM proc
, SCM s
, SCM start
, SCM end
),
2750 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2753 "For example, to change characters to alternately upper and\n"
2757 "(define str (string-copy \"studly\"))\n"
2758 "(string-for-each-index\n"
2760 " (string-set! str i\n"
2761 " ((if (even? i) char-upcase char-downcase)\n"
2762 " (string-ref str i))))\n"
2764 "str @result{} \"StUdLy\"\n"
2766 #define FUNC_NAME s_scm_string_for_each_index
2768 size_t cstart
, cend
;
2770 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2771 proc
, SCM_ARG1
, FUNC_NAME
);
2772 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2776 while (cstart
< cend
)
2778 scm_call_1 (proc
, scm_from_size_t (cstart
));
2782 scm_remember_upto_here_1 (s
);
2783 return SCM_UNSPECIFIED
;
2787 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2788 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2789 "This is the @emph{extended substring} procedure that implements\n"
2790 "replicated copying of a substring of some string.\n"
2792 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2793 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2794 "0 and the length of @var{s}. Replicate this substring up and\n"
2795 "down index space, in both the positive and negative directions.\n"
2796 "@code{xsubstring} returns the substring of this string\n"
2797 "beginning at index @var{from}, and ending at @var{to}, which\n"
2798 "defaults to @var{from} + (@var{end} - @var{start}).")
2799 #define FUNC_NAME s_scm_xsubstring
2802 size_t cstart
, cend
;
2806 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2810 cfrom
= scm_to_int (from
);
2811 if (SCM_UNBNDP (to
))
2812 cto
= cfrom
+ (cend
- cstart
);
2814 cto
= scm_to_int (to
);
2815 if (cstart
== cend
&& cfrom
!= cto
)
2816 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2818 result
= scm_i_make_string (cto
- cfrom
, NULL
);
2819 result
= scm_i_string_start_writing (result
);
2824 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2826 scm_i_string_set_x (result
, p
,
2827 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2829 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2833 scm_i_string_stop_writing ();
2835 scm_remember_upto_here_1 (s
);
2841 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2842 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2843 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2844 "is written into the string @var{target} starting at index\n"
2845 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2846 "@var{target} @var{s})} or these arguments share storage -- you\n"
2847 "cannot copy a string on top of itself.")
2848 #define FUNC_NAME s_scm_string_xcopy_x
2851 size_t ctstart
, cstart
, cend
;
2853 SCM dummy
= SCM_UNDEFINED
;
2856 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2859 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2862 csfrom
= scm_to_int (sfrom
);
2863 if (SCM_UNBNDP (sto
))
2864 csto
= csfrom
+ (cend
- cstart
);
2866 csto
= scm_to_int (sto
);
2867 if (cstart
== cend
&& csfrom
!= csto
)
2868 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2869 SCM_ASSERT_RANGE (1, tstart
,
2870 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2873 target
= scm_i_string_start_writing (target
);
2874 while (csfrom
< csto
)
2876 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2878 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2880 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2884 scm_i_string_stop_writing ();
2886 scm_remember_upto_here_2 (target
, s
);
2887 return SCM_UNSPECIFIED
;
2892 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2893 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2894 "Return the string @var{s1}, but with the characters\n"
2895 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2896 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2897 #define FUNC_NAME s_scm_string_replace
2899 size_t cstart1
, cend1
, cstart2
, cend2
;
2902 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2905 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2908 return (scm_string_append
2909 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2910 scm_i_substring (s2
, cstart2
, cend2
),
2911 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2917 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2918 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2919 "Split the string @var{s} into a list of substrings, where each\n"
2920 "substring is a maximal non-empty contiguous sequence of\n"
2921 "characters from the character set @var{token_set}, which\n"
2922 "defaults to @code{char-set:graphic}.\n"
2923 "If @var{start} or @var{end} indices are provided, they restrict\n"
2924 "@code{string-tokenize} to operating on the indicated substring\n"
2926 #define FUNC_NAME s_scm_string_tokenize
2928 size_t cstart
, cend
;
2929 SCM result
= SCM_EOL
;
2931 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2935 if (SCM_UNBNDP (token_set
))
2936 token_set
= scm_char_set_graphic
;
2938 if (SCM_CHARSETP (token_set
))
2942 while (cstart
< cend
)
2944 while (cstart
< cend
)
2946 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2953 while (cstart
< cend
)
2955 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2959 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2963 SCM_WRONG_TYPE_ARG (2, token_set
);
2965 scm_remember_upto_here_1 (s
);
2970 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2972 "Split the string @var{str} into a list of the substrings delimited\n"
2973 "by appearances of the character @var{chr}. Note that an empty substring\n"
2974 "between separator characters will result in an empty string in the\n"
2978 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2980 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2982 "(string-split \"::\" #\\:)\n"
2984 "(\"\" \"\" \"\")\n"
2986 "(string-split \"\" #\\:)\n"
2990 #define FUNC_NAME s_scm_string_split
2996 SCM_VALIDATE_STRING (1, str
);
2997 SCM_VALIDATE_CHAR (2, chr
);
2999 /* This is explicit wide/narrow logic (instead of using
3000 scm_i_string_ref) is a speed optimization. */
3001 idx
= scm_i_string_length (str
);
3002 narrow
= scm_i_is_narrow_string (str
);
3005 const char *buf
= scm_i_string_chars (str
);
3009 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
3013 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3020 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3024 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3028 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3033 scm_remember_upto_here_1 (str
);
3039 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3040 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3041 "Filter the string @var{s}, retaining only those characters\n"
3042 "which satisfy @var{char_pred}.\n"
3044 "If @var{char_pred} is a procedure, it is applied to each\n"
3045 "character as a predicate, if it is a character, it is tested\n"
3046 "for equality and if it is a character set, it is tested for\n"
3048 #define FUNC_NAME s_scm_string_filter
3050 size_t cstart
, cend
;
3054 #if SCM_ENABLE_DEPRECATED == 1
3055 if (scm_is_string (char_pred
))
3059 scm_c_issue_deprecation_warning
3060 ("Guile used to use the wrong argument order for string-filter.\n"
3061 "This call to string-filter had the arguments in the wrong order.\n"
3062 "See SRFI-13 for more details. At some point we will remove this hack.");
3070 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3074 /* The explicit loops below stripping leading and trailing non-matches
3075 mean we can return a substring if those are the only deletions, making
3076 string-filter as efficient as string-trim-both in that case. */
3078 if (SCM_CHARP (char_pred
))
3082 /* strip leading non-matches by incrementing cstart */
3083 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3086 /* strip trailing non-matches by decrementing cend */
3087 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3090 /* count chars to keep */
3092 for (idx
= cstart
; idx
< cend
; idx
++)
3093 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3096 if (count
== cend
- cstart
)
3098 /* whole of cstart to cend is to be kept, return a copy-on-write
3101 result
= scm_i_substring (s
, cstart
, cend
);
3104 result
= scm_c_make_string (count
, char_pred
);
3106 else if (SCM_CHARSETP (char_pred
))
3110 /* strip leading non-matches by incrementing cstart */
3111 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3114 /* strip trailing non-matches by decrementing cend */
3115 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3118 /* count chars to be kept */
3120 for (idx
= cstart
; idx
< cend
; idx
++)
3121 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3124 /* if whole of start to end kept then return substring */
3125 if (count
== cend
- cstart
)
3126 goto result_substring
;
3130 result
= scm_i_make_string (count
, NULL
);
3131 result
= scm_i_string_start_writing (result
);
3133 /* decrement "count" in this loop as well as using idx, so that if
3134 another thread is simultaneously changing "s" there's no chance
3135 it'll make us copy more than count characters */
3136 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3138 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3140 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3145 scm_i_string_stop_writing ();
3152 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3153 char_pred
, SCM_ARG1
, FUNC_NAME
);
3158 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3159 res
= scm_call_1 (char_pred
, ch
);
3160 if (scm_is_true (res
))
3161 ls
= scm_cons (ch
, ls
);
3164 result
= scm_reverse_list_to_string (ls
);
3167 scm_remember_upto_here_1 (s
);
3173 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3174 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3175 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3177 "If @var{char_pred} is a procedure, it is applied to each\n"
3178 "character as a predicate, if it is a character, it is tested\n"
3179 "for equality and if it is a character set, it is tested for\n"
3181 #define FUNC_NAME s_scm_string_delete
3183 size_t cstart
, cend
;
3187 #if SCM_ENABLE_DEPRECATED == 1
3188 if (scm_is_string (char_pred
))
3192 scm_c_issue_deprecation_warning
3193 ("Guile used to use the wrong argument order for string-delete.\n"
3194 "This call to string-filter had the arguments in the wrong order.\n"
3195 "See SRFI-13 for more details. At some point we will remove this hack.");
3203 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3207 /* The explicit loops below stripping leading and trailing matches mean we
3208 can return a substring if those are the only deletions, making
3209 string-delete as efficient as string-trim-both in that case. */
3211 if (SCM_CHARP (char_pred
))
3215 /* strip leading matches by incrementing cstart */
3216 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3219 /* strip trailing matches by decrementing cend */
3220 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3223 /* count chars to be kept */
3225 for (idx
= cstart
; idx
< cend
; idx
++)
3226 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3229 if (count
== cend
- cstart
)
3231 /* whole of cstart to cend is to be kept, return a copy-on-write
3234 result
= scm_i_substring (s
, cstart
, cend
);
3239 /* new string for retained portion */
3240 result
= scm_i_make_string (count
, NULL
);
3241 result
= scm_i_string_start_writing (result
);
3242 /* decrement "count" in this loop as well as using idx, so that if
3243 another thread is simultaneously changing "s" there's no chance
3244 it'll make us copy more than count characters */
3245 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3247 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3248 if (c
!= SCM_CHAR (char_pred
))
3250 scm_i_string_set_x (result
, i
, c
);
3255 scm_i_string_stop_writing ();
3258 else if (SCM_CHARSETP (char_pred
))
3262 /* strip leading matches by incrementing cstart */
3263 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3266 /* strip trailing matches by decrementing cend */
3267 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3270 /* count chars to be kept */
3272 for (idx
= cstart
; idx
< cend
; idx
++)
3273 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3276 if (count
== cend
- cstart
)
3277 goto result_substring
;
3281 /* new string for retained portion */
3282 result
= scm_i_make_string (count
, NULL
);
3283 result
= scm_i_string_start_writing (result
);
3285 /* decrement "count" in this loop as well as using idx, so that if
3286 another thread is simultaneously changing "s" there's no chance
3287 it'll make us copy more than count characters */
3288 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3290 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3292 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3297 scm_i_string_stop_writing ();
3303 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3304 char_pred
, SCM_ARG1
, FUNC_NAME
);
3309 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3310 res
= scm_call_1 (char_pred
, ch
);
3311 if (scm_is_false (res
))
3312 ls
= scm_cons (ch
, ls
);
3315 result
= scm_reverse_list_to_string (ls
);
3318 scm_remember_upto_here_1 (s
);
3324 scm_init_srfi_13 (void)
3326 #include "libguile/srfi-13.x"
3329 /* End of srfi-13.c. */