1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009 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_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
129 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
131 while (cstart
< cend
)
133 res
= pred_tramp (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_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
196 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
198 while (cstart
< cend
)
200 res
= pred_tramp (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
225 scm_t_trampoline_1 proc_tramp
;
227 proc_tramp
= scm_trampoline_1 (proc
);
228 SCM_ASSERT (proc_tramp
, 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
= proc_tramp (proc
, scm_from_size_t (i
));
244 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
246 if (SCM_CHAR (ch
) > 255)
248 buf
[i
] = SCM_CHAR (ch
);
253 scm_t_wchar
*wbuf
= NULL
;
254 res
= scm_i_make_wide_string (clen
, &wbuf
);
255 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
261 res
= scm_i_make_string (clen
, &nbuf
);
262 for (i
= 0; i
< clen
; i
++)
263 nbuf
[i
] = (unsigned char) buf
[i
];
273 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
274 (SCM str
, SCM start
, SCM end
),
275 "Convert the string @var{str} into a list of characters.")
276 #define FUNC_NAME s_scm_substring_to_list
280 SCM result
= SCM_EOL
;
282 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
286 /* This explicit narrow/wide logic (instead of just using
287 scm_i_string_ref) is for speed optimizaion. */
288 narrow
= scm_i_is_narrow_string (str
);
291 const char *buf
= scm_i_string_chars (str
);
292 while (cstart
< cend
)
295 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
300 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
301 while (cstart
< cend
)
304 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
307 scm_remember_upto_here_1 (str
);
312 /* We export scm_substring_to_list as "string->list" since it is
313 compatible and more general. This function remains for the benefit
314 of C code that used it.
318 scm_string_to_list (SCM str
)
320 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
323 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
325 "An efficient implementation of @code{(compose string->list\n"
329 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
331 #define FUNC_NAME s_scm_reverse_list_to_string
334 long i
= scm_ilength (chrs
), j
;
338 SCM_WRONG_TYPE_ARG (1, chrs
);
339 result
= scm_i_make_string (i
, &data
);
345 while (j
< i
&& scm_is_pair (rest
))
347 SCM elt
= SCM_CAR (rest
);
348 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
350 rest
= SCM_CDR (rest
);
354 result
= scm_i_string_start_writing (result
);
355 while (j
> 0 && scm_is_pair (rest
))
357 SCM elt
= SCM_CAR (rest
);
358 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
359 rest
= SCM_CDR (rest
);
362 scm_i_string_stop_writing ();
370 SCM_SYMBOL (scm_sym_infix
, "infix");
371 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
372 SCM_SYMBOL (scm_sym_suffix
, "suffix");
373 SCM_SYMBOL (scm_sym_prefix
, "prefix");
375 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
376 (SCM ls
, SCM delimiter
, SCM grammar
),
377 "Append the string in the string list @var{ls}, using the string\n"
378 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
379 "@var{grammar} is a symbol which specifies how the delimiter is\n"
380 "placed between the strings, and defaults to the symbol\n"
385 "Insert the separator between list elements. An empty string\n"
386 "will produce an empty list.\n"
387 "@item string-infix\n"
388 "Like @code{infix}, but will raise an error if given the empty\n"
391 "Insert the separator after every list element.\n"
393 "Insert the separator before each list element.\n"
395 #define FUNC_NAME s_scm_string_join
398 #define GRAM_STRICT_INFIX 1
399 #define GRAM_SUFFIX 2
400 #define GRAM_PREFIX 3
403 int gram
= GRAM_INFIX
;
405 long strings
= scm_ilength (ls
);
407 /* Validate the string list. */
409 SCM_WRONG_TYPE_ARG (1, ls
);
411 /* Validate the delimiter and record its length. */
412 if (SCM_UNBNDP (delimiter
))
414 delimiter
= scm_from_locale_string (" ");
419 SCM_VALIDATE_STRING (2, delimiter
);
420 del_len
= scm_i_string_length (delimiter
);
423 /* Validate the grammar symbol and remember the grammar. */
424 if (SCM_UNBNDP (grammar
))
426 else if (scm_is_eq (grammar
, scm_sym_infix
))
428 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
429 gram
= GRAM_STRICT_INFIX
;
430 else if (scm_is_eq (grammar
, scm_sym_suffix
))
432 else if (scm_is_eq (grammar
, scm_sym_prefix
))
435 SCM_WRONG_TYPE_ARG (3, grammar
);
437 /* Check grammar constraints. */
438 if (strings
== 0 && gram
== GRAM_STRICT_INFIX
)
439 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
442 result
= scm_i_make_string (0, NULL
);
448 case GRAM_STRICT_INFIX
:
449 while (scm_is_pair (tmp
))
451 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
452 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
453 result
= scm_string_append (scm_list_2 (result
, delimiter
));
458 while (scm_is_pair (tmp
))
460 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
462 result
= scm_string_append (scm_list_2 (result
, delimiter
));
467 while (scm_is_pair (tmp
))
470 result
= scm_string_append (scm_list_2 (result
, delimiter
));
471 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
479 #undef GRAM_STRICT_INFIX
486 /* There are a number of functions to consider here for Scheme and C:
488 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
489 substring/copy STR start [end] ;; Guile variant of R5RS substring
491 scm_string_copy (str) ;; Old function from Guile
492 scm_substring_copy (str, [start, [end]])
493 ;; C version of SRFI-13 string-copy
494 ;; and C version of substring/copy
496 The C function underlying string-copy is not exported to C
497 programs. scm_substring_copy is defined in strings.c as the
498 underlying function of substring/copy and allows an optional START
502 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
504 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
505 (SCM str
, SCM start
, SCM end
),
506 "Return a freshly allocated copy of the string @var{str}. If\n"
507 "given, @var{start} and @var{end} delimit the portion of\n"
508 "@var{str} which is copied.")
509 #define FUNC_NAME s_scm_srfi13_substring_copy
513 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
516 return scm_i_substring_copy (str
, cstart
, cend
);
521 scm_string_copy (SCM str
)
523 if (!scm_is_string (str
))
524 scm_wrong_type_arg ("scm_string_copy", 0, str
);
526 return scm_i_substring (str
, 0, scm_i_string_length (str
));
529 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
530 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
531 "Copy the sequence of characters from index range [@var{start},\n"
532 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
533 "at index @var{tstart}. The characters are copied left-to-right\n"
534 "or right-to-left as needed -- the copy is guaranteed to work,\n"
535 "even if @var{target} and @var{s} are the same string. It is an\n"
536 "error if the copy operation runs off the end of the target\n"
538 #define FUNC_NAME s_scm_string_copy_x
540 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
541 SCM sdummy
= SCM_UNDEFINED
;
543 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
546 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
550 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
552 target
= scm_i_string_start_writing (target
);
553 for (i
= 0; i
< cend
- cstart
; i
++)
555 scm_i_string_set_x (target
, ctstart
+ i
,
556 scm_i_string_ref (s
, cstart
+ i
));
558 scm_i_string_stop_writing ();
559 scm_remember_upto_here_1 (target
);
561 return SCM_UNSPECIFIED
;
565 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
566 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
567 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
568 "into @var{str2} beginning at position @var{start2}.\n"
569 "@var{str1} and @var{str2} can be the same string.")
570 #define FUNC_NAME s_scm_substring_move_x
572 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
576 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
578 "Return the @var{n} first characters of @var{s}.")
579 #define FUNC_NAME s_scm_string_take
581 return scm_substring (s
, SCM_INUM0
, n
);
586 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
588 "Return all but the first @var{n} characters of @var{s}.")
589 #define FUNC_NAME s_scm_string_drop
591 return scm_substring (s
, n
, SCM_UNDEFINED
);
596 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
598 "Return the @var{n} last characters of @var{s}.")
599 #define FUNC_NAME s_scm_string_take_right
601 return scm_substring (s
,
602 scm_difference (scm_string_length (s
), n
),
608 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
610 "Return all but the last @var{n} characters of @var{s}.")
611 #define FUNC_NAME s_scm_string_drop_right
613 return scm_substring (s
,
615 scm_difference (scm_string_length (s
), n
));
620 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
621 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
622 "Take that characters from @var{start} to @var{end} from the\n"
623 "string @var{s} and return a new string, right-padded by the\n"
624 "character @var{chr} to length @var{len}. If the resulting\n"
625 "string is longer than @var{len}, it is truncated on the right.")
626 #define FUNC_NAME s_scm_string_pad
628 size_t cstart
, cend
, clen
;
630 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
633 clen
= scm_to_size_t (len
);
635 if (SCM_UNBNDP (chr
))
636 chr
= SCM_MAKE_CHAR (' ');
639 SCM_VALIDATE_CHAR (3, chr
);
641 if (clen
< (cend
- cstart
))
642 return scm_i_substring (s
, cend
- clen
, cend
);
646 result
= (scm_string_append
647 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
648 scm_i_substring (s
, cstart
, cend
))));
655 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
656 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
657 "Take that characters from @var{start} to @var{end} from the\n"
658 "string @var{s} and return a new string, left-padded by the\n"
659 "character @var{chr} to length @var{len}. If the resulting\n"
660 "string is longer than @var{len}, it is truncated on the left.")
661 #define FUNC_NAME s_scm_string_pad_right
663 size_t cstart
, cend
, clen
;
665 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
668 clen
= scm_to_size_t (len
);
670 if (SCM_UNBNDP (chr
))
671 chr
= SCM_MAKE_CHAR (' ');
674 SCM_VALIDATE_CHAR (3, chr
);
676 if (clen
< (cend
- cstart
))
677 return scm_i_substring (s
, cstart
, cstart
+ clen
);
682 result
= (scm_string_append
683 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
684 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
692 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
693 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
694 "Trim @var{s} by skipping over all characters on the left\n"
695 "that satisfy the parameter @var{char_pred}:\n"
699 "if it is the character @var{ch}, characters equal to\n"
700 "@var{ch} are trimmed,\n"
703 "if it is a procedure @var{pred} characters that\n"
704 "satisfy @var{pred} are trimmed,\n"
707 "if it is a character set, characters in that set are trimmed.\n"
710 "If called without a @var{char_pred} argument, all whitespace is\n"
712 #define FUNC_NAME s_scm_string_trim
716 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
719 if (SCM_UNBNDP (char_pred
))
721 while (cstart
< cend
)
723 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
728 else if (SCM_CHARP (char_pred
))
730 while (cstart
< cend
)
732 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
737 else if (SCM_CHARSETP (char_pred
))
739 while (cstart
< cend
)
741 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
748 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
749 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
751 while (cstart
< cend
)
755 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
756 if (scm_is_false (res
))
761 return scm_i_substring (s
, cstart
, cend
);
766 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
767 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
768 "Trim @var{s} by skipping over all characters on the right\n"
769 "that satisfy the parameter @var{char_pred}:\n"
773 "if it is the character @var{ch}, characters equal to @var{ch}\n"
777 "if it is a procedure @var{pred} characters that satisfy\n"
778 "@var{pred} are trimmed,\n"
781 "if it is a character sets, all characters in that set are\n"
785 "If called without a @var{char_pred} argument, all whitespace is\n"
787 #define FUNC_NAME s_scm_string_trim_right
791 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
794 if (SCM_UNBNDP (char_pred
))
796 while (cstart
< cend
)
798 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
803 else if (SCM_CHARP (char_pred
))
805 while (cstart
< cend
)
807 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
812 else if (SCM_CHARSETP (char_pred
))
814 while (cstart
< cend
)
816 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
823 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
824 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
826 while (cstart
< cend
)
830 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
831 if (scm_is_false (res
))
836 return scm_i_substring (s
, cstart
, cend
);
841 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
842 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
843 "Trim @var{s} by skipping over all characters on both sides of\n"
844 "the string that satisfy the parameter @var{char_pred}:\n"
848 "if it is the character @var{ch}, characters equal to @var{ch}\n"
852 "if it is a procedure @var{pred} characters that satisfy\n"
853 "@var{pred} are trimmed,\n"
856 "if it is a character set, the characters in the set are\n"
860 "If called without a @var{char_pred} argument, all whitespace is\n"
862 #define FUNC_NAME s_scm_string_trim_both
866 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
869 if (SCM_UNBNDP (char_pred
))
871 while (cstart
< cend
)
873 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
877 while (cstart
< cend
)
879 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
884 else if (SCM_CHARP (char_pred
))
886 while (cstart
< cend
)
888 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
892 while (cstart
< cend
)
894 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
899 else if (SCM_CHARSETP (char_pred
))
901 while (cstart
< cend
)
903 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
907 while (cstart
< cend
)
909 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
916 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
917 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
919 while (cstart
< cend
)
923 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
924 if (scm_is_false (res
))
928 while (cstart
< cend
)
932 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
933 if (scm_is_false (res
))
938 return scm_i_substring (s
, cstart
, cend
);
943 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
944 (SCM str
, SCM chr
, SCM start
, SCM end
),
945 "Stores @var{chr} in every element of the given @var{str} and\n"
946 "returns an unspecified value.")
947 #define FUNC_NAME s_scm_substring_fill_x
952 /* Older versions of Guile provided the function
953 scm_substring_fill_x with the following order of arguments:
957 We accomodate this here by detecting such a usage and reordering
968 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
971 SCM_VALIDATE_CHAR (2, chr
);
974 str
= scm_i_string_start_writing (str
);
975 for (k
= cstart
; k
< cend
; k
++)
976 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
977 scm_i_string_stop_writing ();
979 return SCM_UNSPECIFIED
;
984 scm_string_fill_x (SCM str
, SCM chr
)
986 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
989 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
990 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
991 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
992 "mismatch index, depending upon whether @var{s1} is less than,\n"
993 "equal to, or greater than @var{s2}. The mismatch index is the\n"
994 "largest index @var{i} such that for every 0 <= @var{j} <\n"
995 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
996 "@var{i} is the first position that does not match.")
997 #define FUNC_NAME s_scm_string_compare
999 size_t cstart1
, cend1
, cstart2
, cend2
;
1002 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1005 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1008 SCM_VALIDATE_PROC (3, proc_lt
);
1009 SCM_VALIDATE_PROC (4, proc_eq
);
1010 SCM_VALIDATE_PROC (5, proc_gt
);
1012 while (cstart1
< cend1
&& cstart2
< cend2
)
1014 if (scm_i_string_ref (s1
, cstart1
)
1015 < scm_i_string_ref (s2
, cstart2
))
1020 else if (scm_i_string_ref (s1
, cstart1
)
1021 > scm_i_string_ref (s2
, cstart2
))
1029 if (cstart1
< cend1
)
1031 else if (cstart2
< cend2
)
1037 scm_remember_upto_here_2 (s1
, s2
);
1038 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1043 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1044 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1045 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1046 "mismatch index, depending upon whether @var{s1} is less than,\n"
1047 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1048 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1049 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1050 "@var{i} is the first position where the lowercased letters \n"
1052 #define FUNC_NAME s_scm_string_compare_ci
1054 size_t cstart1
, cend1
, cstart2
, cend2
;
1057 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1060 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1063 SCM_VALIDATE_PROC (3, proc_lt
);
1064 SCM_VALIDATE_PROC (4, proc_eq
);
1065 SCM_VALIDATE_PROC (5, proc_gt
);
1067 while (cstart1
< cend1
&& cstart2
< cend2
)
1069 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1070 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1075 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1076 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1085 if (cstart1
< cend1
)
1087 else if (cstart2
< cend2
)
1093 scm_remember_upto_here (s1
, s2
);
1094 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1098 /* This function compares two substrings, S1 from START1 to END1 and
1099 S2 from START2 to END2, possibly case insensitively, and returns
1100 one of the parameters LESSTHAN, GREATERTHAN, LONGER, SHORTER, or
1101 EQUAL depending if S1 is less than S2, greater than S2, longer,
1102 shorter, or equal. */
1104 compare_strings (const char *fname
, int case_insensitive
,
1105 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1106 SCM lessthan
, SCM greaterthan
, SCM longer
, SCM shorter
, SCM equal
)
1108 size_t cstart1
, cend1
, cstart2
, cend2
;
1112 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1115 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1119 while (cstart1
< cend1
&& cstart2
< cend2
)
1121 if (case_insensitive
)
1123 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1124 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1128 a
= scm_i_string_ref (s1
, cstart1
);
1129 b
= scm_i_string_ref (s2
, cstart2
);
1144 if (cstart1
< cend1
)
1149 else if (cstart2
< cend2
)
1161 scm_remember_upto_here_2 (s1
, s2
);
1166 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1167 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1168 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1170 #define FUNC_NAME s_scm_string_eq
1172 return compare_strings (FUNC_NAME
, 0,
1173 s1
, s2
, start1
, end1
, start2
, end2
,
1174 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1179 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1180 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1181 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1183 #define FUNC_NAME s_scm_string_neq
1185 return compare_strings (FUNC_NAME
, 0,
1186 s1
, s2
, start1
, end1
, start2
, end2
,
1187 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1192 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1193 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1194 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1195 "true value otherwise.")
1196 #define FUNC_NAME s_scm_string_lt
1198 return compare_strings (FUNC_NAME
, 0,
1199 s1
, s2
, start1
, end1
, start2
, end2
,
1200 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1205 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1206 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1207 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1208 "true value otherwise.")
1209 #define FUNC_NAME s_scm_string_gt
1211 return compare_strings (FUNC_NAME
, 0,
1212 s1
, s2
, start1
, end1
, start2
, end2
,
1213 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1218 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1219 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1220 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1222 #define FUNC_NAME s_scm_string_le
1224 return compare_strings (FUNC_NAME
, 0,
1225 s1
, s2
, start1
, end1
, start2
, end2
,
1226 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1231 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1232 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1233 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1235 #define FUNC_NAME s_scm_string_ge
1237 return compare_strings (FUNC_NAME
, 0,
1238 s1
, s2
, start1
, end1
, start2
, end2
,
1239 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1244 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1245 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1246 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1247 "value otherwise. The character comparison is done\n"
1248 "case-insensitively.")
1249 #define FUNC_NAME s_scm_string_ci_eq
1251 return compare_strings (FUNC_NAME
, 1,
1252 s1
, s2
, start1
, end1
, start2
, end2
,
1253 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1258 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1259 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1260 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1261 "value otherwise. The character comparison is done\n"
1262 "case-insensitively.")
1263 #define FUNC_NAME s_scm_string_ci_neq
1265 return compare_strings (FUNC_NAME
, 1,
1266 s1
, s2
, start1
, end1
, start2
, end2
,
1267 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1272 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1273 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1274 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1275 "true value otherwise. The character comparison is done\n"
1276 "case-insensitively.")
1277 #define FUNC_NAME s_scm_string_ci_lt
1279 return compare_strings (FUNC_NAME
, 1,
1280 s1
, s2
, start1
, end1
, start2
, end2
,
1281 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1286 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1287 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1288 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1289 "true value otherwise. The character comparison is done\n"
1290 "case-insensitively.")
1291 #define FUNC_NAME s_scm_string_ci_gt
1293 return compare_strings (FUNC_NAME
, 1,
1294 s1
, s2
, start1
, end1
, start2
, end2
,
1295 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1300 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1301 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1302 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1303 "value otherwise. The character comparison is done\n"
1304 "case-insensitively.")
1305 #define FUNC_NAME s_scm_string_ci_le
1307 return compare_strings (FUNC_NAME
, 1,
1308 s1
, s2
, start1
, end1
, start2
, end2
,
1309 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1314 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1315 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1316 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1317 "otherwise. The character comparison is done\n"
1318 "case-insensitively.")
1319 #define FUNC_NAME s_scm_string_ci_ge
1321 return compare_strings (FUNC_NAME
, 1,
1322 s1
, s2
, start1
, end1
, start2
, end2
,
1323 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1327 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1328 (SCM s
, SCM bound
, SCM start
, SCM end
),
1329 "Compute a hash value for @var{S}. the optional argument "
1330 "@var{bound} is a non-negative exact "
1331 "integer specifying the range of the hash function. "
1332 "A positive value restricts the return value to the "
1334 #define FUNC_NAME s_scm_substring_hash
1336 if (SCM_UNBNDP (bound
))
1337 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1338 if (SCM_UNBNDP (start
))
1340 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1344 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1345 (SCM s
, SCM bound
, SCM start
, SCM end
),
1346 "Compute a hash value for @var{S}. the optional argument "
1347 "@var{bound} is a non-negative exact "
1348 "integer specifying the range of the hash function. "
1349 "A positive value restricts the return value to the "
1351 #define FUNC_NAME s_scm_substring_hash_ci
1353 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1355 SCM_UNDEFINED
, SCM_UNDEFINED
);
1359 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1360 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1361 "Return the length of the longest common prefix of the two\n"
1363 #define FUNC_NAME s_scm_string_prefix_length
1365 size_t cstart1
, cend1
, cstart2
, cend2
;
1368 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1371 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1375 while (cstart1
< cend1
&& cstart2
< cend2
)
1377 if (scm_i_string_ref (s1
, cstart1
)
1378 != scm_i_string_ref (s2
, cstart2
))
1386 scm_remember_upto_here_2 (s1
, s2
);
1387 return scm_from_size_t (len
);
1392 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 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"
1395 "strings, ignoring character case.")
1396 #define FUNC_NAME s_scm_string_prefix_length_ci
1398 size_t cstart1
, cend1
, cstart2
, cend2
;
1401 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1404 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1407 while (cstart1
< cend1
&& cstart2
< cend2
)
1409 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1410 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1418 scm_remember_upto_here_2 (s1
, s2
);
1419 return scm_from_size_t (len
);
1424 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1425 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1426 "Return the length of the longest common suffix of the two\n"
1428 #define FUNC_NAME s_scm_string_suffix_length
1430 size_t cstart1
, cend1
, cstart2
, cend2
;
1433 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1436 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1439 while (cstart1
< cend1
&& cstart2
< cend2
)
1443 if (scm_i_string_ref (s1
, cend1
)
1444 != scm_i_string_ref (s2
, cend2
))
1450 scm_remember_upto_here_2 (s1
, s2
);
1451 return scm_from_size_t (len
);
1456 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1457 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1458 "Return the length of the longest common suffix of the two\n"
1459 "strings, ignoring character case.")
1460 #define FUNC_NAME s_scm_string_suffix_length_ci
1462 size_t cstart1
, cend1
, cstart2
, cend2
;
1465 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1468 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1471 while (cstart1
< cend1
&& cstart2
< cend2
)
1475 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1476 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1482 scm_remember_upto_here_2 (s1
, s2
);
1483 return scm_from_size_t (len
);
1488 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1489 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1490 "Is @var{s1} a prefix of @var{s2}?")
1491 #define FUNC_NAME s_scm_string_prefix_p
1493 size_t cstart1
, cend1
, cstart2
, cend2
;
1494 size_t len
= 0, len1
;
1496 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1499 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1502 len1
= cend1
- cstart1
;
1503 while (cstart1
< cend1
&& cstart2
< cend2
)
1505 if (scm_i_string_ref (s1
, cstart1
)
1506 != scm_i_string_ref (s2
, cstart2
))
1514 scm_remember_upto_here_2 (s1
, s2
);
1515 return scm_from_bool (len
== len1
);
1520 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1521 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1522 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1523 #define FUNC_NAME s_scm_string_prefix_ci_p
1525 size_t cstart1
, cend1
, cstart2
, cend2
;
1526 size_t len
= 0, len1
;
1528 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1531 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1534 len1
= cend1
- cstart1
;
1535 while (cstart1
< cend1
&& cstart2
< cend2
)
1537 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1538 scm_t_wchar b
= uc_tolower (uc_toupper (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_suffix_p
, "string-suffix?", 2, 4, 0,
1554 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1555 "Is @var{s1} a suffix of @var{s2}?")
1556 #define FUNC_NAME s_scm_string_suffix_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
)
1572 if (scm_i_string_ref (s1
, cend1
)
1573 != scm_i_string_ref (s2
, cend2
))
1579 scm_remember_upto_here_2 (s1
, s2
);
1580 return scm_from_bool (len
== len1
);
1585 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1586 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1587 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1588 #define FUNC_NAME s_scm_string_suffix_ci_p
1590 size_t cstart1
, cend1
, cstart2
, cend2
;
1591 size_t len
= 0, len1
;
1593 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1596 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1599 len1
= cend1
- cstart1
;
1600 while (cstart1
< cend1
&& cstart2
< cend2
)
1604 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1605 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1611 scm_remember_upto_here_2 (s1
, s2
);
1612 return scm_from_bool (len
== len1
);
1617 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1618 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1619 "Search through the string @var{s} from left to right, returning\n"
1620 "the index of the first occurence of a character which\n"
1622 "@itemize @bullet\n"
1624 "equals @var{char_pred}, if it is character,\n"
1627 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1630 "is in the set @var{char_pred}, if it is a character set.\n"
1632 #define FUNC_NAME s_scm_string_index
1634 size_t cstart
, cend
;
1636 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1639 if (SCM_CHARP (char_pred
))
1641 while (cstart
< cend
)
1643 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1648 else if (SCM_CHARSETP (char_pred
))
1650 while (cstart
< cend
)
1652 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1659 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1660 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1662 while (cstart
< cend
)
1665 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1666 if (scm_is_true (res
))
1672 scm_remember_upto_here_1 (s
);
1676 scm_remember_upto_here_1 (s
);
1677 return scm_from_size_t (cstart
);
1681 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1682 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1683 "Search through the string @var{s} from right to left, returning\n"
1684 "the index of the last occurence of a character which\n"
1686 "@itemize @bullet\n"
1688 "equals @var{char_pred}, if it is character,\n"
1691 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1694 "is in the set if @var{char_pred} is a character set.\n"
1696 #define FUNC_NAME s_scm_string_index_right
1698 size_t cstart
, cend
;
1700 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1703 if (SCM_CHARP (char_pred
))
1705 while (cstart
< cend
)
1708 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1712 else if (SCM_CHARSETP (char_pred
))
1714 while (cstart
< cend
)
1717 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1723 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1724 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1726 while (cstart
< cend
)
1730 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1731 if (scm_is_true (res
))
1736 scm_remember_upto_here_1 (s
);
1740 scm_remember_upto_here_1 (s
);
1741 return scm_from_size_t (cend
);
1745 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1746 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1747 "Search through the string @var{s} from right to left, returning\n"
1748 "the index of the last occurence of a character which\n"
1750 "@itemize @bullet\n"
1752 "equals @var{char_pred}, if it is character,\n"
1755 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1758 "is in the set if @var{char_pred} is a character set.\n"
1760 #define FUNC_NAME s_scm_string_rindex
1762 return scm_string_index_right (s
, char_pred
, start
, end
);
1766 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1767 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1768 "Search through the string @var{s} from left to right, returning\n"
1769 "the index of the first occurence of a character which\n"
1771 "@itemize @bullet\n"
1773 "does not equal @var{char_pred}, if it is character,\n"
1776 "does not satisify the predicate @var{char_pred}, if it is a\n"
1780 "is not in the set if @var{char_pred} is a character set.\n"
1782 #define FUNC_NAME s_scm_string_skip
1784 size_t cstart
, cend
;
1786 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1789 if (SCM_CHARP (char_pred
))
1791 while (cstart
< cend
)
1793 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1798 else if (SCM_CHARSETP (char_pred
))
1800 while (cstart
< cend
)
1802 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1809 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1810 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1812 while (cstart
< cend
)
1815 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1816 if (scm_is_false (res
))
1822 scm_remember_upto_here_1 (s
);
1826 scm_remember_upto_here_1 (s
);
1827 return scm_from_size_t (cstart
);
1832 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1833 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1834 "Search through the string @var{s} from right to left, returning\n"
1835 "the index of the last occurence of a character which\n"
1837 "@itemize @bullet\n"
1839 "does not equal @var{char_pred}, if it is character,\n"
1842 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1846 "is not in the set if @var{char_pred} is a character set.\n"
1848 #define FUNC_NAME s_scm_string_skip_right
1850 size_t cstart
, cend
;
1852 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1855 if (SCM_CHARP (char_pred
))
1857 while (cstart
< cend
)
1860 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1864 else if (SCM_CHARSETP (char_pred
))
1866 while (cstart
< cend
)
1869 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1875 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1876 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1878 while (cstart
< cend
)
1882 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1883 if (scm_is_false (res
))
1888 scm_remember_upto_here_1 (s
);
1892 scm_remember_upto_here_1 (s
);
1893 return scm_from_size_t (cend
);
1899 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1900 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1901 "Return the count of the number of characters in the string\n"
1904 "@itemize @bullet\n"
1906 "equals @var{char_pred}, if it is character,\n"
1909 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1912 "is in the set @var{char_pred}, if it is a character set.\n"
1914 #define FUNC_NAME s_scm_string_count
1916 size_t cstart
, cend
;
1919 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1922 if (SCM_CHARP (char_pred
))
1924 while (cstart
< cend
)
1926 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1931 else if (SCM_CHARSETP (char_pred
))
1933 while (cstart
< cend
)
1935 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1942 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1943 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1945 while (cstart
< cend
)
1948 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1949 if (scm_is_true (res
))
1955 scm_remember_upto_here_1 (s
);
1956 return scm_from_size_t (count
);
1961 /* FIXME::martin: This should definitely get implemented more
1962 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1964 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1965 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1966 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1967 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1968 "The optional start/end indices restrict the operation to the\n"
1969 "indicated substrings.")
1970 #define FUNC_NAME s_scm_string_contains
1972 size_t cstart1
, cend1
, cstart2
, cend2
;
1975 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1978 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1981 len2
= cend2
- cstart2
;
1982 if (cend1
- cstart1
>= len2
)
1983 while (cstart1
<= cend1
- len2
)
1989 && (scm_i_string_ref (s1
, i
)
1990 == scm_i_string_ref (s2
, j
)))
1997 scm_remember_upto_here_2 (s1
, s2
);
1998 return scm_from_size_t (cstart1
);
2003 scm_remember_upto_here_2 (s1
, s2
);
2009 /* FIXME::martin: This should definitely get implemented more
2010 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2012 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2013 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2014 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2015 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2016 "The optional start/end indices restrict the operation to the\n"
2017 "indicated substrings. Character comparison is done\n"
2018 "case-insensitively.")
2019 #define FUNC_NAME s_scm_string_contains_ci
2021 size_t cstart1
, cend1
, cstart2
, cend2
;
2024 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2027 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2030 len2
= cend2
- cstart2
;
2031 if (cend1
- cstart1
>= len2
)
2032 while (cstart1
<= cend1
- len2
)
2038 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2039 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2046 scm_remember_upto_here_2 (s1
, s2
);
2047 return scm_from_size_t (cstart1
);
2052 scm_remember_upto_here_2 (s1
, s2
);
2058 /* Helper function for the string uppercase conversion functions. */
2060 string_upcase_x (SCM v
, size_t start
, size_t end
)
2064 v
= scm_i_string_start_writing (v
);
2065 for (k
= start
; k
< end
; ++k
)
2066 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2067 scm_i_string_stop_writing ();
2068 scm_remember_upto_here_1 (v
);
2073 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2074 (SCM str
, SCM start
, SCM end
),
2075 "Destructively upcase every character in @code{str}.\n"
2078 "(string-upcase! y)\n"
2079 "@result{} \"ARRDEFG\"\n"
2081 "@result{} \"ARRDEFG\"\n"
2083 #define FUNC_NAME s_scm_substring_upcase_x
2085 size_t cstart
, cend
;
2087 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2090 return string_upcase_x (str
, cstart
, cend
);
2095 scm_string_upcase_x (SCM str
)
2097 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2100 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2101 (SCM str
, SCM start
, SCM end
),
2102 "Upcase every character in @code{str}.")
2103 #define FUNC_NAME s_scm_substring_upcase
2105 size_t cstart
, cend
;
2107 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2110 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2115 scm_string_upcase (SCM str
)
2117 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2120 /* Helper function for the string lowercase conversion functions.
2121 * No argument checking is performed. */
2123 string_downcase_x (SCM v
, size_t start
, size_t end
)
2127 v
= scm_i_string_start_writing (v
);
2128 for (k
= start
; k
< end
; ++k
)
2129 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2130 scm_i_string_stop_writing ();
2131 scm_remember_upto_here_1 (v
);
2136 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2137 (SCM str
, SCM start
, SCM end
),
2138 "Destructively downcase every character in @var{str}.\n"
2142 "@result{} \"ARRDEFG\"\n"
2143 "(string-downcase! y)\n"
2144 "@result{} \"arrdefg\"\n"
2146 "@result{} \"arrdefg\"\n"
2148 #define FUNC_NAME s_scm_substring_downcase_x
2150 size_t cstart
, cend
;
2152 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2155 return string_downcase_x (str
, cstart
, cend
);
2160 scm_string_downcase_x (SCM str
)
2162 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2165 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2166 (SCM str
, SCM start
, SCM end
),
2167 "Downcase every character in @var{str}.")
2168 #define FUNC_NAME s_scm_substring_downcase
2170 size_t cstart
, cend
;
2172 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2175 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2180 scm_string_downcase (SCM str
)
2182 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2185 /* Helper function for the string capitalization functions.
2186 * No argument checking is performed. */
2188 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2194 str
= scm_i_string_start_writing (str
);
2195 for(i
= start
; i
< end
; i
++)
2197 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2198 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2202 scm_i_string_set_x (str
, i
, uc_toupper (SCM_CHAR (ch
)));
2207 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2213 scm_i_string_stop_writing ();
2214 scm_remember_upto_here_1 (str
);
2220 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2221 (SCM str
, SCM start
, SCM end
),
2222 "Destructively titlecase every first character in a word in\n"
2224 #define FUNC_NAME s_scm_string_titlecase_x
2226 size_t cstart
, cend
;
2228 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2231 return string_titlecase_x (str
, cstart
, cend
);
2236 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2237 (SCM str
, SCM start
, SCM end
),
2238 "Titlecase every first character in a word in @var{str}.")
2239 #define FUNC_NAME s_scm_string_titlecase
2241 size_t cstart
, cend
;
2243 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2246 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2250 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2252 "Upcase the first character of every word in @var{str}\n"
2253 "destructively and return @var{str}.\n"
2256 "y @result{} \"hello world\"\n"
2257 "(string-capitalize! y) @result{} \"Hello World\"\n"
2258 "y @result{} \"Hello World\"\n"
2260 #define FUNC_NAME s_scm_string_capitalize_x
2262 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2267 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2269 "Return a freshly allocated string with the characters in\n"
2270 "@var{str}, where the first character of every word is\n"
2272 #define FUNC_NAME s_scm_string_capitalize
2274 return scm_string_capitalize_x (scm_string_copy (str
));
2279 /* Reverse the portion of @var{str} between str[cstart] (including)
2280 and str[cend] excluding. */
2282 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2286 str
= scm_i_string_start_writing (str
);
2290 while (cstart
< cend
)
2292 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2293 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2294 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2299 scm_i_string_stop_writing ();
2303 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2304 (SCM str
, SCM start
, SCM end
),
2305 "Reverse the string @var{str}. The optional arguments\n"
2306 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2308 #define FUNC_NAME s_scm_string_reverse
2310 size_t cstart
, cend
;
2313 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2316 result
= scm_string_copy (str
);
2317 string_reverse_x (result
, cstart
, cend
);
2318 scm_remember_upto_here_1 (str
);
2324 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2325 (SCM str
, SCM start
, SCM end
),
2326 "Reverse the string @var{str} in-place. The optional arguments\n"
2327 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2328 "operate on. The return value is unspecified.")
2329 #define FUNC_NAME s_scm_string_reverse_x
2331 size_t cstart
, cend
;
2333 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2337 string_reverse_x (str
, cstart
, cend
);
2338 scm_remember_upto_here_1 (str
);
2339 return SCM_UNSPECIFIED
;
2344 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2346 "Like @code{string-append}, but the result may share memory\n"
2347 "with the argument strings.")
2348 #define FUNC_NAME s_scm_string_append_shared
2350 /* If "rest" contains just one non-empty string, return that.
2351 If it's entirely empty strings, then return scm_nullstr.
2352 Otherwise use scm_string_concatenate. */
2354 SCM ret
= scm_nullstr
;
2355 int seen_nonempty
= 0;
2358 SCM_VALIDATE_REST_ARGUMENT (rest
);
2360 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2363 if (!scm_is_string (s
))
2364 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2365 if (scm_i_string_length (s
) != 0)
2368 /* two or more non-empty strings, need full concat */
2369 return scm_string_append (rest
);
2380 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2382 "Append the elements of @var{ls} (which must be strings)\n"
2383 "together into a single string. Guaranteed to return a freshly\n"
2384 "allocated string.")
2385 #define FUNC_NAME s_scm_string_concatenate
2387 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2388 return scm_string_append (ls
);
2393 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2394 (SCM ls
, SCM final_string
, SCM end
),
2395 "Without optional arguments, this procedure is equivalent to\n"
2398 "(string-concatenate (reverse ls))\n"
2401 "If the optional argument @var{final_string} is specified, it is\n"
2402 "consed onto the beginning to @var{ls} before performing the\n"
2403 "list-reverse and string-concatenate operations. If @var{end}\n"
2404 "is given, only the characters of @var{final_string} up to index\n"
2405 "@var{end} are used.\n"
2407 "Guaranteed to return a freshly allocated string.")
2408 #define FUNC_NAME s_scm_string_concatenate_reverse
2410 if (!SCM_UNBNDP (end
))
2411 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2413 if (!SCM_UNBNDP (final_string
))
2414 ls
= scm_cons (final_string
, ls
);
2416 return scm_string_concatenate (scm_reverse (ls
));
2421 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2423 "Like @code{string-concatenate}, but the result may share memory\n"
2424 "with the strings in the list @var{ls}.")
2425 #define FUNC_NAME s_scm_string_concatenate_shared
2427 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2428 return scm_string_append_shared (ls
);
2433 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2434 (SCM ls
, SCM final_string
, SCM end
),
2435 "Like @code{string-concatenate-reverse}, but the result may\n"
2436 "share memory with the the strings in the @var{ls} arguments.")
2437 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2439 /* Just call the non-sharing version. */
2440 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2445 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2446 (SCM proc
, SCM s
, SCM start
, SCM end
),
2447 "@var{proc} is a char->char procedure, it is mapped over\n"
2448 "@var{s}. The order in which the procedure is applied to the\n"
2449 "string elements is not specified.")
2450 #define FUNC_NAME s_scm_string_map
2453 size_t cstart
, cend
;
2455 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2457 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2458 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2461 result
= scm_i_make_string (cend
- cstart
, NULL
);
2463 while (cstart
< cend
)
2465 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2466 if (!SCM_CHARP (ch
))
2467 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2469 result
= scm_i_string_start_writing (result
);
2470 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2471 scm_i_string_stop_writing ();
2480 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2481 (SCM proc
, SCM s
, SCM start
, SCM end
),
2482 "@var{proc} is a char->char procedure, it is mapped over\n"
2483 "@var{s}. The order in which the procedure is applied to the\n"
2484 "string elements is not specified. The string @var{s} is\n"
2485 "modified in-place, the return value is not specified.")
2486 #define FUNC_NAME s_scm_string_map_x
2488 size_t cstart
, cend
;
2489 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2491 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2492 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2495 while (cstart
< cend
)
2497 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2498 if (!SCM_CHARP (ch
))
2499 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2500 s
= scm_i_string_start_writing (s
);
2501 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2502 scm_i_string_stop_writing ();
2505 return SCM_UNSPECIFIED
;
2510 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2511 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2512 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2513 "as the terminating element, from left to right. @var{kons}\n"
2514 "must expect two arguments: The actual character and the last\n"
2515 "result of @var{kons}' application.")
2516 #define FUNC_NAME s_scm_string_fold
2518 size_t cstart
, cend
;
2521 SCM_VALIDATE_PROC (1, kons
);
2522 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2526 while (cstart
< cend
)
2528 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2532 scm_remember_upto_here_1 (s
);
2538 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2539 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2540 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2541 "as the terminating element, from right to left. @var{kons}\n"
2542 "must expect two arguments: The actual character and the last\n"
2543 "result of @var{kons}' application.")
2544 #define FUNC_NAME s_scm_string_fold_right
2546 size_t cstart
, cend
;
2549 SCM_VALIDATE_PROC (1, kons
);
2550 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2554 while (cstart
< cend
)
2556 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2560 scm_remember_upto_here_1 (s
);
2566 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2567 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2568 "@itemize @bullet\n"
2569 "@item @var{g} is used to generate a series of @emph{seed}\n"
2570 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2571 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2573 "@item @var{p} tells us when to stop -- when it returns true\n"
2574 "when applied to one of these seed values.\n"
2575 "@item @var{f} maps each seed value to the corresponding\n"
2576 "character in the result string. These chars are assembled\n"
2577 "into the string in a left-to-right order.\n"
2578 "@item @var{base} is the optional initial/leftmost portion\n"
2579 "of the constructed string; it default to the empty\n"
2581 "@item @var{make_final} is applied to the terminal seed\n"
2582 "value (on which @var{p} returns true) to produce\n"
2583 "the final/rightmost portion of the constructed string.\n"
2584 "It defaults to @code{(lambda (x) "")}.\n"
2586 #define FUNC_NAME s_scm_string_unfold
2590 SCM_VALIDATE_PROC (1, p
);
2591 SCM_VALIDATE_PROC (2, f
);
2592 SCM_VALIDATE_PROC (3, g
);
2593 if (!SCM_UNBNDP (base
))
2595 SCM_VALIDATE_STRING (5, base
);
2599 ans
= scm_i_make_string (0, NULL
);
2600 if (!SCM_UNBNDP (make_final
))
2601 SCM_VALIDATE_PROC (6, make_final
);
2603 res
= scm_call_1 (p
, seed
);
2604 while (scm_is_false (res
))
2608 SCM ch
= scm_call_1 (f
, seed
);
2609 if (!SCM_CHARP (ch
))
2610 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2611 str
= scm_i_make_string (1, NULL
);
2612 str
= scm_i_string_start_writing (str
);
2613 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2614 scm_i_string_stop_writing ();
2617 ans
= scm_string_append (scm_list_2 (ans
, str
));
2618 seed
= scm_call_1 (g
, seed
);
2619 res
= scm_call_1 (p
, seed
);
2621 if (!SCM_UNBNDP (make_final
))
2623 res
= scm_call_1 (make_final
, seed
);
2624 return scm_string_append (scm_list_2 (ans
, res
));
2632 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2633 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2634 "@itemize @bullet\n"
2635 "@item @var{g} is used to generate a series of @emph{seed}\n"
2636 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2637 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2639 "@item @var{p} tells us when to stop -- when it returns true\n"
2640 "when applied to one of these seed values.\n"
2641 "@item @var{f} maps each seed value to the corresponding\n"
2642 "character in the result string. These chars are assembled\n"
2643 "into the string in a right-to-left order.\n"
2644 "@item @var{base} is the optional initial/rightmost portion\n"
2645 "of the constructed string; it default to the empty\n"
2647 "@item @var{make_final} is applied to the terminal seed\n"
2648 "value (on which @var{p} returns true) to produce\n"
2649 "the final/leftmost portion of the constructed string.\n"
2650 "It defaults to @code{(lambda (x) "")}.\n"
2652 #define FUNC_NAME s_scm_string_unfold_right
2656 SCM_VALIDATE_PROC (1, p
);
2657 SCM_VALIDATE_PROC (2, f
);
2658 SCM_VALIDATE_PROC (3, g
);
2659 if (!SCM_UNBNDP (base
))
2661 SCM_VALIDATE_STRING (5, base
);
2665 ans
= scm_i_make_string (0, NULL
);
2666 if (!SCM_UNBNDP (make_final
))
2667 SCM_VALIDATE_PROC (6, make_final
);
2669 res
= scm_call_1 (p
, seed
);
2670 while (scm_is_false (res
))
2674 SCM ch
= scm_call_1 (f
, seed
);
2675 if (!SCM_CHARP (ch
))
2676 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2677 str
= scm_i_make_string (1, NULL
);
2678 str
= scm_i_string_start_writing (str
);
2679 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2680 scm_i_string_stop_writing ();
2683 ans
= scm_string_append (scm_list_2 (str
, ans
));
2684 seed
= scm_call_1 (g
, seed
);
2685 res
= scm_call_1 (p
, seed
);
2687 if (!SCM_UNBNDP (make_final
))
2689 res
= scm_call_1 (make_final
, seed
);
2690 return scm_string_append (scm_list_2 (res
, ans
));
2698 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2699 (SCM proc
, SCM s
, SCM start
, SCM end
),
2700 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2701 "return value is not specified.")
2702 #define FUNC_NAME s_scm_string_for_each
2704 size_t cstart
, cend
;
2705 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2707 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2708 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2711 while (cstart
< cend
)
2713 proc_tramp (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2717 scm_remember_upto_here_1 (s
);
2718 return SCM_UNSPECIFIED
;
2722 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2723 (SCM proc
, SCM s
, SCM start
, SCM end
),
2724 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2727 "For example, to change characters to alternately upper and\n"
2731 "(define str (string-copy \"studly\"))\n"
2732 "(string-for-each-index\n"
2734 " (string-set! str i\n"
2735 " ((if (even? i) char-upcase char-downcase)\n"
2736 " (string-ref str i))))\n"
2738 "str @result{} \"StUdLy\"\n"
2740 #define FUNC_NAME s_scm_string_for_each_index
2742 size_t cstart
, cend
;
2743 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2745 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2746 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2750 while (cstart
< cend
)
2752 proc_tramp (proc
, scm_from_size_t (cstart
));
2756 scm_remember_upto_here_1 (s
);
2757 return SCM_UNSPECIFIED
;
2761 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2762 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2763 "This is the @emph{extended substring} procedure that implements\n"
2764 "replicated copying of a substring of some string.\n"
2766 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2767 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2768 "0 and the length of @var{s}. Replicate this substring up and\n"
2769 "down index space, in both the positive and negative directions.\n"
2770 "@code{xsubstring} returns the substring of this string\n"
2771 "beginning at index @var{from}, and ending at @var{to}, which\n"
2772 "defaults to @var{from} + (@var{end} - @var{start}).")
2773 #define FUNC_NAME s_scm_xsubstring
2776 size_t cstart
, cend
;
2780 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2784 cfrom
= scm_to_int (from
);
2785 if (SCM_UNBNDP (to
))
2786 cto
= cfrom
+ (cend
- cstart
);
2788 cto
= scm_to_int (to
);
2789 if (cstart
== cend
&& cfrom
!= cto
)
2790 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2792 result
= scm_i_make_string (cto
- cfrom
, NULL
);
2793 result
= scm_i_string_start_writing (result
);
2798 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2800 scm_i_string_set_x (result
, p
,
2801 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2803 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2807 scm_i_string_stop_writing ();
2809 scm_remember_upto_here_1 (s
);
2815 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2816 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2817 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2818 "is written into the string @var{target} starting at index\n"
2819 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2820 "@var{target} @var{s})} or these arguments share storage -- you\n"
2821 "cannot copy a string on top of itself.")
2822 #define FUNC_NAME s_scm_string_xcopy_x
2825 size_t ctstart
, cstart
, cend
;
2827 SCM dummy
= SCM_UNDEFINED
;
2830 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2833 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2836 csfrom
= scm_to_int (sfrom
);
2837 if (SCM_UNBNDP (sto
))
2838 csto
= csfrom
+ (cend
- cstart
);
2840 csto
= scm_to_int (sto
);
2841 if (cstart
== cend
&& csfrom
!= csto
)
2842 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2843 SCM_ASSERT_RANGE (1, tstart
,
2844 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2847 target
= scm_i_string_start_writing (target
);
2848 while (csfrom
< csto
)
2850 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2852 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2854 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2858 scm_i_string_stop_writing ();
2860 scm_remember_upto_here_2 (target
, s
);
2861 return SCM_UNSPECIFIED
;
2866 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2867 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2868 "Return the string @var{s1}, but with the characters\n"
2869 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2870 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2871 #define FUNC_NAME s_scm_string_replace
2873 size_t cstart1
, cend1
, cstart2
, cend2
;
2876 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2879 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2882 return (scm_string_append
2883 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2884 scm_i_substring (s2
, cstart2
, cend2
),
2885 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2891 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2892 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2893 "Split the string @var{s} into a list of substrings, where each\n"
2894 "substring is a maximal non-empty contiguous sequence of\n"
2895 "characters from the character set @var{token_set}, which\n"
2896 "defaults to @code{char-set:graphic}.\n"
2897 "If @var{start} or @var{end} indices are provided, they restrict\n"
2898 "@code{string-tokenize} to operating on the indicated substring\n"
2900 #define FUNC_NAME s_scm_string_tokenize
2902 size_t cstart
, cend
;
2903 SCM result
= SCM_EOL
;
2905 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2909 if (SCM_UNBNDP (token_set
))
2910 token_set
= scm_char_set_graphic
;
2912 if (SCM_CHARSETP (token_set
))
2916 while (cstart
< cend
)
2918 while (cstart
< cend
)
2920 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2927 while (cstart
< cend
)
2929 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2933 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2937 SCM_WRONG_TYPE_ARG (2, token_set
);
2939 scm_remember_upto_here_1 (s
);
2944 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2946 "Split the string @var{str} into the a list of the substrings delimited\n"
2947 "by appearances of the character @var{chr}. Note that an empty substring\n"
2948 "between separator characters will result in an empty string in the\n"
2952 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2954 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2956 "(string-split \"::\" #\\:)\n"
2958 "(\"\" \"\" \"\")\n"
2960 "(string-split \"\" #\\:)\n"
2964 #define FUNC_NAME s_scm_string_split
2970 SCM_VALIDATE_STRING (1, str
);
2971 SCM_VALIDATE_CHAR (2, chr
);
2973 /* This is explicit wide/narrow logic (instead of using
2974 scm_i_string_ref) is a speed optimization. */
2975 idx
= scm_i_string_length (str
);
2976 narrow
= scm_i_is_narrow_string (str
);
2979 const char *buf
= scm_i_string_chars (str
);
2983 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
2987 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
2994 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
2998 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3002 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3007 scm_remember_upto_here_1 (str
);
3013 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3014 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3015 "Filter the string @var{s}, retaining only those characters\n"
3016 "which satisfy @var{char_pred}.\n"
3018 "If @var{char_pred} is a procedure, it is applied to each\n"
3019 "character as a predicate, if it is a character, it is tested\n"
3020 "for equality and if it is a character set, it is tested for\n"
3022 #define FUNC_NAME s_scm_string_filter
3024 size_t cstart
, cend
;
3028 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3032 /* The explicit loops below stripping leading and trailing non-matches
3033 mean we can return a substring if those are the only deletions, making
3034 string-filter as efficient as string-trim-both in that case. */
3036 if (SCM_CHARP (char_pred
))
3040 /* strip leading non-matches by incrementing cstart */
3041 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3044 /* strip trailing non-matches by decrementing cend */
3045 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3048 /* count chars to keep */
3050 for (idx
= cstart
; idx
< cend
; idx
++)
3051 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3054 if (count
== cend
- cstart
)
3056 /* whole of cstart to cend is to be kept, return a copy-on-write
3059 result
= scm_i_substring (s
, cstart
, cend
);
3062 result
= scm_c_make_string (count
, char_pred
);
3064 else if (SCM_CHARSETP (char_pred
))
3068 /* strip leading non-matches by incrementing cstart */
3069 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3072 /* strip trailing non-matches by decrementing cend */
3073 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3076 /* count chars to be kept */
3078 for (idx
= cstart
; idx
< cend
; idx
++)
3079 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3082 /* if whole of start to end kept then return substring */
3083 if (count
== cend
- cstart
)
3084 goto result_substring
;
3088 result
= scm_i_make_string (count
, NULL
);
3089 result
= scm_i_string_start_writing (result
);
3091 /* decrement "count" in this loop as well as using idx, so that if
3092 another thread is simultaneously changing "s" there's no chance
3093 it'll make us copy more than count characters */
3094 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3096 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3098 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3103 scm_i_string_stop_writing ();
3109 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3111 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3116 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3117 res
= pred_tramp (char_pred
, ch
);
3118 if (scm_is_true (res
))
3119 ls
= scm_cons (ch
, ls
);
3122 result
= scm_reverse_list_to_string (ls
);
3125 scm_remember_upto_here_1 (s
);
3131 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3132 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3133 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3135 "If @var{char_pred} is a procedure, it is applied to each\n"
3136 "character as a predicate, if it is a character, it is tested\n"
3137 "for equality and if it is a character set, it is tested for\n"
3139 #define FUNC_NAME s_scm_string_delete
3141 size_t cstart
, cend
;
3145 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3149 /* The explicit loops below stripping leading and trailing matches mean we
3150 can return a substring if those are the only deletions, making
3151 string-delete as efficient as string-trim-both in that case. */
3153 if (SCM_CHARP (char_pred
))
3157 /* strip leading matches by incrementing cstart */
3158 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3161 /* strip trailing matches by decrementing cend */
3162 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3165 /* count chars to be kept */
3167 for (idx
= cstart
; idx
< cend
; idx
++)
3168 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3171 if (count
== cend
- cstart
)
3173 /* whole of cstart to cend is to be kept, return a copy-on-write
3176 result
= scm_i_substring (s
, cstart
, cend
);
3181 /* new string for retained portion */
3182 result
= scm_i_make_string (count
, NULL
);
3183 result
= scm_i_string_start_writing (result
);
3184 /* decrement "count" in this loop as well as using idx, so that if
3185 another thread is simultaneously changing "s" there's no chance
3186 it'll make us copy more than count characters */
3187 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3189 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3190 if (c
!= SCM_CHAR (char_pred
))
3192 scm_i_string_set_x (result
, i
, c
);
3197 scm_i_string_stop_writing ();
3200 else if (SCM_CHARSETP (char_pred
))
3204 /* strip leading matches by incrementing cstart */
3205 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3208 /* strip trailing matches by decrementing cend */
3209 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3212 /* count chars to be kept */
3214 for (idx
= cstart
; idx
< cend
; idx
++)
3215 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3218 if (count
== cend
- cstart
)
3219 goto result_substring
;
3223 /* new string for retained portion */
3224 result
= scm_i_make_string (count
, NULL
);
3225 result
= scm_i_string_start_writing (result
);
3227 /* decrement "count" in this loop as well as using idx, so that if
3228 another thread is simultaneously changing "s" there's no chance
3229 it'll make us copy more than count characters */
3230 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3232 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3234 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3239 scm_i_string_stop_writing ();
3245 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3246 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3251 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3252 res
= pred_tramp (char_pred
, ch
);
3253 if (scm_is_false (res
))
3254 ls
= scm_cons (ch
, ls
);
3257 result
= scm_reverse_list_to_string (ls
);
3260 scm_remember_upto_here_1 (s
);
3266 scm_init_srfi_13 (void)
3268 #include "libguile/srfi-13.x"
3271 /* End of srfi-13.c. */