1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 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
)
723 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
725 while (cstart
< cend
)
727 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
732 else if (SCM_CHARP (char_pred
))
734 while (cstart
< cend
)
736 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
741 else if (SCM_CHARSETP (char_pred
))
743 while (cstart
< cend
)
745 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
752 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
753 char_pred
, SCM_ARG2
, FUNC_NAME
);
755 while (cstart
< cend
)
759 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
760 if (scm_is_false (res
))
765 return scm_i_substring (s
, cstart
, cend
);
770 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
771 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
772 "Trim @var{s} by skipping over all characters on the right\n"
773 "that satisfy the parameter @var{char_pred}:\n"
777 "if it is the character @var{ch}, characters equal to @var{ch}\n"
781 "if it is a procedure @var{pred} characters that satisfy\n"
782 "@var{pred} are trimmed,\n"
785 "if it is a character sets, all characters in that set are\n"
789 "If called without a @var{char_pred} argument, all whitespace is\n"
791 #define FUNC_NAME s_scm_string_trim_right
795 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
798 if (SCM_UNBNDP (char_pred
)
799 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
801 while (cstart
< cend
)
803 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
808 else if (SCM_CHARP (char_pred
))
810 while (cstart
< cend
)
812 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
817 else if (SCM_CHARSETP (char_pred
))
819 while (cstart
< cend
)
821 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
828 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
829 char_pred
, SCM_ARG2
, FUNC_NAME
);
831 while (cstart
< cend
)
835 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
836 if (scm_is_false (res
))
841 return scm_i_substring (s
, cstart
, cend
);
846 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
847 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
848 "Trim @var{s} by skipping over all characters on both sides of\n"
849 "the string that satisfy the parameter @var{char_pred}:\n"
853 "if it is the character @var{ch}, characters equal to @var{ch}\n"
857 "if it is a procedure @var{pred} characters that satisfy\n"
858 "@var{pred} are trimmed,\n"
861 "if it is a character set, the characters in the set are\n"
865 "If called without a @var{char_pred} argument, all whitespace is\n"
867 #define FUNC_NAME s_scm_string_trim_both
871 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
874 if (SCM_UNBNDP (char_pred
)
875 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
877 while (cstart
< cend
)
879 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
883 while (cstart
< cend
)
885 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
890 else if (SCM_CHARP (char_pred
))
892 while (cstart
< cend
)
894 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
898 while (cstart
< cend
)
900 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
905 else if (SCM_CHARSETP (char_pred
))
907 while (cstart
< cend
)
909 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
913 while (cstart
< cend
)
915 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
922 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
923 char_pred
, SCM_ARG2
, FUNC_NAME
);
925 while (cstart
< cend
)
929 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
930 if (scm_is_false (res
))
934 while (cstart
< cend
)
938 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
939 if (scm_is_false (res
))
944 return scm_i_substring (s
, cstart
, cend
);
949 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
950 (SCM str
, SCM chr
, SCM start
, SCM end
),
951 "Stores @var{chr} in every element of the given @var{str} and\n"
952 "returns an unspecified value.")
953 #define FUNC_NAME s_scm_substring_fill_x
958 /* Older versions of Guile provided the function
959 scm_substring_fill_x with the following order of arguments:
963 We accomodate this here by detecting such a usage and reordering
974 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
977 SCM_VALIDATE_CHAR (2, chr
);
981 str
= scm_i_string_start_writing (str
);
982 for (k
= cstart
; k
< cend
; k
++)
983 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
984 scm_i_string_stop_writing ();
987 return SCM_UNSPECIFIED
;
992 scm_string_fill_x (SCM str
, SCM chr
)
994 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
997 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
998 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
999 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1000 "mismatch index, depending upon whether @var{s1} is less than,\n"
1001 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1002 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1003 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1004 "@var{i} is the first position that does not match.")
1005 #define FUNC_NAME s_scm_string_compare
1007 size_t cstart1
, cend1
, cstart2
, cend2
;
1010 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1013 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1016 SCM_VALIDATE_PROC (3, proc_lt
);
1017 SCM_VALIDATE_PROC (4, proc_eq
);
1018 SCM_VALIDATE_PROC (5, proc_gt
);
1020 while (cstart1
< cend1
&& cstart2
< cend2
)
1022 if (scm_i_string_ref (s1
, cstart1
)
1023 < scm_i_string_ref (s2
, cstart2
))
1028 else if (scm_i_string_ref (s1
, cstart1
)
1029 > scm_i_string_ref (s2
, cstart2
))
1037 if (cstart1
< cend1
)
1039 else if (cstart2
< cend2
)
1045 scm_remember_upto_here_2 (s1
, s2
);
1046 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1051 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1052 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1053 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1054 "mismatch index, depending upon whether @var{s1} is less than,\n"
1055 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1056 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1057 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1058 "@var{i} is the first position where the lowercased letters \n"
1060 #define FUNC_NAME s_scm_string_compare_ci
1062 size_t cstart1
, cend1
, cstart2
, cend2
;
1065 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1068 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1071 SCM_VALIDATE_PROC (3, proc_lt
);
1072 SCM_VALIDATE_PROC (4, proc_eq
);
1073 SCM_VALIDATE_PROC (5, proc_gt
);
1075 while (cstart1
< cend1
&& cstart2
< cend2
)
1077 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1078 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1083 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1084 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1093 if (cstart1
< cend1
)
1095 else if (cstart2
< cend2
)
1101 scm_remember_upto_here (s1
, s2
);
1102 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1106 /* This function compares two substrings, S1 from START1 to END1 and
1107 S2 from START2 to END2, possibly case insensitively, and returns
1108 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1109 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1110 longer, or equal. */
1112 compare_strings (const char *fname
, int case_insensitive
,
1113 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1114 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1116 size_t cstart1
, cend1
, cstart2
, cend2
;
1120 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1123 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1127 while (cstart1
< cend1
&& cstart2
< cend2
)
1129 if (case_insensitive
)
1131 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1132 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1136 a
= scm_i_string_ref (s1
, cstart1
);
1137 b
= scm_i_string_ref (s2
, cstart2
);
1152 if (cstart1
< cend1
)
1157 else if (cstart2
< cend2
)
1169 scm_remember_upto_here_2 (s1
, s2
);
1174 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1175 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1176 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1178 #define FUNC_NAME s_scm_string_eq
1180 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1181 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1182 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1183 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1185 /* Fast path for this common case, which avoids the repeated calls to
1186 `scm_i_string_ref'. */
1189 len1
= scm_i_string_length (s1
);
1190 len2
= scm_i_string_length (s2
);
1196 if (!scm_i_is_narrow_string (s1
))
1199 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1200 scm_i_string_data (s2
),
1205 return compare_strings (FUNC_NAME
, 0,
1206 s1
, s2
, start1
, end1
, start2
, end2
,
1207 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1212 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1213 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1214 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1216 #define FUNC_NAME s_scm_string_neq
1218 return compare_strings (FUNC_NAME
, 0,
1219 s1
, s2
, start1
, end1
, start2
, end2
,
1220 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1225 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1226 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1227 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1228 "true value otherwise.")
1229 #define FUNC_NAME s_scm_string_lt
1231 return compare_strings (FUNC_NAME
, 0,
1232 s1
, s2
, start1
, end1
, start2
, end2
,
1233 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1238 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1239 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1240 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1241 "true value otherwise.")
1242 #define FUNC_NAME s_scm_string_gt
1244 return compare_strings (FUNC_NAME
, 0,
1245 s1
, s2
, start1
, end1
, start2
, end2
,
1246 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1251 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1252 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1253 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1255 #define FUNC_NAME s_scm_string_le
1257 return compare_strings (FUNC_NAME
, 0,
1258 s1
, s2
, start1
, end1
, start2
, end2
,
1259 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1264 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1265 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1266 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1268 #define FUNC_NAME s_scm_string_ge
1270 return compare_strings (FUNC_NAME
, 0,
1271 s1
, s2
, start1
, end1
, start2
, end2
,
1272 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1277 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1278 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1279 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1280 "value otherwise. The character comparison is done\n"
1281 "case-insensitively.")
1282 #define FUNC_NAME s_scm_string_ci_eq
1284 return compare_strings (FUNC_NAME
, 1,
1285 s1
, s2
, start1
, end1
, start2
, end2
,
1286 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1291 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1292 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1293 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1294 "value otherwise. The character comparison is done\n"
1295 "case-insensitively.")
1296 #define FUNC_NAME s_scm_string_ci_neq
1298 return compare_strings (FUNC_NAME
, 1,
1299 s1
, s2
, start1
, end1
, start2
, end2
,
1300 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1305 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1306 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1307 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1308 "true value otherwise. The character comparison is done\n"
1309 "case-insensitively.")
1310 #define FUNC_NAME s_scm_string_ci_lt
1312 return compare_strings (FUNC_NAME
, 1,
1313 s1
, s2
, start1
, end1
, start2
, end2
,
1314 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1319 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1320 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1321 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1322 "true value otherwise. The character comparison is done\n"
1323 "case-insensitively.")
1324 #define FUNC_NAME s_scm_string_ci_gt
1326 return compare_strings (FUNC_NAME
, 1,
1327 s1
, s2
, start1
, end1
, start2
, end2
,
1328 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1333 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1334 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1335 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1336 "value otherwise. The character comparison is done\n"
1337 "case-insensitively.")
1338 #define FUNC_NAME s_scm_string_ci_le
1340 return compare_strings (FUNC_NAME
, 1,
1341 s1
, s2
, start1
, end1
, start2
, end2
,
1342 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1347 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1348 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1349 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1350 "otherwise. The character comparison is done\n"
1351 "case-insensitively.")
1352 #define FUNC_NAME s_scm_string_ci_ge
1354 return compare_strings (FUNC_NAME
, 1,
1355 s1
, s2
, start1
, end1
, start2
, end2
,
1356 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1360 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1361 (SCM s
, SCM bound
, SCM start
, SCM end
),
1362 "Compute a hash value for @var{s}. the optional argument "
1363 "@var{bound} is a non-negative exact "
1364 "integer specifying the range of the hash function. "
1365 "A positive value restricts the return value to the "
1367 #define FUNC_NAME s_scm_substring_hash
1369 if (SCM_UNBNDP (bound
))
1370 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1371 if (SCM_UNBNDP (start
))
1373 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1377 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1378 (SCM s
, SCM bound
, SCM start
, SCM end
),
1379 "Compute a hash value for @var{s}. the optional argument "
1380 "@var{bound} is a non-negative exact "
1381 "integer specifying the range of the hash function. "
1382 "A positive value restricts the return value to the "
1384 #define FUNC_NAME s_scm_substring_hash_ci
1386 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1388 SCM_UNDEFINED
, SCM_UNDEFINED
);
1392 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1393 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1394 "Return the length of the longest common prefix of the two\n"
1396 #define FUNC_NAME s_scm_string_prefix_length
1398 size_t cstart1
, cend1
, cstart2
, cend2
;
1401 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1404 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1408 while (cstart1
< cend1
&& cstart2
< cend2
)
1410 if (scm_i_string_ref (s1
, cstart1
)
1411 != scm_i_string_ref (s2
, cstart2
))
1419 scm_remember_upto_here_2 (s1
, s2
);
1420 return scm_from_size_t (len
);
1425 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1426 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1427 "Return the length of the longest common prefix of the two\n"
1428 "strings, ignoring character case.")
1429 #define FUNC_NAME s_scm_string_prefix_length_ci
1431 size_t cstart1
, cend1
, cstart2
, cend2
;
1434 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1437 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1440 while (cstart1
< cend1
&& cstart2
< cend2
)
1442 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1443 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1451 scm_remember_upto_here_2 (s1
, s2
);
1452 return scm_from_size_t (len
);
1457 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1458 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1459 "Return the length of the longest common suffix of the two\n"
1461 #define FUNC_NAME s_scm_string_suffix_length
1463 size_t cstart1
, cend1
, cstart2
, cend2
;
1466 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1469 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1472 while (cstart1
< cend1
&& cstart2
< cend2
)
1476 if (scm_i_string_ref (s1
, cend1
)
1477 != scm_i_string_ref (s2
, cend2
))
1483 scm_remember_upto_here_2 (s1
, s2
);
1484 return scm_from_size_t (len
);
1489 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1490 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1491 "Return the length of the longest common suffix of the two\n"
1492 "strings, ignoring character case.")
1493 #define FUNC_NAME s_scm_string_suffix_length_ci
1495 size_t cstart1
, cend1
, cstart2
, cend2
;
1498 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1501 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1504 while (cstart1
< cend1
&& cstart2
< cend2
)
1508 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1509 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1515 scm_remember_upto_here_2 (s1
, s2
);
1516 return scm_from_size_t (len
);
1521 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1522 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1523 "Is @var{s1} a prefix of @var{s2}?")
1524 #define FUNC_NAME s_scm_string_prefix_p
1526 size_t cstart1
, cend1
, cstart2
, cend2
;
1527 size_t len
= 0, len1
;
1529 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1532 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1535 len1
= cend1
- cstart1
;
1536 while (cstart1
< cend1
&& cstart2
< cend2
)
1538 if (scm_i_string_ref (s1
, cstart1
)
1539 != scm_i_string_ref (s2
, cstart2
))
1547 scm_remember_upto_here_2 (s1
, s2
);
1548 return scm_from_bool (len
== len1
);
1553 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1554 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1555 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1556 #define FUNC_NAME s_scm_string_prefix_ci_p
1558 size_t cstart1
, cend1
, cstart2
, cend2
;
1559 size_t len
= 0, len1
;
1561 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1564 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1567 len1
= cend1
- cstart1
;
1568 while (cstart1
< cend1
&& cstart2
< cend2
)
1570 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1571 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1580 scm_remember_upto_here_2 (s1
, s2
);
1581 return scm_from_bool (len
== len1
);
1586 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1587 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1588 "Is @var{s1} a suffix of @var{s2}?")
1589 #define FUNC_NAME s_scm_string_suffix_p
1591 size_t cstart1
, cend1
, cstart2
, cend2
;
1592 size_t len
= 0, len1
;
1594 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1597 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1600 len1
= cend1
- cstart1
;
1601 while (cstart1
< cend1
&& cstart2
< cend2
)
1605 if (scm_i_string_ref (s1
, cend1
)
1606 != scm_i_string_ref (s2
, cend2
))
1612 scm_remember_upto_here_2 (s1
, s2
);
1613 return scm_from_bool (len
== len1
);
1618 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1619 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1620 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1621 #define FUNC_NAME s_scm_string_suffix_ci_p
1623 size_t cstart1
, cend1
, cstart2
, cend2
;
1624 size_t len
= 0, len1
;
1626 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1629 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1632 len1
= cend1
- cstart1
;
1633 while (cstart1
< cend1
&& cstart2
< cend2
)
1637 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1638 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1644 scm_remember_upto_here_2 (s1
, s2
);
1645 return scm_from_bool (len
== len1
);
1650 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1651 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1652 "Search through the string @var{s} from left to right, returning\n"
1653 "the index of the first occurrence of a character which\n"
1655 "@itemize @bullet\n"
1657 "equals @var{char_pred}, if it is character,\n"
1660 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1663 "is in the set @var{char_pred}, if it is a character set.\n"
1665 "Return @code{#f} if no match is found.")
1666 #define FUNC_NAME s_scm_string_index
1668 size_t cstart
, cend
;
1670 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1673 if (SCM_CHARP (char_pred
))
1675 while (cstart
< cend
)
1677 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1682 else if (SCM_CHARSETP (char_pred
))
1684 while (cstart
< cend
)
1686 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1693 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1694 char_pred
, SCM_ARG2
, FUNC_NAME
);
1696 while (cstart
< cend
)
1699 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1700 if (scm_is_true (res
))
1706 scm_remember_upto_here_1 (s
);
1710 scm_remember_upto_here_1 (s
);
1711 return scm_from_size_t (cstart
);
1715 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1716 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1717 "Search through the string @var{s} from right to left, returning\n"
1718 "the index of the last occurrence of a character which\n"
1720 "@itemize @bullet\n"
1722 "equals @var{char_pred}, if it is character,\n"
1725 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1728 "is in the set if @var{char_pred} is a character set.\n"
1730 "Return @code{#f} if no match is found.")
1731 #define FUNC_NAME s_scm_string_index_right
1733 size_t cstart
, cend
;
1735 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1738 if (SCM_CHARP (char_pred
))
1740 while (cstart
< cend
)
1743 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1747 else if (SCM_CHARSETP (char_pred
))
1749 while (cstart
< cend
)
1752 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1758 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1759 char_pred
, SCM_ARG2
, FUNC_NAME
);
1761 while (cstart
< cend
)
1765 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1766 if (scm_is_true (res
))
1771 scm_remember_upto_here_1 (s
);
1775 scm_remember_upto_here_1 (s
);
1776 return scm_from_size_t (cend
);
1780 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1781 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1782 "Search through the string @var{s} from right to left, returning\n"
1783 "the index of the last occurrence of a character which\n"
1785 "@itemize @bullet\n"
1787 "equals @var{char_pred}, if it is character,\n"
1790 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1793 "is in the set if @var{char_pred} is a character set.\n"
1795 "Return @code{#f} if no match is found.")
1796 #define FUNC_NAME s_scm_string_rindex
1798 return scm_string_index_right (s
, char_pred
, start
, end
);
1802 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1803 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1804 "Search through the string @var{s} from left to right, returning\n"
1805 "the index of the first occurrence of a character which\n"
1807 "@itemize @bullet\n"
1809 "does not equal @var{char_pred}, if it is character,\n"
1812 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1816 "is not in the set if @var{char_pred} is a character set.\n"
1818 #define FUNC_NAME s_scm_string_skip
1820 size_t cstart
, cend
;
1822 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1825 if (SCM_CHARP (char_pred
))
1827 while (cstart
< cend
)
1829 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1834 else if (SCM_CHARSETP (char_pred
))
1836 while (cstart
< cend
)
1838 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1845 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1846 char_pred
, SCM_ARG2
, FUNC_NAME
);
1848 while (cstart
< cend
)
1851 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1852 if (scm_is_false (res
))
1858 scm_remember_upto_here_1 (s
);
1862 scm_remember_upto_here_1 (s
);
1863 return scm_from_size_t (cstart
);
1868 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1869 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1870 "Search through the string @var{s} from right to left, returning\n"
1871 "the index of the last occurrence of a character which\n"
1873 "@itemize @bullet\n"
1875 "does not equal @var{char_pred}, if it is character,\n"
1878 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1882 "is not in the set if @var{char_pred} is a character set.\n"
1884 #define FUNC_NAME s_scm_string_skip_right
1886 size_t cstart
, cend
;
1888 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1891 if (SCM_CHARP (char_pred
))
1893 while (cstart
< cend
)
1896 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1900 else if (SCM_CHARSETP (char_pred
))
1902 while (cstart
< cend
)
1905 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1911 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1912 char_pred
, SCM_ARG2
, FUNC_NAME
);
1914 while (cstart
< cend
)
1918 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1919 if (scm_is_false (res
))
1924 scm_remember_upto_here_1 (s
);
1928 scm_remember_upto_here_1 (s
);
1929 return scm_from_size_t (cend
);
1935 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1936 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1937 "Return the count of the number of characters in the string\n"
1940 "@itemize @bullet\n"
1942 "equals @var{char_pred}, if it is character,\n"
1945 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1948 "is in the set @var{char_pred}, if it is a character set.\n"
1950 #define FUNC_NAME s_scm_string_count
1952 size_t cstart
, cend
;
1955 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1958 if (SCM_CHARP (char_pred
))
1960 while (cstart
< cend
)
1962 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1967 else if (SCM_CHARSETP (char_pred
))
1969 while (cstart
< cend
)
1971 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1978 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1979 char_pred
, SCM_ARG2
, FUNC_NAME
);
1981 while (cstart
< cend
)
1984 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1985 if (scm_is_true (res
))
1991 scm_remember_upto_here_1 (s
);
1992 return scm_from_size_t (count
);
1997 /* FIXME::martin: This should definitely get implemented more
1998 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2000 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2001 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2002 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2003 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2004 "The optional start/end indices restrict the operation to the\n"
2005 "indicated substrings.")
2006 #define FUNC_NAME s_scm_string_contains
2008 size_t cstart1
, cend1
, cstart2
, cend2
;
2011 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2014 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2017 len2
= cend2
- cstart2
;
2018 if (cend1
- cstart1
>= len2
)
2019 while (cstart1
<= cend1
- len2
)
2025 && (scm_i_string_ref (s1
, i
)
2026 == scm_i_string_ref (s2
, j
)))
2033 scm_remember_upto_here_2 (s1
, s2
);
2034 return scm_from_size_t (cstart1
);
2039 scm_remember_upto_here_2 (s1
, s2
);
2045 /* FIXME::martin: This should definitely get implemented more
2046 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2048 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2049 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2050 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2051 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2052 "The optional start/end indices restrict the operation to the\n"
2053 "indicated substrings. Character comparison is done\n"
2054 "case-insensitively.")
2055 #define FUNC_NAME s_scm_string_contains_ci
2057 size_t cstart1
, cend1
, cstart2
, cend2
;
2060 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2063 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2066 len2
= cend2
- cstart2
;
2067 if (cend1
- cstart1
>= len2
)
2068 while (cstart1
<= cend1
- len2
)
2074 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2075 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2082 scm_remember_upto_here_2 (s1
, s2
);
2083 return scm_from_size_t (cstart1
);
2088 scm_remember_upto_here_2 (s1
, s2
);
2094 /* Helper function for the string uppercase conversion functions. */
2096 string_upcase_x (SCM v
, size_t start
, size_t end
)
2102 v
= scm_i_string_start_writing (v
);
2103 for (k
= start
; k
< end
; ++k
)
2104 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2105 scm_i_string_stop_writing ();
2106 scm_remember_upto_here_1 (v
);
2112 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2113 (SCM str
, SCM start
, SCM end
),
2114 "Destructively upcase every character in @code{str}.\n"
2117 "(string-upcase! y)\n"
2118 "@result{} \"ARRDEFG\"\n"
2120 "@result{} \"ARRDEFG\"\n"
2122 #define FUNC_NAME s_scm_substring_upcase_x
2124 size_t cstart
, cend
;
2126 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2129 return string_upcase_x (str
, cstart
, cend
);
2134 scm_string_upcase_x (SCM str
)
2136 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2139 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2140 (SCM str
, SCM start
, SCM end
),
2141 "Upcase every character in @code{str}.")
2142 #define FUNC_NAME s_scm_substring_upcase
2144 size_t cstart
, cend
;
2146 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2149 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2154 scm_string_upcase (SCM str
)
2156 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2159 /* Helper function for the string lowercase conversion functions.
2160 * No argument checking is performed. */
2162 string_downcase_x (SCM v
, size_t start
, size_t end
)
2168 v
= scm_i_string_start_writing (v
);
2169 for (k
= start
; k
< end
; ++k
)
2170 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2171 scm_i_string_stop_writing ();
2172 scm_remember_upto_here_1 (v
);
2178 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2179 (SCM str
, SCM start
, SCM end
),
2180 "Destructively downcase every character in @var{str}.\n"
2184 "@result{} \"ARRDEFG\"\n"
2185 "(string-downcase! y)\n"
2186 "@result{} \"arrdefg\"\n"
2188 "@result{} \"arrdefg\"\n"
2190 #define FUNC_NAME s_scm_substring_downcase_x
2192 size_t cstart
, cend
;
2194 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2197 return string_downcase_x (str
, cstart
, cend
);
2202 scm_string_downcase_x (SCM str
)
2204 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2207 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2208 (SCM str
, SCM start
, SCM end
),
2209 "Downcase every character in @var{str}.")
2210 #define FUNC_NAME s_scm_substring_downcase
2212 size_t cstart
, cend
;
2214 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2217 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2222 scm_string_downcase (SCM str
)
2224 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2227 /* Helper function for the string capitalization functions.
2228 * No argument checking is performed. */
2230 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2238 str
= scm_i_string_start_writing (str
);
2239 for(i
= start
; i
< end
; i
++)
2241 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2242 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2246 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2251 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2257 scm_i_string_stop_writing ();
2258 scm_remember_upto_here_1 (str
);
2265 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2266 (SCM str
, SCM start
, SCM end
),
2267 "Destructively titlecase every first character in a word in\n"
2269 #define FUNC_NAME s_scm_string_titlecase_x
2271 size_t cstart
, cend
;
2273 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2276 return string_titlecase_x (str
, cstart
, cend
);
2281 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2282 (SCM str
, SCM start
, SCM end
),
2283 "Titlecase every first character in a word in @var{str}.")
2284 #define FUNC_NAME s_scm_string_titlecase
2286 size_t cstart
, cend
;
2288 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2291 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2295 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2297 "Upcase the first character of every word in @var{str}\n"
2298 "destructively and return @var{str}.\n"
2301 "y @result{} \"hello world\"\n"
2302 "(string-capitalize! y) @result{} \"Hello World\"\n"
2303 "y @result{} \"Hello World\"\n"
2305 #define FUNC_NAME s_scm_string_capitalize_x
2307 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2312 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2314 "Return a freshly allocated string with the characters in\n"
2315 "@var{str}, where the first character of every word is\n"
2317 #define FUNC_NAME s_scm_string_capitalize
2319 return scm_string_capitalize_x (scm_string_copy (str
));
2324 /* Reverse the portion of @var{str} between str[cstart] (including)
2325 and str[cend] excluding. */
2327 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2331 str
= scm_i_string_start_writing (str
);
2337 while (cstart
< cend
)
2339 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2340 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2341 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2346 scm_i_string_stop_writing ();
2351 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2352 (SCM str
, SCM start
, SCM end
),
2353 "Reverse the string @var{str}. The optional arguments\n"
2354 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2356 #define FUNC_NAME s_scm_string_reverse
2358 size_t cstart
, cend
;
2361 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2364 result
= scm_string_copy (str
);
2365 string_reverse_x (result
, cstart
, cend
);
2366 scm_remember_upto_here_1 (str
);
2372 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2373 (SCM str
, SCM start
, SCM end
),
2374 "Reverse the string @var{str} in-place. The optional arguments\n"
2375 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2376 "operate on. The return value is unspecified.")
2377 #define FUNC_NAME s_scm_string_reverse_x
2379 size_t cstart
, cend
;
2381 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2385 string_reverse_x (str
, cstart
, cend
);
2386 scm_remember_upto_here_1 (str
);
2387 return SCM_UNSPECIFIED
;
2392 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2394 "Like @code{string-append}, but the result may share memory\n"
2395 "with the argument strings.")
2396 #define FUNC_NAME s_scm_string_append_shared
2398 /* If "rest" contains just one non-empty string, return that.
2399 If it's entirely empty strings, then return scm_nullstr.
2400 Otherwise use scm_string_concatenate. */
2402 SCM ret
= scm_nullstr
;
2403 int seen_nonempty
= 0;
2406 SCM_VALIDATE_REST_ARGUMENT (rest
);
2408 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2411 if (!scm_is_string (s
))
2412 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2413 if (scm_i_string_length (s
) != 0)
2416 /* two or more non-empty strings, need full concat */
2417 return scm_string_append (rest
);
2428 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2430 "Append the elements of @var{ls} (which must be strings)\n"
2431 "together into a single string. Guaranteed to return a freshly\n"
2432 "allocated string.")
2433 #define FUNC_NAME s_scm_string_concatenate
2435 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2436 return scm_string_append (ls
);
2441 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2442 (SCM ls
, SCM final_string
, SCM end
),
2443 "Without optional arguments, this procedure is equivalent to\n"
2446 "(string-concatenate (reverse ls))\n"
2449 "If the optional argument @var{final_string} is specified, it is\n"
2450 "consed onto the beginning to @var{ls} before performing the\n"
2451 "list-reverse and string-concatenate operations. If @var{end}\n"
2452 "is given, only the characters of @var{final_string} up to index\n"
2453 "@var{end} are used.\n"
2455 "Guaranteed to return a freshly allocated string.")
2456 #define FUNC_NAME s_scm_string_concatenate_reverse
2458 if (!SCM_UNBNDP (end
))
2459 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2461 if (!SCM_UNBNDP (final_string
))
2462 ls
= scm_cons (final_string
, ls
);
2464 return scm_string_concatenate (scm_reverse (ls
));
2469 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2471 "Like @code{string-concatenate}, but the result may share memory\n"
2472 "with the strings in the list @var{ls}.")
2473 #define FUNC_NAME s_scm_string_concatenate_shared
2475 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2476 return scm_string_append_shared (ls
);
2481 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2482 (SCM ls
, SCM final_string
, SCM end
),
2483 "Like @code{string-concatenate-reverse}, but the result may\n"
2484 "share memory with the strings in the @var{ls} arguments.")
2485 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2487 /* Just call the non-sharing version. */
2488 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2493 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2494 (SCM proc
, SCM s
, SCM start
, SCM end
),
2495 "@var{proc} is a char->char procedure, it is mapped over\n"
2496 "@var{s}. The order in which the procedure is applied to the\n"
2497 "string elements is not specified.")
2498 #define FUNC_NAME s_scm_string_map
2501 size_t cstart
, cend
;
2504 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2505 proc
, SCM_ARG1
, FUNC_NAME
);
2506 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2509 result
= scm_i_make_string (cend
- cstart
, NULL
, 0);
2511 while (cstart
< cend
)
2513 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2514 if (!SCM_CHARP (ch
))
2515 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2517 result
= scm_i_string_start_writing (result
);
2518 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2519 scm_i_string_stop_writing ();
2528 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2529 (SCM proc
, SCM s
, SCM start
, SCM end
),
2530 "@var{proc} is a char->char procedure, it is mapped over\n"
2531 "@var{s}. The order in which the procedure is applied to the\n"
2532 "string elements is not specified. The string @var{s} is\n"
2533 "modified in-place, the return value is not specified.")
2534 #define FUNC_NAME s_scm_string_map_x
2536 size_t cstart
, cend
;
2538 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2539 proc
, SCM_ARG1
, FUNC_NAME
);
2540 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2543 while (cstart
< cend
)
2545 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2546 if (!SCM_CHARP (ch
))
2547 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2548 s
= scm_i_string_start_writing (s
);
2549 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2550 scm_i_string_stop_writing ();
2553 return SCM_UNSPECIFIED
;
2558 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2559 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2560 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2561 "as the terminating element, from left to right. @var{kons}\n"
2562 "must expect two arguments: The actual character and the last\n"
2563 "result of @var{kons}' application.")
2564 #define FUNC_NAME s_scm_string_fold
2566 size_t cstart
, cend
;
2569 SCM_VALIDATE_PROC (1, kons
);
2570 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2574 while (cstart
< cend
)
2576 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2580 scm_remember_upto_here_1 (s
);
2586 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2587 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2588 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2589 "as the terminating element, from right to left. @var{kons}\n"
2590 "must expect two arguments: The actual character and the last\n"
2591 "result of @var{kons}' application.")
2592 #define FUNC_NAME s_scm_string_fold_right
2594 size_t cstart
, cend
;
2597 SCM_VALIDATE_PROC (1, kons
);
2598 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2602 while (cstart
< cend
)
2604 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2608 scm_remember_upto_here_1 (s
);
2614 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2615 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2616 "@itemize @bullet\n"
2617 "@item @var{g} is used to generate a series of @emph{seed}\n"
2618 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2619 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2621 "@item @var{p} tells us when to stop -- when it returns true\n"
2622 "when applied to one of these seed values.\n"
2623 "@item @var{f} maps each seed value to the corresponding\n"
2624 "character in the result string. These chars are assembled\n"
2625 "into the string in a left-to-right order.\n"
2626 "@item @var{base} is the optional initial/leftmost portion\n"
2627 "of the constructed string; it default to the empty\n"
2629 "@item @var{make_final} is applied to the terminal seed\n"
2630 "value (on which @var{p} returns true) to produce\n"
2631 "the final/rightmost portion of the constructed string.\n"
2632 "It defaults to @code{(lambda (x) "")}.\n"
2634 #define FUNC_NAME s_scm_string_unfold
2638 SCM_VALIDATE_PROC (1, p
);
2639 SCM_VALIDATE_PROC (2, f
);
2640 SCM_VALIDATE_PROC (3, g
);
2641 if (!SCM_UNBNDP (base
))
2643 SCM_VALIDATE_STRING (5, base
);
2647 ans
= scm_i_make_string (0, NULL
, 0);
2648 if (!SCM_UNBNDP (make_final
))
2649 SCM_VALIDATE_PROC (6, make_final
);
2651 res
= scm_call_1 (p
, seed
);
2652 while (scm_is_false (res
))
2656 SCM ch
= scm_call_1 (f
, seed
);
2657 if (!SCM_CHARP (ch
))
2658 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2659 str
= scm_i_make_string (1, NULL
, 0);
2660 str
= scm_i_string_start_writing (str
);
2661 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2662 scm_i_string_stop_writing ();
2665 ans
= scm_string_append (scm_list_2 (ans
, str
));
2666 seed
= scm_call_1 (g
, seed
);
2667 res
= scm_call_1 (p
, seed
);
2669 if (!SCM_UNBNDP (make_final
))
2671 res
= scm_call_1 (make_final
, seed
);
2672 return scm_string_append (scm_list_2 (ans
, res
));
2680 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2681 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2682 "@itemize @bullet\n"
2683 "@item @var{g} is used to generate a series of @emph{seed}\n"
2684 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2685 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2687 "@item @var{p} tells us when to stop -- when it returns true\n"
2688 "when applied to one of these seed values.\n"
2689 "@item @var{f} maps each seed value to the corresponding\n"
2690 "character in the result string. These chars are assembled\n"
2691 "into the string in a right-to-left order.\n"
2692 "@item @var{base} is the optional initial/rightmost portion\n"
2693 "of the constructed string; it default to the empty\n"
2695 "@item @var{make_final} is applied to the terminal seed\n"
2696 "value (on which @var{p} returns true) to produce\n"
2697 "the final/leftmost portion of the constructed string.\n"
2698 "It defaults to @code{(lambda (x) "")}.\n"
2700 #define FUNC_NAME s_scm_string_unfold_right
2704 SCM_VALIDATE_PROC (1, p
);
2705 SCM_VALIDATE_PROC (2, f
);
2706 SCM_VALIDATE_PROC (3, g
);
2707 if (!SCM_UNBNDP (base
))
2709 SCM_VALIDATE_STRING (5, base
);
2713 ans
= scm_i_make_string (0, NULL
, 0);
2714 if (!SCM_UNBNDP (make_final
))
2715 SCM_VALIDATE_PROC (6, make_final
);
2717 res
= scm_call_1 (p
, seed
);
2718 while (scm_is_false (res
))
2722 SCM ch
= scm_call_1 (f
, seed
);
2723 if (!SCM_CHARP (ch
))
2724 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2725 str
= scm_i_make_string (1, NULL
, 0);
2726 str
= scm_i_string_start_writing (str
);
2727 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2728 scm_i_string_stop_writing ();
2731 ans
= scm_string_append (scm_list_2 (str
, ans
));
2732 seed
= scm_call_1 (g
, seed
);
2733 res
= scm_call_1 (p
, seed
);
2735 if (!SCM_UNBNDP (make_final
))
2737 res
= scm_call_1 (make_final
, seed
);
2738 return scm_string_append (scm_list_2 (res
, ans
));
2746 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2747 (SCM proc
, SCM s
, SCM start
, SCM end
),
2748 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2749 "return value is not specified.")
2750 #define FUNC_NAME s_scm_string_for_each
2752 size_t cstart
, cend
;
2754 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2755 proc
, SCM_ARG1
, FUNC_NAME
);
2756 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2759 while (cstart
< cend
)
2761 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2765 scm_remember_upto_here_1 (s
);
2766 return SCM_UNSPECIFIED
;
2770 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2771 (SCM proc
, SCM s
, SCM start
, SCM end
),
2772 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2775 "For example, to change characters to alternately upper and\n"
2779 "(define str (string-copy \"studly\"))\n"
2780 "(string-for-each-index\n"
2782 " (string-set! str i\n"
2783 " ((if (even? i) char-upcase char-downcase)\n"
2784 " (string-ref str i))))\n"
2786 "str @result{} \"StUdLy\"\n"
2788 #define FUNC_NAME s_scm_string_for_each_index
2790 size_t cstart
, cend
;
2792 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2793 proc
, SCM_ARG1
, FUNC_NAME
);
2794 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2798 while (cstart
< cend
)
2800 scm_call_1 (proc
, scm_from_size_t (cstart
));
2804 scm_remember_upto_here_1 (s
);
2805 return SCM_UNSPECIFIED
;
2809 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2810 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2811 "This is the @emph{extended substring} procedure that implements\n"
2812 "replicated copying of a substring of some string.\n"
2814 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2815 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2816 "0 and the length of @var{s}. Replicate this substring up and\n"
2817 "down index space, in both the positive and negative directions.\n"
2818 "@code{xsubstring} returns the substring of this string\n"
2819 "beginning at index @var{from}, and ending at @var{to}, which\n"
2820 "defaults to @var{from} + (@var{end} - @var{start}).")
2821 #define FUNC_NAME s_scm_xsubstring
2824 size_t cstart
, cend
;
2828 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2832 cfrom
= scm_to_int (from
);
2833 if (SCM_UNBNDP (to
))
2834 cto
= cfrom
+ (cend
- cstart
);
2836 cto
= scm_to_int (to
);
2837 if (cstart
== cend
&& cfrom
!= cto
)
2838 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2840 result
= scm_i_make_string (cto
- cfrom
, NULL
, 0);
2841 result
= scm_i_string_start_writing (result
);
2846 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2848 scm_i_string_set_x (result
, p
,
2849 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2851 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2855 scm_i_string_stop_writing ();
2857 scm_remember_upto_here_1 (s
);
2863 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2864 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2865 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2866 "is written into the string @var{target} starting at index\n"
2867 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2868 "@var{target} @var{s})} or these arguments share storage -- you\n"
2869 "cannot copy a string on top of itself.")
2870 #define FUNC_NAME s_scm_string_xcopy_x
2873 size_t ctstart
, cstart
, cend
;
2875 SCM dummy
= SCM_UNDEFINED
;
2878 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2881 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2884 csfrom
= scm_to_int (sfrom
);
2885 if (SCM_UNBNDP (sto
))
2886 csto
= csfrom
+ (cend
- cstart
);
2888 csto
= scm_to_int (sto
);
2892 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2893 SCM_ASSERT_RANGE (1, tstart
,
2894 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2897 target
= scm_i_string_start_writing (target
);
2898 while (csfrom
< csto
)
2900 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2902 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2904 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2908 scm_i_string_stop_writing ();
2910 scm_remember_upto_here_2 (target
, s
);
2912 return SCM_UNSPECIFIED
;
2917 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2918 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2919 "Return the string @var{s1}, but with the characters\n"
2920 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2921 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2922 #define FUNC_NAME s_scm_string_replace
2924 size_t cstart1
, cend1
, cstart2
, cend2
;
2927 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2930 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2933 return (scm_string_append
2934 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2935 scm_i_substring (s2
, cstart2
, cend2
),
2936 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2942 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2943 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2944 "Split the string @var{s} into a list of substrings, where each\n"
2945 "substring is a maximal non-empty contiguous sequence of\n"
2946 "characters from the character set @var{token_set}, which\n"
2947 "defaults to @code{char-set:graphic}.\n"
2948 "If @var{start} or @var{end} indices are provided, they restrict\n"
2949 "@code{string-tokenize} to operating on the indicated substring\n"
2951 #define FUNC_NAME s_scm_string_tokenize
2953 size_t cstart
, cend
;
2954 SCM result
= SCM_EOL
;
2956 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2960 if (SCM_UNBNDP (token_set
))
2961 token_set
= scm_char_set_graphic
;
2963 if (SCM_CHARSETP (token_set
))
2967 while (cstart
< cend
)
2969 while (cstart
< cend
)
2971 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2978 while (cstart
< cend
)
2980 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2984 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2988 SCM_WRONG_TYPE_ARG (2, token_set
);
2990 scm_remember_upto_here_1 (s
);
2995 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2997 "Split the string @var{str} into a list of the substrings delimited\n"
2998 "by appearances of the character @var{chr}. Note that an empty substring\n"
2999 "between separator characters will result in an empty string in the\n"
3003 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3005 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3007 "(string-split \"::\" #\\:)\n"
3009 "(\"\" \"\" \"\")\n"
3011 "(string-split \"\" #\\:)\n"
3015 #define FUNC_NAME s_scm_string_split
3021 SCM_VALIDATE_STRING (1, str
);
3022 SCM_VALIDATE_CHAR (2, chr
);
3024 /* This is explicit wide/narrow logic (instead of using
3025 scm_i_string_ref) is a speed optimization. */
3026 idx
= scm_i_string_length (str
);
3027 narrow
= scm_i_is_narrow_string (str
);
3030 const char *buf
= scm_i_string_chars (str
);
3034 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
3038 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3045 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3049 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3053 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3058 scm_remember_upto_here_1 (str
);
3064 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3065 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3066 "Filter the string @var{s}, retaining only those characters\n"
3067 "which satisfy @var{char_pred}.\n"
3069 "If @var{char_pred} is a procedure, it is applied to each\n"
3070 "character as a predicate, if it is a character, it is tested\n"
3071 "for equality and if it is a character set, it is tested for\n"
3073 #define FUNC_NAME s_scm_string_filter
3075 size_t cstart
, cend
;
3079 #if SCM_ENABLE_DEPRECATED == 1
3080 if (scm_is_string (char_pred
))
3084 scm_c_issue_deprecation_warning
3085 ("Guile used to use the wrong argument order for string-filter.\n"
3086 "This call to string-filter had the arguments in the wrong order.\n"
3087 "See SRFI-13 for more details. At some point we will remove this hack.");
3095 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3099 /* The explicit loops below stripping leading and trailing non-matches
3100 mean we can return a substring if those are the only deletions, making
3101 string-filter as efficient as string-trim-both in that case. */
3103 if (SCM_CHARP (char_pred
))
3107 /* strip leading non-matches by incrementing cstart */
3108 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3111 /* strip trailing non-matches by decrementing cend */
3112 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3115 /* count chars to keep */
3117 for (idx
= cstart
; idx
< cend
; idx
++)
3118 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3121 if (count
== cend
- cstart
)
3123 /* whole of cstart to cend is to be kept, return a copy-on-write
3126 result
= scm_i_substring (s
, cstart
, cend
);
3129 result
= scm_c_make_string (count
, char_pred
);
3131 else if (SCM_CHARSETP (char_pred
))
3135 /* strip leading non-matches by incrementing cstart */
3136 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3139 /* strip trailing non-matches by decrementing cend */
3140 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3143 /* count chars to be kept */
3145 for (idx
= cstart
; idx
< cend
; idx
++)
3146 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3149 /* if whole of start to end kept then return substring */
3150 if (count
== cend
- cstart
)
3151 goto result_substring
;
3155 result
= scm_i_make_string (count
, NULL
, 0);
3156 result
= scm_i_string_start_writing (result
);
3158 /* decrement "count" in this loop as well as using idx, so that if
3159 another thread is simultaneously changing "s" there's no chance
3160 it'll make us copy more than count characters */
3161 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3163 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3165 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3170 scm_i_string_stop_writing ();
3177 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3178 char_pred
, SCM_ARG1
, FUNC_NAME
);
3183 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3184 res
= scm_call_1 (char_pred
, ch
);
3185 if (scm_is_true (res
))
3186 ls
= scm_cons (ch
, ls
);
3189 result
= scm_reverse_list_to_string (ls
);
3192 scm_remember_upto_here_1 (s
);
3198 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3199 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3200 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3202 "If @var{char_pred} is a procedure, it is applied to each\n"
3203 "character as a predicate, if it is a character, it is tested\n"
3204 "for equality and if it is a character set, it is tested for\n"
3206 #define FUNC_NAME s_scm_string_delete
3208 size_t cstart
, cend
;
3212 #if SCM_ENABLE_DEPRECATED == 1
3213 if (scm_is_string (char_pred
))
3217 scm_c_issue_deprecation_warning
3218 ("Guile used to use the wrong argument order for string-delete.\n"
3219 "This call to string-filter had the arguments in the wrong order.\n"
3220 "See SRFI-13 for more details. At some point we will remove this hack.");
3228 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3232 /* The explicit loops below stripping leading and trailing matches mean we
3233 can return a substring if those are the only deletions, making
3234 string-delete as efficient as string-trim-both in that case. */
3236 if (SCM_CHARP (char_pred
))
3240 /* strip leading matches by incrementing cstart */
3241 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3244 /* strip trailing matches by decrementing cend */
3245 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3248 /* count chars to be kept */
3250 for (idx
= cstart
; idx
< cend
; idx
++)
3251 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3254 if (count
== cend
- cstart
)
3256 /* whole of cstart to cend is to be kept, return a copy-on-write
3259 result
= scm_i_substring (s
, cstart
, cend
);
3264 /* new string for retained portion */
3265 result
= scm_i_make_string (count
, NULL
, 0);
3266 result
= scm_i_string_start_writing (result
);
3267 /* decrement "count" in this loop as well as using idx, so that if
3268 another thread is simultaneously changing "s" there's no chance
3269 it'll make us copy more than count characters */
3270 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3272 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3273 if (c
!= SCM_CHAR (char_pred
))
3275 scm_i_string_set_x (result
, i
, c
);
3280 scm_i_string_stop_writing ();
3283 else if (SCM_CHARSETP (char_pred
))
3287 /* strip leading matches by incrementing cstart */
3288 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3291 /* strip trailing matches by decrementing cend */
3292 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3295 /* count chars to be kept */
3297 for (idx
= cstart
; idx
< cend
; idx
++)
3298 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3301 if (count
== cend
- cstart
)
3302 goto result_substring
;
3306 /* new string for retained portion */
3307 result
= scm_i_make_string (count
, NULL
, 0);
3308 result
= scm_i_string_start_writing (result
);
3310 /* decrement "count" in this loop as well as using idx, so that if
3311 another thread is simultaneously changing "s" there's no chance
3312 it'll make us copy more than count characters */
3313 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3315 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3317 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3322 scm_i_string_stop_writing ();
3328 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3329 char_pred
, SCM_ARG1
, FUNC_NAME
);
3334 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3335 res
= scm_call_1 (char_pred
, ch
);
3336 if (scm_is_false (res
))
3337 ls
= scm_cons (ch
, ls
);
3340 result
= scm_reverse_list_to_string (ls
);
3343 scm_remember_upto_here_1 (s
);
3349 scm_init_srfi_13 (void)
3351 #include "libguile/srfi-13.x"
3354 /* End of srfi-13.c. */