1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010 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/srfi-13.h"
33 #include "libguile/srfi-14.h"
35 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 scm_i_get_substring_spec (scm_i_string_length (str), \
41 start, &c_start, end, &c_end); \
44 #define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
45 pos_start, start, c_start, \
46 pos_end, end, c_end) \
48 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
49 scm_i_get_substring_spec (scm_i_string_length (str), \
50 start, &c_start, end, &c_end); \
53 #define REF_IN_CHARSET(s, i, cs) \
54 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
56 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
58 "Return @code{#t} if @var{str}'s length is zero, and\n"
59 "@code{#f} otherwise.\n"
61 "(string-null? \"\") @result{} #t\n"
62 "y @result{} \"foo\"\n"
63 "(string-null? y) @result{} #f\n"
65 #define FUNC_NAME s_scm_string_null_p
67 SCM_VALIDATE_STRING (1, str
);
68 return scm_from_bool (scm_i_string_length (str
) == 0);
76 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
80 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
81 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
82 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
84 "@var{char_pred} can be a character to check for any equal to that, or\n"
85 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
86 "or a predicate procedure to call.\n"
88 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
89 "successively on the characters from @var{start} to @var{end}. If\n"
90 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
91 "stops and that return value is the return from @code{string-any}. The\n"
92 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
93 "point is reached, is a tail call.\n"
95 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
96 "@var{end}) then the return is @code{#f}.\n")
97 #define FUNC_NAME s_scm_string_any
100 SCM res
= SCM_BOOL_F
;
102 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
106 if (SCM_CHARP (char_pred
))
109 for (i
= cstart
; i
< cend
; i
++)
110 if (scm_i_string_ref (s
, i
) == SCM_CHAR (char_pred
))
116 else if (SCM_CHARSETP (char_pred
))
119 for (i
= cstart
; i
< cend
; i
++)
120 if (REF_IN_CHARSET (s
, i
, char_pred
))
128 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
129 char_pred
, SCM_ARG1
, FUNC_NAME
);
131 while (cstart
< cend
)
133 res
= scm_call_1 (char_pred
,
134 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
135 if (scm_is_true (res
))
141 scm_remember_upto_here_1 (s
);
147 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
148 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
149 "Check if @var{char_pred} is true for every character in string\n"
152 "@var{char_pred} can be a character to check for every character equal\n"
153 "to that, or a character set (@pxref{Character Sets}) to check for\n"
154 "every character being in that set, or a predicate procedure to call.\n"
156 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
157 "successively on the characters from @var{start} to @var{end}. If\n"
158 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
159 "returns @code{#f}. The call on the last character (ie.@: at\n"
160 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
161 "return from that call is the return from @code{string-every}.\n"
163 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
164 "@var{end}) then the return is @code{#t}.\n")
165 #define FUNC_NAME s_scm_string_every
168 SCM res
= SCM_BOOL_T
;
170 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
173 if (SCM_CHARP (char_pred
))
176 for (i
= cstart
; i
< cend
; i
++)
177 if (scm_i_string_ref (s
, i
) != SCM_CHAR (char_pred
))
183 else if (SCM_CHARSETP (char_pred
))
186 for (i
= cstart
; i
< cend
; i
++)
187 if (!REF_IN_CHARSET (s
, i
, char_pred
))
195 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
196 char_pred
, SCM_ARG1
, FUNC_NAME
);
198 while (cstart
< cend
)
200 res
= scm_call_1 (char_pred
,
201 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
202 if (scm_is_false (res
))
208 scm_remember_upto_here_1 (s
);
214 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
216 "@var{proc} is an integer->char procedure. Construct a string\n"
217 "of size @var{len} by applying @var{proc} to each index to\n"
218 "produce the corresponding string element. The order in which\n"
219 "@var{proc} is applied to the indices is not specified.")
220 #define FUNC_NAME s_scm_string_tabulate
226 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
227 proc
, SCM_ARG1
, FUNC_NAME
);
229 SCM_ASSERT_RANGE (2, len
, scm_to_int (len
) >= 0);
230 clen
= scm_to_size_t (len
);
233 /* This function is more complicated than necessary for the sake
235 scm_t_wchar
*buf
= scm_malloc (clen
* sizeof (scm_t_wchar
));
240 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
243 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
245 if (SCM_CHAR (ch
) > 255)
247 buf
[i
] = SCM_CHAR (ch
);
252 scm_t_wchar
*wbuf
= NULL
;
253 res
= scm_i_make_wide_string (clen
, &wbuf
);
254 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
260 res
= scm_i_make_string (clen
, &nbuf
);
261 for (i
= 0; i
< clen
; i
++)
262 nbuf
[i
] = (unsigned char) buf
[i
];
272 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
273 (SCM str
, SCM start
, SCM end
),
274 "Convert the string @var{str} into a list of characters.")
275 #define FUNC_NAME s_scm_substring_to_list
279 SCM result
= SCM_EOL
;
281 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
285 /* This explicit narrow/wide logic (instead of just using
286 scm_i_string_ref) is for speed optimizaion. */
287 narrow
= scm_i_is_narrow_string (str
);
290 const char *buf
= scm_i_string_chars (str
);
291 while (cstart
< cend
)
294 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
299 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
300 while (cstart
< cend
)
303 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
306 scm_remember_upto_here_1 (str
);
311 /* We export scm_substring_to_list as "string->list" since it is
312 compatible and more general. This function remains for the benefit
313 of C code that used it.
317 scm_string_to_list (SCM str
)
319 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
322 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
324 "An efficient implementation of @code{(compose string->list\n"
328 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
330 #define FUNC_NAME s_scm_reverse_list_to_string
333 long i
= scm_ilength (chrs
), j
;
337 SCM_WRONG_TYPE_ARG (1, chrs
);
338 result
= scm_i_make_string (i
, &data
);
344 while (j
< i
&& scm_is_pair (rest
))
346 SCM elt
= SCM_CAR (rest
);
347 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
349 rest
= SCM_CDR (rest
);
353 result
= scm_i_string_start_writing (result
);
354 while (j
> 0 && scm_is_pair (rest
))
356 SCM elt
= SCM_CAR (rest
);
357 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
358 rest
= SCM_CDR (rest
);
361 scm_i_string_stop_writing ();
369 SCM_SYMBOL (scm_sym_infix
, "infix");
370 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
371 SCM_SYMBOL (scm_sym_suffix
, "suffix");
372 SCM_SYMBOL (scm_sym_prefix
, "prefix");
374 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
375 (SCM ls
, SCM delimiter
, SCM grammar
),
376 "Append the string in the string list @var{ls}, using the string\n"
377 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
378 "@var{grammar} is a symbol which specifies how the delimiter is\n"
379 "placed between the strings, and defaults to the symbol\n"
384 "Insert the separator between list elements. An empty string\n"
385 "will produce an empty list.\n"
386 "@item string-infix\n"
387 "Like @code{infix}, but will raise an error if given the empty\n"
390 "Insert the separator after every list element.\n"
392 "Insert the separator before each list element.\n"
394 #define FUNC_NAME s_scm_string_join
397 #define GRAM_STRICT_INFIX 1
398 #define GRAM_SUFFIX 2
399 #define GRAM_PREFIX 3
402 int gram
= GRAM_INFIX
;
404 long strings
= scm_ilength (ls
);
406 /* Validate the string list. */
408 SCM_WRONG_TYPE_ARG (1, ls
);
410 /* Validate the delimiter and record its length. */
411 if (SCM_UNBNDP (delimiter
))
413 delimiter
= scm_from_locale_string (" ");
418 SCM_VALIDATE_STRING (2, delimiter
);
419 del_len
= scm_i_string_length (delimiter
);
422 /* Validate the grammar symbol and remember the grammar. */
423 if (SCM_UNBNDP (grammar
))
425 else if (scm_is_eq (grammar
, scm_sym_infix
))
427 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
428 gram
= GRAM_STRICT_INFIX
;
429 else if (scm_is_eq (grammar
, scm_sym_suffix
))
431 else if (scm_is_eq (grammar
, scm_sym_prefix
))
434 SCM_WRONG_TYPE_ARG (3, grammar
);
436 /* Check grammar constraints. */
437 if (strings
== 0 && gram
== GRAM_STRICT_INFIX
)
438 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
441 result
= scm_i_make_string (0, NULL
);
447 case GRAM_STRICT_INFIX
:
448 while (scm_is_pair (tmp
))
450 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
451 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
452 result
= scm_string_append (scm_list_2 (result
, delimiter
));
457 while (scm_is_pair (tmp
))
459 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
461 result
= scm_string_append (scm_list_2 (result
, delimiter
));
466 while (scm_is_pair (tmp
))
469 result
= scm_string_append (scm_list_2 (result
, delimiter
));
470 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
478 #undef GRAM_STRICT_INFIX
485 /* There are a number of functions to consider here for Scheme and C:
487 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
488 substring/copy STR start [end] ;; Guile variant of R5RS substring
490 scm_string_copy (str) ;; Old function from Guile
491 scm_substring_copy (str, [start, [end]])
492 ;; C version of SRFI-13 string-copy
493 ;; and C version of substring/copy
495 The C function underlying string-copy is not exported to C
496 programs. scm_substring_copy is defined in strings.c as the
497 underlying function of substring/copy and allows an optional START
501 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
503 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
504 (SCM str
, SCM start
, SCM end
),
505 "Return a freshly allocated copy of the string @var{str}. If\n"
506 "given, @var{start} and @var{end} delimit the portion of\n"
507 "@var{str} which is copied.")
508 #define FUNC_NAME s_scm_srfi13_substring_copy
512 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
515 return scm_i_substring_copy (str
, cstart
, cend
);
520 scm_string_copy (SCM str
)
522 if (!scm_is_string (str
))
523 scm_wrong_type_arg ("scm_string_copy", 0, str
);
525 return scm_i_substring (str
, 0, scm_i_string_length (str
));
528 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
529 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
530 "Copy the sequence of characters from index range [@var{start},\n"
531 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
532 "at index @var{tstart}. The characters are copied left-to-right\n"
533 "or right-to-left as needed -- the copy is guaranteed to work,\n"
534 "even if @var{target} and @var{s} are the same string. It is an\n"
535 "error if the copy operation runs off the end of the target\n"
537 #define FUNC_NAME s_scm_string_copy_x
539 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
540 SCM sdummy
= SCM_UNDEFINED
;
542 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
545 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
549 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
551 target
= scm_i_string_start_writing (target
);
552 for (i
= 0; i
< cend
- cstart
; i
++)
554 scm_i_string_set_x (target
, ctstart
+ i
,
555 scm_i_string_ref (s
, cstart
+ i
));
557 scm_i_string_stop_writing ();
558 scm_remember_upto_here_1 (target
);
560 return SCM_UNSPECIFIED
;
564 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
565 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
566 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
567 "into @var{str2} beginning at position @var{start2}.\n"
568 "@var{str1} and @var{str2} can be the same string.")
569 #define FUNC_NAME s_scm_substring_move_x
571 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
575 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
577 "Return the @var{n} first characters of @var{s}.")
578 #define FUNC_NAME s_scm_string_take
580 return scm_substring (s
, SCM_INUM0
, n
);
585 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
587 "Return all but the first @var{n} characters of @var{s}.")
588 #define FUNC_NAME s_scm_string_drop
590 return scm_substring (s
, n
, SCM_UNDEFINED
);
595 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
597 "Return the @var{n} last characters of @var{s}.")
598 #define FUNC_NAME s_scm_string_take_right
600 return scm_substring (s
,
601 scm_difference (scm_string_length (s
), n
),
607 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
609 "Return all but the last @var{n} characters of @var{s}.")
610 #define FUNC_NAME s_scm_string_drop_right
612 return scm_substring (s
,
614 scm_difference (scm_string_length (s
), n
));
619 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
620 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
621 "Take that characters from @var{start} to @var{end} from the\n"
622 "string @var{s} and return a new string, right-padded by the\n"
623 "character @var{chr} to length @var{len}. If the resulting\n"
624 "string is longer than @var{len}, it is truncated on the right.")
625 #define FUNC_NAME s_scm_string_pad
627 size_t cstart
, cend
, clen
;
629 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
632 clen
= scm_to_size_t (len
);
634 if (SCM_UNBNDP (chr
))
635 chr
= SCM_MAKE_CHAR (' ');
638 SCM_VALIDATE_CHAR (3, chr
);
640 if (clen
< (cend
- cstart
))
641 return scm_i_substring (s
, cend
- clen
, cend
);
645 result
= (scm_string_append
646 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
647 scm_i_substring (s
, cstart
, cend
))));
654 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
655 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
656 "Take that characters from @var{start} to @var{end} from the\n"
657 "string @var{s} and return a new string, left-padded by the\n"
658 "character @var{chr} to length @var{len}. If the resulting\n"
659 "string is longer than @var{len}, it is truncated on the left.")
660 #define FUNC_NAME s_scm_string_pad_right
662 size_t cstart
, cend
, clen
;
664 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
667 clen
= scm_to_size_t (len
);
669 if (SCM_UNBNDP (chr
))
670 chr
= SCM_MAKE_CHAR (' ');
673 SCM_VALIDATE_CHAR (3, chr
);
675 if (clen
< (cend
- cstart
))
676 return scm_i_substring (s
, cstart
, cstart
+ clen
);
681 result
= (scm_string_append
682 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
683 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
691 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
692 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
693 "Trim @var{s} by skipping over all characters on the left\n"
694 "that satisfy the parameter @var{char_pred}:\n"
698 "if it is the character @var{ch}, characters equal to\n"
699 "@var{ch} are trimmed,\n"
702 "if it is a procedure @var{pred} characters that\n"
703 "satisfy @var{pred} are trimmed,\n"
706 "if it is a character set, characters in that set are trimmed.\n"
709 "If called without a @var{char_pred} argument, all whitespace is\n"
711 #define FUNC_NAME s_scm_string_trim
715 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
718 if (SCM_UNBNDP (char_pred
))
720 while (cstart
< cend
)
722 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
727 else if (SCM_CHARP (char_pred
))
729 while (cstart
< cend
)
731 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
736 else if (SCM_CHARSETP (char_pred
))
738 while (cstart
< cend
)
740 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
747 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
748 char_pred
, SCM_ARG2
, FUNC_NAME
);
750 while (cstart
< cend
)
754 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
755 if (scm_is_false (res
))
760 return scm_i_substring (s
, cstart
, cend
);
765 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
766 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
767 "Trim @var{s} by skipping over all characters on the right\n"
768 "that satisfy the parameter @var{char_pred}:\n"
772 "if it is the character @var{ch}, characters equal to @var{ch}\n"
776 "if it is a procedure @var{pred} characters that satisfy\n"
777 "@var{pred} are trimmed,\n"
780 "if it is a character sets, all characters in that set are\n"
784 "If called without a @var{char_pred} argument, all whitespace is\n"
786 #define FUNC_NAME s_scm_string_trim_right
790 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
793 if (SCM_UNBNDP (char_pred
))
795 while (cstart
< cend
)
797 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
802 else if (SCM_CHARP (char_pred
))
804 while (cstart
< cend
)
806 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
811 else if (SCM_CHARSETP (char_pred
))
813 while (cstart
< cend
)
815 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
822 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
823 char_pred
, SCM_ARG2
, FUNC_NAME
);
825 while (cstart
< cend
)
829 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
830 if (scm_is_false (res
))
835 return scm_i_substring (s
, cstart
, cend
);
840 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
841 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
842 "Trim @var{s} by skipping over all characters on both sides of\n"
843 "the string that satisfy the parameter @var{char_pred}:\n"
847 "if it is the character @var{ch}, characters equal to @var{ch}\n"
851 "if it is a procedure @var{pred} characters that satisfy\n"
852 "@var{pred} are trimmed,\n"
855 "if it is a character set, the characters in the set are\n"
859 "If called without a @var{char_pred} argument, all whitespace is\n"
861 #define FUNC_NAME s_scm_string_trim_both
865 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
868 if (SCM_UNBNDP (char_pred
))
870 while (cstart
< cend
)
872 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
876 while (cstart
< cend
)
878 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
883 else if (SCM_CHARP (char_pred
))
885 while (cstart
< cend
)
887 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
891 while (cstart
< cend
)
893 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
898 else if (SCM_CHARSETP (char_pred
))
900 while (cstart
< cend
)
902 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
906 while (cstart
< cend
)
908 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
915 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
916 char_pred
, SCM_ARG2
, FUNC_NAME
);
918 while (cstart
< cend
)
922 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
923 if (scm_is_false (res
))
927 while (cstart
< cend
)
931 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
932 if (scm_is_false (res
))
937 return scm_i_substring (s
, cstart
, cend
);
942 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
943 (SCM str
, SCM chr
, SCM start
, SCM end
),
944 "Stores @var{chr} in every element of the given @var{str} and\n"
945 "returns an unspecified value.")
946 #define FUNC_NAME s_scm_substring_fill_x
951 /* Older versions of Guile provided the function
952 scm_substring_fill_x with the following order of arguments:
956 We accomodate this here by detecting such a usage and reordering
967 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
970 SCM_VALIDATE_CHAR (2, chr
);
973 str
= scm_i_string_start_writing (str
);
974 for (k
= cstart
; k
< cend
; k
++)
975 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
976 scm_i_string_stop_writing ();
978 return SCM_UNSPECIFIED
;
983 scm_string_fill_x (SCM str
, SCM chr
)
985 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
988 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
989 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
990 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
991 "mismatch index, depending upon whether @var{s1} is less than,\n"
992 "equal to, or greater than @var{s2}. The mismatch index is the\n"
993 "largest index @var{i} such that for every 0 <= @var{j} <\n"
994 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
995 "@var{i} is the first position that does not match.")
996 #define FUNC_NAME s_scm_string_compare
998 size_t cstart1
, cend1
, cstart2
, cend2
;
1001 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1004 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1007 SCM_VALIDATE_PROC (3, proc_lt
);
1008 SCM_VALIDATE_PROC (4, proc_eq
);
1009 SCM_VALIDATE_PROC (5, proc_gt
);
1011 while (cstart1
< cend1
&& cstart2
< cend2
)
1013 if (scm_i_string_ref (s1
, cstart1
)
1014 < scm_i_string_ref (s2
, cstart2
))
1019 else if (scm_i_string_ref (s1
, cstart1
)
1020 > scm_i_string_ref (s2
, cstart2
))
1028 if (cstart1
< cend1
)
1030 else if (cstart2
< cend2
)
1036 scm_remember_upto_here_2 (s1
, s2
);
1037 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1042 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1043 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1044 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1045 "mismatch index, depending upon whether @var{s1} is less than,\n"
1046 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1047 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1048 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1049 "@var{i} is the first position where the lowercased letters \n"
1051 #define FUNC_NAME s_scm_string_compare_ci
1053 size_t cstart1
, cend1
, cstart2
, cend2
;
1056 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1059 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1062 SCM_VALIDATE_PROC (3, proc_lt
);
1063 SCM_VALIDATE_PROC (4, proc_eq
);
1064 SCM_VALIDATE_PROC (5, proc_gt
);
1066 while (cstart1
< cend1
&& cstart2
< cend2
)
1068 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1069 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1074 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1075 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1084 if (cstart1
< cend1
)
1086 else if (cstart2
< cend2
)
1092 scm_remember_upto_here (s1
, s2
);
1093 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1097 /* This function compares two substrings, S1 from START1 to END1 and
1098 S2 from START2 to END2, possibly case insensitively, and returns
1099 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1100 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1101 longer, or equal. */
1103 compare_strings (const char *fname
, int case_insensitive
,
1104 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1105 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1107 size_t cstart1
, cend1
, cstart2
, cend2
;
1111 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1114 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1118 while (cstart1
< cend1
&& cstart2
< cend2
)
1120 if (case_insensitive
)
1122 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1123 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1127 a
= scm_i_string_ref (s1
, cstart1
);
1128 b
= scm_i_string_ref (s2
, cstart2
);
1143 if (cstart1
< cend1
)
1148 else if (cstart2
< cend2
)
1160 scm_remember_upto_here_2 (s1
, s2
);
1165 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1166 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1167 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1169 #define FUNC_NAME s_scm_string_eq
1171 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1172 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1173 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1174 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1176 /* Fast path for this common case, which avoids the repeated calls to
1177 `scm_i_string_ref'. */
1180 len1
= scm_i_string_length (s1
);
1181 len2
= scm_i_string_length (s2
);
1183 if (SCM_LIKELY (len1
== len2
))
1185 if (!scm_i_is_narrow_string (s1
))
1188 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1189 scm_i_string_data (s2
),
1194 return compare_strings (FUNC_NAME
, 0,
1195 s1
, s2
, start1
, end1
, start2
, end2
,
1196 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1201 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1202 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1203 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1205 #define FUNC_NAME s_scm_string_neq
1207 return compare_strings (FUNC_NAME
, 0,
1208 s1
, s2
, start1
, end1
, start2
, end2
,
1209 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1214 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1215 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1216 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1217 "true value otherwise.")
1218 #define FUNC_NAME s_scm_string_lt
1220 return compare_strings (FUNC_NAME
, 0,
1221 s1
, s2
, start1
, end1
, start2
, end2
,
1222 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1227 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1228 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1229 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1230 "true value otherwise.")
1231 #define FUNC_NAME s_scm_string_gt
1233 return compare_strings (FUNC_NAME
, 0,
1234 s1
, s2
, start1
, end1
, start2
, end2
,
1235 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1240 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1241 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1242 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1244 #define FUNC_NAME s_scm_string_le
1246 return compare_strings (FUNC_NAME
, 0,
1247 s1
, s2
, start1
, end1
, start2
, end2
,
1248 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1253 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1254 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1255 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1257 #define FUNC_NAME s_scm_string_ge
1259 return compare_strings (FUNC_NAME
, 0,
1260 s1
, s2
, start1
, end1
, start2
, end2
,
1261 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1266 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1267 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1268 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1269 "value otherwise. The character comparison is done\n"
1270 "case-insensitively.")
1271 #define FUNC_NAME s_scm_string_ci_eq
1273 return compare_strings (FUNC_NAME
, 1,
1274 s1
, s2
, start1
, end1
, start2
, end2
,
1275 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1280 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1281 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1282 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1283 "value otherwise. The character comparison is done\n"
1284 "case-insensitively.")
1285 #define FUNC_NAME s_scm_string_ci_neq
1287 return compare_strings (FUNC_NAME
, 1,
1288 s1
, s2
, start1
, end1
, start2
, end2
,
1289 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1294 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1295 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1296 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1297 "true value otherwise. The character comparison is done\n"
1298 "case-insensitively.")
1299 #define FUNC_NAME s_scm_string_ci_lt
1301 return compare_strings (FUNC_NAME
, 1,
1302 s1
, s2
, start1
, end1
, start2
, end2
,
1303 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1308 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1309 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1310 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1311 "true value otherwise. The character comparison is done\n"
1312 "case-insensitively.")
1313 #define FUNC_NAME s_scm_string_ci_gt
1315 return compare_strings (FUNC_NAME
, 1,
1316 s1
, s2
, start1
, end1
, start2
, end2
,
1317 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1322 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1323 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1324 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1325 "value otherwise. The character comparison is done\n"
1326 "case-insensitively.")
1327 #define FUNC_NAME s_scm_string_ci_le
1329 return compare_strings (FUNC_NAME
, 1,
1330 s1
, s2
, start1
, end1
, start2
, end2
,
1331 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1336 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1337 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1338 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1339 "otherwise. The character comparison is done\n"
1340 "case-insensitively.")
1341 #define FUNC_NAME s_scm_string_ci_ge
1343 return compare_strings (FUNC_NAME
, 1,
1344 s1
, s2
, start1
, end1
, start2
, end2
,
1345 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1349 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1350 (SCM s
, SCM bound
, SCM start
, SCM end
),
1351 "Compute a hash value for @var{S}. the optional argument "
1352 "@var{bound} is a non-negative exact "
1353 "integer specifying the range of the hash function. "
1354 "A positive value restricts the return value to the "
1356 #define FUNC_NAME s_scm_substring_hash
1358 if (SCM_UNBNDP (bound
))
1359 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1360 if (SCM_UNBNDP (start
))
1362 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1366 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1367 (SCM s
, SCM bound
, SCM start
, SCM end
),
1368 "Compute a hash value for @var{S}. the optional argument "
1369 "@var{bound} is a non-negative exact "
1370 "integer specifying the range of the hash function. "
1371 "A positive value restricts the return value to the "
1373 #define FUNC_NAME s_scm_substring_hash_ci
1375 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1377 SCM_UNDEFINED
, SCM_UNDEFINED
);
1381 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1382 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1383 "Return the length of the longest common prefix of the two\n"
1385 #define FUNC_NAME s_scm_string_prefix_length
1387 size_t cstart1
, cend1
, cstart2
, cend2
;
1390 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1393 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1397 while (cstart1
< cend1
&& cstart2
< cend2
)
1399 if (scm_i_string_ref (s1
, cstart1
)
1400 != scm_i_string_ref (s2
, cstart2
))
1408 scm_remember_upto_here_2 (s1
, s2
);
1409 return scm_from_size_t (len
);
1414 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1415 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1416 "Return the length of the longest common prefix of the two\n"
1417 "strings, ignoring character case.")
1418 #define FUNC_NAME s_scm_string_prefix_length_ci
1420 size_t cstart1
, cend1
, cstart2
, cend2
;
1423 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1426 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1429 while (cstart1
< cend1
&& cstart2
< cend2
)
1431 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1432 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1440 scm_remember_upto_here_2 (s1
, s2
);
1441 return scm_from_size_t (len
);
1446 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1447 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1448 "Return the length of the longest common suffix of the two\n"
1450 #define FUNC_NAME s_scm_string_suffix_length
1452 size_t cstart1
, cend1
, cstart2
, cend2
;
1455 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1458 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1461 while (cstart1
< cend1
&& cstart2
< cend2
)
1465 if (scm_i_string_ref (s1
, cend1
)
1466 != scm_i_string_ref (s2
, cend2
))
1472 scm_remember_upto_here_2 (s1
, s2
);
1473 return scm_from_size_t (len
);
1478 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1479 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1480 "Return the length of the longest common suffix of the two\n"
1481 "strings, ignoring character case.")
1482 #define FUNC_NAME s_scm_string_suffix_length_ci
1484 size_t cstart1
, cend1
, cstart2
, cend2
;
1487 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1490 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1493 while (cstart1
< cend1
&& cstart2
< cend2
)
1497 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1498 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1504 scm_remember_upto_here_2 (s1
, s2
);
1505 return scm_from_size_t (len
);
1510 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1511 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1512 "Is @var{s1} a prefix of @var{s2}?")
1513 #define FUNC_NAME s_scm_string_prefix_p
1515 size_t cstart1
, cend1
, cstart2
, cend2
;
1516 size_t len
= 0, len1
;
1518 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1521 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1524 len1
= cend1
- cstart1
;
1525 while (cstart1
< cend1
&& cstart2
< cend2
)
1527 if (scm_i_string_ref (s1
, cstart1
)
1528 != scm_i_string_ref (s2
, cstart2
))
1536 scm_remember_upto_here_2 (s1
, s2
);
1537 return scm_from_bool (len
== len1
);
1542 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1543 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1544 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1545 #define FUNC_NAME s_scm_string_prefix_ci_p
1547 size_t cstart1
, cend1
, cstart2
, cend2
;
1548 size_t len
= 0, len1
;
1550 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1553 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1556 len1
= cend1
- cstart1
;
1557 while (cstart1
< cend1
&& cstart2
< cend2
)
1559 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1560 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1569 scm_remember_upto_here_2 (s1
, s2
);
1570 return scm_from_bool (len
== len1
);
1575 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1576 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1577 "Is @var{s1} a suffix of @var{s2}?")
1578 #define FUNC_NAME s_scm_string_suffix_p
1580 size_t cstart1
, cend1
, cstart2
, cend2
;
1581 size_t len
= 0, len1
;
1583 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1586 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1589 len1
= cend1
- cstart1
;
1590 while (cstart1
< cend1
&& cstart2
< cend2
)
1594 if (scm_i_string_ref (s1
, cend1
)
1595 != scm_i_string_ref (s2
, cend2
))
1601 scm_remember_upto_here_2 (s1
, s2
);
1602 return scm_from_bool (len
== len1
);
1607 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1608 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1609 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1610 #define FUNC_NAME s_scm_string_suffix_ci_p
1612 size_t cstart1
, cend1
, cstart2
, cend2
;
1613 size_t len
= 0, len1
;
1615 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1618 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1621 len1
= cend1
- cstart1
;
1622 while (cstart1
< cend1
&& cstart2
< cend2
)
1626 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1627 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1633 scm_remember_upto_here_2 (s1
, s2
);
1634 return scm_from_bool (len
== len1
);
1639 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1640 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1641 "Search through the string @var{s} from left to right, returning\n"
1642 "the index of the first occurence of a character which\n"
1644 "@itemize @bullet\n"
1646 "equals @var{char_pred}, if it is character,\n"
1649 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1652 "is in the set @var{char_pred}, if it is a character set.\n"
1654 #define FUNC_NAME s_scm_string_index
1656 size_t cstart
, cend
;
1658 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1661 if (SCM_CHARP (char_pred
))
1663 while (cstart
< cend
)
1665 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1670 else if (SCM_CHARSETP (char_pred
))
1672 while (cstart
< cend
)
1674 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1681 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1682 char_pred
, SCM_ARG2
, FUNC_NAME
);
1684 while (cstart
< cend
)
1687 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1688 if (scm_is_true (res
))
1694 scm_remember_upto_here_1 (s
);
1698 scm_remember_upto_here_1 (s
);
1699 return scm_from_size_t (cstart
);
1703 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1704 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1705 "Search through the string @var{s} from right to left, returning\n"
1706 "the index of the last occurence of a character which\n"
1708 "@itemize @bullet\n"
1710 "equals @var{char_pred}, if it is character,\n"
1713 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1716 "is in the set if @var{char_pred} is a character set.\n"
1718 #define FUNC_NAME s_scm_string_index_right
1720 size_t cstart
, cend
;
1722 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1725 if (SCM_CHARP (char_pred
))
1727 while (cstart
< cend
)
1730 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1734 else if (SCM_CHARSETP (char_pred
))
1736 while (cstart
< cend
)
1739 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1745 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1746 char_pred
, SCM_ARG2
, FUNC_NAME
);
1748 while (cstart
< cend
)
1752 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1753 if (scm_is_true (res
))
1758 scm_remember_upto_here_1 (s
);
1762 scm_remember_upto_here_1 (s
);
1763 return scm_from_size_t (cend
);
1767 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1768 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1769 "Search through the string @var{s} from right to left, returning\n"
1770 "the index of the last occurence of a character which\n"
1772 "@itemize @bullet\n"
1774 "equals @var{char_pred}, if it is character,\n"
1777 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1780 "is in the set if @var{char_pred} is a character set.\n"
1782 #define FUNC_NAME s_scm_string_rindex
1784 return scm_string_index_right (s
, char_pred
, start
, end
);
1788 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1789 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1790 "Search through the string @var{s} from left to right, returning\n"
1791 "the index of the first occurence of a character which\n"
1793 "@itemize @bullet\n"
1795 "does not equal @var{char_pred}, if it is character,\n"
1798 "does not satisify the predicate @var{char_pred}, if it is a\n"
1802 "is not in the set if @var{char_pred} is a character set.\n"
1804 #define FUNC_NAME s_scm_string_skip
1806 size_t cstart
, cend
;
1808 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1811 if (SCM_CHARP (char_pred
))
1813 while (cstart
< cend
)
1815 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1820 else if (SCM_CHARSETP (char_pred
))
1822 while (cstart
< cend
)
1824 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1831 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1832 char_pred
, SCM_ARG2
, FUNC_NAME
);
1834 while (cstart
< cend
)
1837 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1838 if (scm_is_false (res
))
1844 scm_remember_upto_here_1 (s
);
1848 scm_remember_upto_here_1 (s
);
1849 return scm_from_size_t (cstart
);
1854 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1855 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1856 "Search through the string @var{s} from right to left, returning\n"
1857 "the index of the last occurence of a character which\n"
1859 "@itemize @bullet\n"
1861 "does not equal @var{char_pred}, if it is character,\n"
1864 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1868 "is not in the set if @var{char_pred} is a character set.\n"
1870 #define FUNC_NAME s_scm_string_skip_right
1872 size_t cstart
, cend
;
1874 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1877 if (SCM_CHARP (char_pred
))
1879 while (cstart
< cend
)
1882 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1886 else if (SCM_CHARSETP (char_pred
))
1888 while (cstart
< cend
)
1891 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1897 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1898 char_pred
, SCM_ARG2
, FUNC_NAME
);
1900 while (cstart
< cend
)
1904 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1905 if (scm_is_false (res
))
1910 scm_remember_upto_here_1 (s
);
1914 scm_remember_upto_here_1 (s
);
1915 return scm_from_size_t (cend
);
1921 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1922 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1923 "Return the count of the number of characters in the string\n"
1926 "@itemize @bullet\n"
1928 "equals @var{char_pred}, if it is character,\n"
1931 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1934 "is in the set @var{char_pred}, if it is a character set.\n"
1936 #define FUNC_NAME s_scm_string_count
1938 size_t cstart
, cend
;
1941 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1944 if (SCM_CHARP (char_pred
))
1946 while (cstart
< cend
)
1948 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1953 else if (SCM_CHARSETP (char_pred
))
1955 while (cstart
< cend
)
1957 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1964 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1965 char_pred
, SCM_ARG2
, FUNC_NAME
);
1967 while (cstart
< cend
)
1970 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1971 if (scm_is_true (res
))
1977 scm_remember_upto_here_1 (s
);
1978 return scm_from_size_t (count
);
1983 /* FIXME::martin: This should definitely get implemented more
1984 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1986 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1987 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1988 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1989 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1990 "The optional start/end indices restrict the operation to the\n"
1991 "indicated substrings.")
1992 #define FUNC_NAME s_scm_string_contains
1994 size_t cstart1
, cend1
, cstart2
, cend2
;
1997 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2000 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2003 len2
= cend2
- cstart2
;
2004 if (cend1
- cstart1
>= len2
)
2005 while (cstart1
<= cend1
- len2
)
2011 && (scm_i_string_ref (s1
, i
)
2012 == scm_i_string_ref (s2
, j
)))
2019 scm_remember_upto_here_2 (s1
, s2
);
2020 return scm_from_size_t (cstart1
);
2025 scm_remember_upto_here_2 (s1
, s2
);
2031 /* FIXME::martin: This should definitely get implemented more
2032 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2034 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2035 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2036 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2037 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2038 "The optional start/end indices restrict the operation to the\n"
2039 "indicated substrings. Character comparison is done\n"
2040 "case-insensitively.")
2041 #define FUNC_NAME s_scm_string_contains_ci
2043 size_t cstart1
, cend1
, cstart2
, cend2
;
2046 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2049 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2052 len2
= cend2
- cstart2
;
2053 if (cend1
- cstart1
>= len2
)
2054 while (cstart1
<= cend1
- len2
)
2060 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2061 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2068 scm_remember_upto_here_2 (s1
, s2
);
2069 return scm_from_size_t (cstart1
);
2074 scm_remember_upto_here_2 (s1
, s2
);
2080 /* Helper function for the string uppercase conversion functions. */
2082 string_upcase_x (SCM v
, size_t start
, size_t end
)
2086 v
= scm_i_string_start_writing (v
);
2087 for (k
= start
; k
< end
; ++k
)
2088 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2089 scm_i_string_stop_writing ();
2090 scm_remember_upto_here_1 (v
);
2095 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2096 (SCM str
, SCM start
, SCM end
),
2097 "Destructively upcase every character in @code{str}.\n"
2100 "(string-upcase! y)\n"
2101 "@result{} \"ARRDEFG\"\n"
2103 "@result{} \"ARRDEFG\"\n"
2105 #define FUNC_NAME s_scm_substring_upcase_x
2107 size_t cstart
, cend
;
2109 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2112 return string_upcase_x (str
, cstart
, cend
);
2117 scm_string_upcase_x (SCM str
)
2119 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2122 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2123 (SCM str
, SCM start
, SCM end
),
2124 "Upcase every character in @code{str}.")
2125 #define FUNC_NAME s_scm_substring_upcase
2127 size_t cstart
, cend
;
2129 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2132 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2137 scm_string_upcase (SCM str
)
2139 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2142 /* Helper function for the string lowercase conversion functions.
2143 * No argument checking is performed. */
2145 string_downcase_x (SCM v
, size_t start
, size_t end
)
2149 v
= scm_i_string_start_writing (v
);
2150 for (k
= start
; k
< end
; ++k
)
2151 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2152 scm_i_string_stop_writing ();
2153 scm_remember_upto_here_1 (v
);
2158 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2159 (SCM str
, SCM start
, SCM end
),
2160 "Destructively downcase every character in @var{str}.\n"
2164 "@result{} \"ARRDEFG\"\n"
2165 "(string-downcase! y)\n"
2166 "@result{} \"arrdefg\"\n"
2168 "@result{} \"arrdefg\"\n"
2170 #define FUNC_NAME s_scm_substring_downcase_x
2172 size_t cstart
, cend
;
2174 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2177 return string_downcase_x (str
, cstart
, cend
);
2182 scm_string_downcase_x (SCM str
)
2184 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2187 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2188 (SCM str
, SCM start
, SCM end
),
2189 "Downcase every character in @var{str}.")
2190 #define FUNC_NAME s_scm_substring_downcase
2192 size_t cstart
, cend
;
2194 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2197 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2202 scm_string_downcase (SCM str
)
2204 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2207 /* Helper function for the string capitalization functions.
2208 * No argument checking is performed. */
2210 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2216 str
= scm_i_string_start_writing (str
);
2217 for(i
= start
; i
< end
; i
++)
2219 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2220 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2224 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2229 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2235 scm_i_string_stop_writing ();
2236 scm_remember_upto_here_1 (str
);
2242 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2243 (SCM str
, SCM start
, SCM end
),
2244 "Destructively titlecase every first character in a word in\n"
2246 #define FUNC_NAME s_scm_string_titlecase_x
2248 size_t cstart
, cend
;
2250 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2253 return string_titlecase_x (str
, cstart
, cend
);
2258 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2259 (SCM str
, SCM start
, SCM end
),
2260 "Titlecase every first character in a word in @var{str}.")
2261 #define FUNC_NAME s_scm_string_titlecase
2263 size_t cstart
, cend
;
2265 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2268 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2272 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2274 "Upcase the first character of every word in @var{str}\n"
2275 "destructively and return @var{str}.\n"
2278 "y @result{} \"hello world\"\n"
2279 "(string-capitalize! y) @result{} \"Hello World\"\n"
2280 "y @result{} \"Hello World\"\n"
2282 #define FUNC_NAME s_scm_string_capitalize_x
2284 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2289 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2291 "Return a freshly allocated string with the characters in\n"
2292 "@var{str}, where the first character of every word is\n"
2294 #define FUNC_NAME s_scm_string_capitalize
2296 return scm_string_capitalize_x (scm_string_copy (str
));
2301 /* Reverse the portion of @var{str} between str[cstart] (including)
2302 and str[cend] excluding. */
2304 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2308 str
= scm_i_string_start_writing (str
);
2312 while (cstart
< cend
)
2314 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2315 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2316 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2321 scm_i_string_stop_writing ();
2325 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2326 (SCM str
, SCM start
, SCM end
),
2327 "Reverse the string @var{str}. The optional arguments\n"
2328 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2330 #define FUNC_NAME s_scm_string_reverse
2332 size_t cstart
, cend
;
2335 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2338 result
= scm_string_copy (str
);
2339 string_reverse_x (result
, cstart
, cend
);
2340 scm_remember_upto_here_1 (str
);
2346 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2347 (SCM str
, SCM start
, SCM end
),
2348 "Reverse the string @var{str} in-place. The optional arguments\n"
2349 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2350 "operate on. The return value is unspecified.")
2351 #define FUNC_NAME s_scm_string_reverse_x
2353 size_t cstart
, cend
;
2355 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2359 string_reverse_x (str
, cstart
, cend
);
2360 scm_remember_upto_here_1 (str
);
2361 return SCM_UNSPECIFIED
;
2366 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2368 "Like @code{string-append}, but the result may share memory\n"
2369 "with the argument strings.")
2370 #define FUNC_NAME s_scm_string_append_shared
2372 /* If "rest" contains just one non-empty string, return that.
2373 If it's entirely empty strings, then return scm_nullstr.
2374 Otherwise use scm_string_concatenate. */
2376 SCM ret
= scm_nullstr
;
2377 int seen_nonempty
= 0;
2380 SCM_VALIDATE_REST_ARGUMENT (rest
);
2382 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2385 if (!scm_is_string (s
))
2386 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2387 if (scm_i_string_length (s
) != 0)
2390 /* two or more non-empty strings, need full concat */
2391 return scm_string_append (rest
);
2402 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2404 "Append the elements of @var{ls} (which must be strings)\n"
2405 "together into a single string. Guaranteed to return a freshly\n"
2406 "allocated string.")
2407 #define FUNC_NAME s_scm_string_concatenate
2409 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2410 return scm_string_append (ls
);
2415 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2416 (SCM ls
, SCM final_string
, SCM end
),
2417 "Without optional arguments, this procedure is equivalent to\n"
2420 "(string-concatenate (reverse ls))\n"
2423 "If the optional argument @var{final_string} is specified, it is\n"
2424 "consed onto the beginning to @var{ls} before performing the\n"
2425 "list-reverse and string-concatenate operations. If @var{end}\n"
2426 "is given, only the characters of @var{final_string} up to index\n"
2427 "@var{end} are used.\n"
2429 "Guaranteed to return a freshly allocated string.")
2430 #define FUNC_NAME s_scm_string_concatenate_reverse
2432 if (!SCM_UNBNDP (end
))
2433 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2435 if (!SCM_UNBNDP (final_string
))
2436 ls
= scm_cons (final_string
, ls
);
2438 return scm_string_concatenate (scm_reverse (ls
));
2443 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2445 "Like @code{string-concatenate}, but the result may share memory\n"
2446 "with the strings in the list @var{ls}.")
2447 #define FUNC_NAME s_scm_string_concatenate_shared
2449 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2450 return scm_string_append_shared (ls
);
2455 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2456 (SCM ls
, SCM final_string
, SCM end
),
2457 "Like @code{string-concatenate-reverse}, but the result may\n"
2458 "share memory with the the strings in the @var{ls} arguments.")
2459 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2461 /* Just call the non-sharing version. */
2462 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2467 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2468 (SCM proc
, SCM s
, SCM start
, SCM end
),
2469 "@var{proc} is a char->char procedure, it is mapped over\n"
2470 "@var{s}. The order in which the procedure is applied to the\n"
2471 "string elements is not specified.")
2472 #define FUNC_NAME s_scm_string_map
2475 size_t cstart
, cend
;
2478 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2479 proc
, SCM_ARG1
, FUNC_NAME
);
2480 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2483 result
= scm_i_make_string (cend
- cstart
, NULL
);
2485 while (cstart
< cend
)
2487 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2488 if (!SCM_CHARP (ch
))
2489 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2491 result
= scm_i_string_start_writing (result
);
2492 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2493 scm_i_string_stop_writing ();
2502 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2503 (SCM proc
, SCM s
, SCM start
, SCM end
),
2504 "@var{proc} is a char->char procedure, it is mapped over\n"
2505 "@var{s}. The order in which the procedure is applied to the\n"
2506 "string elements is not specified. The string @var{s} is\n"
2507 "modified in-place, the return value is not specified.")
2508 #define FUNC_NAME s_scm_string_map_x
2510 size_t cstart
, cend
;
2512 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2513 proc
, SCM_ARG1
, FUNC_NAME
);
2514 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2517 while (cstart
< cend
)
2519 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2520 if (!SCM_CHARP (ch
))
2521 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2522 s
= scm_i_string_start_writing (s
);
2523 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2524 scm_i_string_stop_writing ();
2527 return SCM_UNSPECIFIED
;
2532 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2533 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2534 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2535 "as the terminating element, from left to right. @var{kons}\n"
2536 "must expect two arguments: The actual character and the last\n"
2537 "result of @var{kons}' application.")
2538 #define FUNC_NAME s_scm_string_fold
2540 size_t cstart
, cend
;
2543 SCM_VALIDATE_PROC (1, kons
);
2544 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2548 while (cstart
< cend
)
2550 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2554 scm_remember_upto_here_1 (s
);
2560 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2561 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2562 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2563 "as the terminating element, from right to left. @var{kons}\n"
2564 "must expect two arguments: The actual character and the last\n"
2565 "result of @var{kons}' application.")
2566 #define FUNC_NAME s_scm_string_fold_right
2568 size_t cstart
, cend
;
2571 SCM_VALIDATE_PROC (1, kons
);
2572 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2576 while (cstart
< cend
)
2578 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2582 scm_remember_upto_here_1 (s
);
2588 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2589 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2590 "@itemize @bullet\n"
2591 "@item @var{g} is used to generate a series of @emph{seed}\n"
2592 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2593 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2595 "@item @var{p} tells us when to stop -- when it returns true\n"
2596 "when applied to one of these seed values.\n"
2597 "@item @var{f} maps each seed value to the corresponding\n"
2598 "character in the result string. These chars are assembled\n"
2599 "into the string in a left-to-right order.\n"
2600 "@item @var{base} is the optional initial/leftmost portion\n"
2601 "of the constructed string; it default to the empty\n"
2603 "@item @var{make_final} is applied to the terminal seed\n"
2604 "value (on which @var{p} returns true) to produce\n"
2605 "the final/rightmost portion of the constructed string.\n"
2606 "It defaults to @code{(lambda (x) "")}.\n"
2608 #define FUNC_NAME s_scm_string_unfold
2612 SCM_VALIDATE_PROC (1, p
);
2613 SCM_VALIDATE_PROC (2, f
);
2614 SCM_VALIDATE_PROC (3, g
);
2615 if (!SCM_UNBNDP (base
))
2617 SCM_VALIDATE_STRING (5, base
);
2621 ans
= scm_i_make_string (0, NULL
);
2622 if (!SCM_UNBNDP (make_final
))
2623 SCM_VALIDATE_PROC (6, make_final
);
2625 res
= scm_call_1 (p
, seed
);
2626 while (scm_is_false (res
))
2630 SCM ch
= scm_call_1 (f
, seed
);
2631 if (!SCM_CHARP (ch
))
2632 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2633 str
= scm_i_make_string (1, NULL
);
2634 str
= scm_i_string_start_writing (str
);
2635 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2636 scm_i_string_stop_writing ();
2639 ans
= scm_string_append (scm_list_2 (ans
, str
));
2640 seed
= scm_call_1 (g
, seed
);
2641 res
= scm_call_1 (p
, seed
);
2643 if (!SCM_UNBNDP (make_final
))
2645 res
= scm_call_1 (make_final
, seed
);
2646 return scm_string_append (scm_list_2 (ans
, res
));
2654 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2655 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2656 "@itemize @bullet\n"
2657 "@item @var{g} is used to generate a series of @emph{seed}\n"
2658 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2659 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2661 "@item @var{p} tells us when to stop -- when it returns true\n"
2662 "when applied to one of these seed values.\n"
2663 "@item @var{f} maps each seed value to the corresponding\n"
2664 "character in the result string. These chars are assembled\n"
2665 "into the string in a right-to-left order.\n"
2666 "@item @var{base} is the optional initial/rightmost portion\n"
2667 "of the constructed string; it default to the empty\n"
2669 "@item @var{make_final} is applied to the terminal seed\n"
2670 "value (on which @var{p} returns true) to produce\n"
2671 "the final/leftmost portion of the constructed string.\n"
2672 "It defaults to @code{(lambda (x) "")}.\n"
2674 #define FUNC_NAME s_scm_string_unfold_right
2678 SCM_VALIDATE_PROC (1, p
);
2679 SCM_VALIDATE_PROC (2, f
);
2680 SCM_VALIDATE_PROC (3, g
);
2681 if (!SCM_UNBNDP (base
))
2683 SCM_VALIDATE_STRING (5, base
);
2687 ans
= scm_i_make_string (0, NULL
);
2688 if (!SCM_UNBNDP (make_final
))
2689 SCM_VALIDATE_PROC (6, make_final
);
2691 res
= scm_call_1 (p
, seed
);
2692 while (scm_is_false (res
))
2696 SCM ch
= scm_call_1 (f
, seed
);
2697 if (!SCM_CHARP (ch
))
2698 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2699 str
= scm_i_make_string (1, NULL
);
2700 str
= scm_i_string_start_writing (str
);
2701 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2702 scm_i_string_stop_writing ();
2705 ans
= scm_string_append (scm_list_2 (str
, ans
));
2706 seed
= scm_call_1 (g
, seed
);
2707 res
= scm_call_1 (p
, seed
);
2709 if (!SCM_UNBNDP (make_final
))
2711 res
= scm_call_1 (make_final
, seed
);
2712 return scm_string_append (scm_list_2 (res
, ans
));
2720 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2721 (SCM proc
, SCM s
, SCM start
, SCM end
),
2722 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2723 "return value is not specified.")
2724 #define FUNC_NAME s_scm_string_for_each
2726 size_t cstart
, cend
;
2728 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2729 proc
, SCM_ARG1
, FUNC_NAME
);
2730 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2733 while (cstart
< cend
)
2735 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2739 scm_remember_upto_here_1 (s
);
2740 return SCM_UNSPECIFIED
;
2744 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2745 (SCM proc
, SCM s
, SCM start
, SCM end
),
2746 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2749 "For example, to change characters to alternately upper and\n"
2753 "(define str (string-copy \"studly\"))\n"
2754 "(string-for-each-index\n"
2756 " (string-set! str i\n"
2757 " ((if (even? i) char-upcase char-downcase)\n"
2758 " (string-ref str i))))\n"
2760 "str @result{} \"StUdLy\"\n"
2762 #define FUNC_NAME s_scm_string_for_each_index
2764 size_t cstart
, cend
;
2766 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2767 proc
, SCM_ARG1
, FUNC_NAME
);
2768 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2772 while (cstart
< cend
)
2774 scm_call_1 (proc
, scm_from_size_t (cstart
));
2778 scm_remember_upto_here_1 (s
);
2779 return SCM_UNSPECIFIED
;
2783 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2784 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2785 "This is the @emph{extended substring} procedure that implements\n"
2786 "replicated copying of a substring of some string.\n"
2788 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2789 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2790 "0 and the length of @var{s}. Replicate this substring up and\n"
2791 "down index space, in both the positive and negative directions.\n"
2792 "@code{xsubstring} returns the substring of this string\n"
2793 "beginning at index @var{from}, and ending at @var{to}, which\n"
2794 "defaults to @var{from} + (@var{end} - @var{start}).")
2795 #define FUNC_NAME s_scm_xsubstring
2798 size_t cstart
, cend
;
2802 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2806 cfrom
= scm_to_int (from
);
2807 if (SCM_UNBNDP (to
))
2808 cto
= cfrom
+ (cend
- cstart
);
2810 cto
= scm_to_int (to
);
2811 if (cstart
== cend
&& cfrom
!= cto
)
2812 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2814 result
= scm_i_make_string (cto
- cfrom
, NULL
);
2815 result
= scm_i_string_start_writing (result
);
2820 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2822 scm_i_string_set_x (result
, p
,
2823 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2825 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2829 scm_i_string_stop_writing ();
2831 scm_remember_upto_here_1 (s
);
2837 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2838 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2839 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2840 "is written into the string @var{target} starting at index\n"
2841 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2842 "@var{target} @var{s})} or these arguments share storage -- you\n"
2843 "cannot copy a string on top of itself.")
2844 #define FUNC_NAME s_scm_string_xcopy_x
2847 size_t ctstart
, cstart
, cend
;
2849 SCM dummy
= SCM_UNDEFINED
;
2852 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2855 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2858 csfrom
= scm_to_int (sfrom
);
2859 if (SCM_UNBNDP (sto
))
2860 csto
= csfrom
+ (cend
- cstart
);
2862 csto
= scm_to_int (sto
);
2863 if (cstart
== cend
&& csfrom
!= csto
)
2864 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2865 SCM_ASSERT_RANGE (1, tstart
,
2866 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2869 target
= scm_i_string_start_writing (target
);
2870 while (csfrom
< csto
)
2872 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2874 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2876 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2880 scm_i_string_stop_writing ();
2882 scm_remember_upto_here_2 (target
, s
);
2883 return SCM_UNSPECIFIED
;
2888 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2889 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2890 "Return the string @var{s1}, but with the characters\n"
2891 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2892 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2893 #define FUNC_NAME s_scm_string_replace
2895 size_t cstart1
, cend1
, cstart2
, cend2
;
2898 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2901 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2904 return (scm_string_append
2905 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2906 scm_i_substring (s2
, cstart2
, cend2
),
2907 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2913 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2914 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2915 "Split the string @var{s} into a list of substrings, where each\n"
2916 "substring is a maximal non-empty contiguous sequence of\n"
2917 "characters from the character set @var{token_set}, which\n"
2918 "defaults to @code{char-set:graphic}.\n"
2919 "If @var{start} or @var{end} indices are provided, they restrict\n"
2920 "@code{string-tokenize} to operating on the indicated substring\n"
2922 #define FUNC_NAME s_scm_string_tokenize
2924 size_t cstart
, cend
;
2925 SCM result
= SCM_EOL
;
2927 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2931 if (SCM_UNBNDP (token_set
))
2932 token_set
= scm_char_set_graphic
;
2934 if (SCM_CHARSETP (token_set
))
2938 while (cstart
< cend
)
2940 while (cstart
< cend
)
2942 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2949 while (cstart
< cend
)
2951 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2955 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2959 SCM_WRONG_TYPE_ARG (2, token_set
);
2961 scm_remember_upto_here_1 (s
);
2966 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2968 "Split the string @var{str} into the a list of the substrings delimited\n"
2969 "by appearances of the character @var{chr}. Note that an empty substring\n"
2970 "between separator characters will result in an empty string in the\n"
2974 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2976 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2978 "(string-split \"::\" #\\:)\n"
2980 "(\"\" \"\" \"\")\n"
2982 "(string-split \"\" #\\:)\n"
2986 #define FUNC_NAME s_scm_string_split
2992 SCM_VALIDATE_STRING (1, str
);
2993 SCM_VALIDATE_CHAR (2, chr
);
2995 /* This is explicit wide/narrow logic (instead of using
2996 scm_i_string_ref) is a speed optimization. */
2997 idx
= scm_i_string_length (str
);
2998 narrow
= scm_i_is_narrow_string (str
);
3001 const char *buf
= scm_i_string_chars (str
);
3005 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
3009 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3016 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3020 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3024 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3029 scm_remember_upto_here_1 (str
);
3035 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3036 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3037 "Filter the string @var{s}, retaining only those characters\n"
3038 "which satisfy @var{char_pred}.\n"
3040 "If @var{char_pred} is a procedure, it is applied to each\n"
3041 "character as a predicate, if it is a character, it is tested\n"
3042 "for equality and if it is a character set, it is tested for\n"
3044 #define FUNC_NAME s_scm_string_filter
3046 size_t cstart
, cend
;
3050 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3054 /* The explicit loops below stripping leading and trailing non-matches
3055 mean we can return a substring if those are the only deletions, making
3056 string-filter as efficient as string-trim-both in that case. */
3058 if (SCM_CHARP (char_pred
))
3062 /* strip leading non-matches by incrementing cstart */
3063 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3066 /* strip trailing non-matches by decrementing cend */
3067 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3070 /* count chars to keep */
3072 for (idx
= cstart
; idx
< cend
; idx
++)
3073 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3076 if (count
== cend
- cstart
)
3078 /* whole of cstart to cend is to be kept, return a copy-on-write
3081 result
= scm_i_substring (s
, cstart
, cend
);
3084 result
= scm_c_make_string (count
, char_pred
);
3086 else if (SCM_CHARSETP (char_pred
))
3090 /* strip leading non-matches by incrementing cstart */
3091 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3094 /* strip trailing non-matches by decrementing cend */
3095 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3098 /* count chars to be kept */
3100 for (idx
= cstart
; idx
< cend
; idx
++)
3101 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3104 /* if whole of start to end kept then return substring */
3105 if (count
== cend
- cstart
)
3106 goto result_substring
;
3110 result
= scm_i_make_string (count
, NULL
);
3111 result
= scm_i_string_start_writing (result
);
3113 /* decrement "count" in this loop as well as using idx, so that if
3114 another thread is simultaneously changing "s" there's no chance
3115 it'll make us copy more than count characters */
3116 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3118 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3120 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3125 scm_i_string_stop_writing ();
3132 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3133 char_pred
, SCM_ARG2
, FUNC_NAME
);
3138 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3139 res
= scm_call_1 (char_pred
, ch
);
3140 if (scm_is_true (res
))
3141 ls
= scm_cons (ch
, ls
);
3144 result
= scm_reverse_list_to_string (ls
);
3147 scm_remember_upto_here_1 (s
);
3153 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3154 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3155 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3157 "If @var{char_pred} is a procedure, it is applied to each\n"
3158 "character as a predicate, if it is a character, it is tested\n"
3159 "for equality and if it is a character set, it is tested for\n"
3161 #define FUNC_NAME s_scm_string_delete
3163 size_t cstart
, cend
;
3167 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3171 /* The explicit loops below stripping leading and trailing matches mean we
3172 can return a substring if those are the only deletions, making
3173 string-delete as efficient as string-trim-both in that case. */
3175 if (SCM_CHARP (char_pred
))
3179 /* strip leading matches by incrementing cstart */
3180 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3183 /* strip trailing matches by decrementing cend */
3184 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3187 /* count chars to be kept */
3189 for (idx
= cstart
; idx
< cend
; idx
++)
3190 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3193 if (count
== cend
- cstart
)
3195 /* whole of cstart to cend is to be kept, return a copy-on-write
3198 result
= scm_i_substring (s
, cstart
, cend
);
3203 /* new string for retained portion */
3204 result
= scm_i_make_string (count
, NULL
);
3205 result
= scm_i_string_start_writing (result
);
3206 /* decrement "count" in this loop as well as using idx, so that if
3207 another thread is simultaneously changing "s" there's no chance
3208 it'll make us copy more than count characters */
3209 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3211 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3212 if (c
!= SCM_CHAR (char_pred
))
3214 scm_i_string_set_x (result
, i
, c
);
3219 scm_i_string_stop_writing ();
3222 else if (SCM_CHARSETP (char_pred
))
3226 /* strip leading matches by incrementing cstart */
3227 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3230 /* strip trailing matches by decrementing cend */
3231 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3234 /* count chars to be kept */
3236 for (idx
= cstart
; idx
< cend
; idx
++)
3237 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3240 if (count
== cend
- cstart
)
3241 goto result_substring
;
3245 /* new string for retained portion */
3246 result
= scm_i_make_string (count
, NULL
);
3247 result
= scm_i_string_start_writing (result
);
3249 /* decrement "count" in this loop as well as using idx, so that if
3250 another thread is simultaneously changing "s" there's no chance
3251 it'll make us copy more than count characters */
3252 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3254 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3256 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3261 scm_i_string_stop_writing ();
3267 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3268 char_pred
, SCM_ARG2
, FUNC_NAME
);
3273 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3274 res
= scm_call_1 (char_pred
, ch
);
3275 if (scm_is_false (res
))
3276 ls
= scm_cons (ch
, ls
);
3279 result
= scm_reverse_list_to_string (ls
);
3282 scm_remember_upto_here_1 (s
);
3288 scm_init_srfi_13 (void)
3290 #include "libguile/srfi-13.x"
3293 /* End of srfi-13.c. */