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_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1172 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1173 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1175 /* Fast path for this common case, which avoids the repeated calls to
1176 `scm_i_string_ref'. */
1179 len1
= scm_i_string_length (s1
);
1180 len2
= scm_i_string_length (s2
);
1182 if (SCM_LIKELY (len1
== len2
))
1184 if (!scm_i_is_narrow_string (s1
))
1187 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1188 scm_i_string_data (s2
),
1193 return compare_strings (FUNC_NAME
, 0,
1194 s1
, s2
, start1
, end1
, start2
, end2
,
1195 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1200 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1201 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1202 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1204 #define FUNC_NAME s_scm_string_neq
1206 return compare_strings (FUNC_NAME
, 0,
1207 s1
, s2
, start1
, end1
, start2
, end2
,
1208 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1213 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1214 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1215 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1216 "true value otherwise.")
1217 #define FUNC_NAME s_scm_string_lt
1219 return compare_strings (FUNC_NAME
, 0,
1220 s1
, s2
, start1
, end1
, start2
, end2
,
1221 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1226 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1227 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1228 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1229 "true value otherwise.")
1230 #define FUNC_NAME s_scm_string_gt
1232 return compare_strings (FUNC_NAME
, 0,
1233 s1
, s2
, start1
, end1
, start2
, end2
,
1234 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1239 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1240 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1241 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1243 #define FUNC_NAME s_scm_string_le
1245 return compare_strings (FUNC_NAME
, 0,
1246 s1
, s2
, start1
, end1
, start2
, end2
,
1247 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1252 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1253 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1254 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1256 #define FUNC_NAME s_scm_string_ge
1258 return compare_strings (FUNC_NAME
, 0,
1259 s1
, s2
, start1
, end1
, start2
, end2
,
1260 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1265 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1266 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1267 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1268 "value otherwise. The character comparison is done\n"
1269 "case-insensitively.")
1270 #define FUNC_NAME s_scm_string_ci_eq
1272 return compare_strings (FUNC_NAME
, 1,
1273 s1
, s2
, start1
, end1
, start2
, end2
,
1274 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1279 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1280 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1281 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1282 "value otherwise. The character comparison is done\n"
1283 "case-insensitively.")
1284 #define FUNC_NAME s_scm_string_ci_neq
1286 return compare_strings (FUNC_NAME
, 1,
1287 s1
, s2
, start1
, end1
, start2
, end2
,
1288 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1293 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1294 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1295 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1296 "true value otherwise. The character comparison is done\n"
1297 "case-insensitively.")
1298 #define FUNC_NAME s_scm_string_ci_lt
1300 return compare_strings (FUNC_NAME
, 1,
1301 s1
, s2
, start1
, end1
, start2
, end2
,
1302 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1307 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1308 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1309 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1310 "true value otherwise. The character comparison is done\n"
1311 "case-insensitively.")
1312 #define FUNC_NAME s_scm_string_ci_gt
1314 return compare_strings (FUNC_NAME
, 1,
1315 s1
, s2
, start1
, end1
, start2
, end2
,
1316 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1321 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1322 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1323 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1324 "value otherwise. The character comparison is done\n"
1325 "case-insensitively.")
1326 #define FUNC_NAME s_scm_string_ci_le
1328 return compare_strings (FUNC_NAME
, 1,
1329 s1
, s2
, start1
, end1
, start2
, end2
,
1330 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1335 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1336 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1337 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1338 "otherwise. The character comparison is done\n"
1339 "case-insensitively.")
1340 #define FUNC_NAME s_scm_string_ci_ge
1342 return compare_strings (FUNC_NAME
, 1,
1343 s1
, s2
, start1
, end1
, start2
, end2
,
1344 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1348 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1349 (SCM s
, SCM bound
, SCM start
, SCM end
),
1350 "Compute a hash value for @var{S}. the optional argument "
1351 "@var{bound} is a non-negative exact "
1352 "integer specifying the range of the hash function. "
1353 "A positive value restricts the return value to the "
1355 #define FUNC_NAME s_scm_substring_hash
1357 if (SCM_UNBNDP (bound
))
1358 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1359 if (SCM_UNBNDP (start
))
1361 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1365 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1366 (SCM s
, SCM bound
, SCM start
, SCM end
),
1367 "Compute a hash value for @var{S}. the optional argument "
1368 "@var{bound} is a non-negative exact "
1369 "integer specifying the range of the hash function. "
1370 "A positive value restricts the return value to the "
1372 #define FUNC_NAME s_scm_substring_hash_ci
1374 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1376 SCM_UNDEFINED
, SCM_UNDEFINED
);
1380 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1381 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1382 "Return the length of the longest common prefix of the two\n"
1384 #define FUNC_NAME s_scm_string_prefix_length
1386 size_t cstart1
, cend1
, cstart2
, cend2
;
1389 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1392 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1396 while (cstart1
< cend1
&& cstart2
< cend2
)
1398 if (scm_i_string_ref (s1
, cstart1
)
1399 != scm_i_string_ref (s2
, cstart2
))
1407 scm_remember_upto_here_2 (s1
, s2
);
1408 return scm_from_size_t (len
);
1413 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1414 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1415 "Return the length of the longest common prefix of the two\n"
1416 "strings, ignoring character case.")
1417 #define FUNC_NAME s_scm_string_prefix_length_ci
1419 size_t cstart1
, cend1
, cstart2
, cend2
;
1422 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1425 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1428 while (cstart1
< cend1
&& cstart2
< cend2
)
1430 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1431 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1439 scm_remember_upto_here_2 (s1
, s2
);
1440 return scm_from_size_t (len
);
1445 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1446 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1447 "Return the length of the longest common suffix of the two\n"
1449 #define FUNC_NAME s_scm_string_suffix_length
1451 size_t cstart1
, cend1
, cstart2
, cend2
;
1454 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1457 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1460 while (cstart1
< cend1
&& cstart2
< cend2
)
1464 if (scm_i_string_ref (s1
, cend1
)
1465 != scm_i_string_ref (s2
, cend2
))
1471 scm_remember_upto_here_2 (s1
, s2
);
1472 return scm_from_size_t (len
);
1477 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1478 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1479 "Return the length of the longest common suffix of the two\n"
1480 "strings, ignoring character case.")
1481 #define FUNC_NAME s_scm_string_suffix_length_ci
1483 size_t cstart1
, cend1
, cstart2
, cend2
;
1486 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1489 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1492 while (cstart1
< cend1
&& cstart2
< cend2
)
1496 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1497 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1503 scm_remember_upto_here_2 (s1
, s2
);
1504 return scm_from_size_t (len
);
1509 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1510 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1511 "Is @var{s1} a prefix of @var{s2}?")
1512 #define FUNC_NAME s_scm_string_prefix_p
1514 size_t cstart1
, cend1
, cstart2
, cend2
;
1515 size_t len
= 0, len1
;
1517 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1520 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1523 len1
= cend1
- cstart1
;
1524 while (cstart1
< cend1
&& cstart2
< cend2
)
1526 if (scm_i_string_ref (s1
, cstart1
)
1527 != scm_i_string_ref (s2
, cstart2
))
1535 scm_remember_upto_here_2 (s1
, s2
);
1536 return scm_from_bool (len
== len1
);
1541 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1542 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1543 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1544 #define FUNC_NAME s_scm_string_prefix_ci_p
1546 size_t cstart1
, cend1
, cstart2
, cend2
;
1547 size_t len
= 0, len1
;
1549 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1552 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1555 len1
= cend1
- cstart1
;
1556 while (cstart1
< cend1
&& cstart2
< cend2
)
1558 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1559 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1568 scm_remember_upto_here_2 (s1
, s2
);
1569 return scm_from_bool (len
== len1
);
1574 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1575 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1576 "Is @var{s1} a suffix of @var{s2}?")
1577 #define FUNC_NAME s_scm_string_suffix_p
1579 size_t cstart1
, cend1
, cstart2
, cend2
;
1580 size_t len
= 0, len1
;
1582 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1585 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1588 len1
= cend1
- cstart1
;
1589 while (cstart1
< cend1
&& cstart2
< cend2
)
1593 if (scm_i_string_ref (s1
, cend1
)
1594 != scm_i_string_ref (s2
, cend2
))
1600 scm_remember_upto_here_2 (s1
, s2
);
1601 return scm_from_bool (len
== len1
);
1606 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1607 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1608 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1609 #define FUNC_NAME s_scm_string_suffix_ci_p
1611 size_t cstart1
, cend1
, cstart2
, cend2
;
1612 size_t len
= 0, len1
;
1614 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1617 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1620 len1
= cend1
- cstart1
;
1621 while (cstart1
< cend1
&& cstart2
< cend2
)
1625 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1626 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1632 scm_remember_upto_here_2 (s1
, s2
);
1633 return scm_from_bool (len
== len1
);
1638 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1639 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1640 "Search through the string @var{s} from left to right, returning\n"
1641 "the index of the first occurence of a character which\n"
1643 "@itemize @bullet\n"
1645 "equals @var{char_pred}, if it is character,\n"
1648 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1651 "is in the set @var{char_pred}, if it is a character set.\n"
1653 #define FUNC_NAME s_scm_string_index
1655 size_t cstart
, cend
;
1657 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1660 if (SCM_CHARP (char_pred
))
1662 while (cstart
< cend
)
1664 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1669 else if (SCM_CHARSETP (char_pred
))
1671 while (cstart
< cend
)
1673 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1680 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1681 char_pred
, SCM_ARG2
, FUNC_NAME
);
1683 while (cstart
< cend
)
1686 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1687 if (scm_is_true (res
))
1693 scm_remember_upto_here_1 (s
);
1697 scm_remember_upto_here_1 (s
);
1698 return scm_from_size_t (cstart
);
1702 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1703 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1704 "Search through the string @var{s} from right to left, returning\n"
1705 "the index of the last occurence of a character which\n"
1707 "@itemize @bullet\n"
1709 "equals @var{char_pred}, if it is character,\n"
1712 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1715 "is in the set if @var{char_pred} is a character set.\n"
1717 #define FUNC_NAME s_scm_string_index_right
1719 size_t cstart
, cend
;
1721 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1724 if (SCM_CHARP (char_pred
))
1726 while (cstart
< cend
)
1729 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1733 else if (SCM_CHARSETP (char_pred
))
1735 while (cstart
< cend
)
1738 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1744 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1745 char_pred
, SCM_ARG2
, FUNC_NAME
);
1747 while (cstart
< cend
)
1751 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1752 if (scm_is_true (res
))
1757 scm_remember_upto_here_1 (s
);
1761 scm_remember_upto_here_1 (s
);
1762 return scm_from_size_t (cend
);
1766 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1767 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1768 "Search through the string @var{s} from right to left, returning\n"
1769 "the index of the last occurence of a character which\n"
1771 "@itemize @bullet\n"
1773 "equals @var{char_pred}, if it is character,\n"
1776 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1779 "is in the set if @var{char_pred} is a character set.\n"
1781 #define FUNC_NAME s_scm_string_rindex
1783 return scm_string_index_right (s
, char_pred
, start
, end
);
1787 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1788 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1789 "Search through the string @var{s} from left to right, returning\n"
1790 "the index of the first occurence of a character which\n"
1792 "@itemize @bullet\n"
1794 "does not equal @var{char_pred}, if it is character,\n"
1797 "does not satisify the predicate @var{char_pred}, if it is a\n"
1801 "is not in the set if @var{char_pred} is a character set.\n"
1803 #define FUNC_NAME s_scm_string_skip
1805 size_t cstart
, cend
;
1807 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1810 if (SCM_CHARP (char_pred
))
1812 while (cstart
< cend
)
1814 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1819 else if (SCM_CHARSETP (char_pred
))
1821 while (cstart
< cend
)
1823 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1830 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1831 char_pred
, SCM_ARG2
, FUNC_NAME
);
1833 while (cstart
< cend
)
1836 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1837 if (scm_is_false (res
))
1843 scm_remember_upto_here_1 (s
);
1847 scm_remember_upto_here_1 (s
);
1848 return scm_from_size_t (cstart
);
1853 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1854 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1855 "Search through the string @var{s} from right to left, returning\n"
1856 "the index of the last occurence of a character which\n"
1858 "@itemize @bullet\n"
1860 "does not equal @var{char_pred}, if it is character,\n"
1863 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1867 "is not in the set if @var{char_pred} is a character set.\n"
1869 #define FUNC_NAME s_scm_string_skip_right
1871 size_t cstart
, cend
;
1873 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1876 if (SCM_CHARP (char_pred
))
1878 while (cstart
< cend
)
1881 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1885 else if (SCM_CHARSETP (char_pred
))
1887 while (cstart
< cend
)
1890 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1896 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1897 char_pred
, SCM_ARG2
, FUNC_NAME
);
1899 while (cstart
< cend
)
1903 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1904 if (scm_is_false (res
))
1909 scm_remember_upto_here_1 (s
);
1913 scm_remember_upto_here_1 (s
);
1914 return scm_from_size_t (cend
);
1920 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1921 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1922 "Return the count of the number of characters in the string\n"
1925 "@itemize @bullet\n"
1927 "equals @var{char_pred}, if it is character,\n"
1930 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1933 "is in the set @var{char_pred}, if it is a character set.\n"
1935 #define FUNC_NAME s_scm_string_count
1937 size_t cstart
, cend
;
1940 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1943 if (SCM_CHARP (char_pred
))
1945 while (cstart
< cend
)
1947 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1952 else if (SCM_CHARSETP (char_pred
))
1954 while (cstart
< cend
)
1956 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1963 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1964 char_pred
, SCM_ARG2
, FUNC_NAME
);
1966 while (cstart
< cend
)
1969 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1970 if (scm_is_true (res
))
1976 scm_remember_upto_here_1 (s
);
1977 return scm_from_size_t (count
);
1982 /* FIXME::martin: This should definitely get implemented more
1983 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1985 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1986 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1987 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1988 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1989 "The optional start/end indices restrict the operation to the\n"
1990 "indicated substrings.")
1991 #define FUNC_NAME s_scm_string_contains
1993 size_t cstart1
, cend1
, cstart2
, cend2
;
1996 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1999 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2002 len2
= cend2
- cstart2
;
2003 if (cend1
- cstart1
>= len2
)
2004 while (cstart1
<= cend1
- len2
)
2010 && (scm_i_string_ref (s1
, i
)
2011 == scm_i_string_ref (s2
, j
)))
2018 scm_remember_upto_here_2 (s1
, s2
);
2019 return scm_from_size_t (cstart1
);
2024 scm_remember_upto_here_2 (s1
, s2
);
2030 /* FIXME::martin: This should definitely get implemented more
2031 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2033 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2034 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2035 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2036 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2037 "The optional start/end indices restrict the operation to the\n"
2038 "indicated substrings. Character comparison is done\n"
2039 "case-insensitively.")
2040 #define FUNC_NAME s_scm_string_contains_ci
2042 size_t cstart1
, cend1
, cstart2
, cend2
;
2045 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2048 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2051 len2
= cend2
- cstart2
;
2052 if (cend1
- cstart1
>= len2
)
2053 while (cstart1
<= cend1
- len2
)
2059 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2060 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2067 scm_remember_upto_here_2 (s1
, s2
);
2068 return scm_from_size_t (cstart1
);
2073 scm_remember_upto_here_2 (s1
, s2
);
2079 /* Helper function for the string uppercase conversion functions. */
2081 string_upcase_x (SCM v
, size_t start
, size_t end
)
2085 v
= scm_i_string_start_writing (v
);
2086 for (k
= start
; k
< end
; ++k
)
2087 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2088 scm_i_string_stop_writing ();
2089 scm_remember_upto_here_1 (v
);
2094 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2095 (SCM str
, SCM start
, SCM end
),
2096 "Destructively upcase every character in @code{str}.\n"
2099 "(string-upcase! y)\n"
2100 "@result{} \"ARRDEFG\"\n"
2102 "@result{} \"ARRDEFG\"\n"
2104 #define FUNC_NAME s_scm_substring_upcase_x
2106 size_t cstart
, cend
;
2108 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2111 return string_upcase_x (str
, cstart
, cend
);
2116 scm_string_upcase_x (SCM str
)
2118 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2121 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2122 (SCM str
, SCM start
, SCM end
),
2123 "Upcase every character in @code{str}.")
2124 #define FUNC_NAME s_scm_substring_upcase
2126 size_t cstart
, cend
;
2128 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2131 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2136 scm_string_upcase (SCM str
)
2138 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2141 /* Helper function for the string lowercase conversion functions.
2142 * No argument checking is performed. */
2144 string_downcase_x (SCM v
, size_t start
, size_t end
)
2148 v
= scm_i_string_start_writing (v
);
2149 for (k
= start
; k
< end
; ++k
)
2150 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2151 scm_i_string_stop_writing ();
2152 scm_remember_upto_here_1 (v
);
2157 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2158 (SCM str
, SCM start
, SCM end
),
2159 "Destructively downcase every character in @var{str}.\n"
2163 "@result{} \"ARRDEFG\"\n"
2164 "(string-downcase! y)\n"
2165 "@result{} \"arrdefg\"\n"
2167 "@result{} \"arrdefg\"\n"
2169 #define FUNC_NAME s_scm_substring_downcase_x
2171 size_t cstart
, cend
;
2173 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2176 return string_downcase_x (str
, cstart
, cend
);
2181 scm_string_downcase_x (SCM str
)
2183 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2186 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2187 (SCM str
, SCM start
, SCM end
),
2188 "Downcase every character in @var{str}.")
2189 #define FUNC_NAME s_scm_substring_downcase
2191 size_t cstart
, cend
;
2193 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2196 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2201 scm_string_downcase (SCM str
)
2203 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2206 /* Helper function for the string capitalization functions.
2207 * No argument checking is performed. */
2209 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2215 str
= scm_i_string_start_writing (str
);
2216 for(i
= start
; i
< end
; i
++)
2218 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2219 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2223 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2228 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2234 scm_i_string_stop_writing ();
2235 scm_remember_upto_here_1 (str
);
2241 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2242 (SCM str
, SCM start
, SCM end
),
2243 "Destructively titlecase every first character in a word in\n"
2245 #define FUNC_NAME s_scm_string_titlecase_x
2247 size_t cstart
, cend
;
2249 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2252 return string_titlecase_x (str
, cstart
, cend
);
2257 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2258 (SCM str
, SCM start
, SCM end
),
2259 "Titlecase every first character in a word in @var{str}.")
2260 #define FUNC_NAME s_scm_string_titlecase
2262 size_t cstart
, cend
;
2264 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2267 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2271 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2273 "Upcase the first character of every word in @var{str}\n"
2274 "destructively and return @var{str}.\n"
2277 "y @result{} \"hello world\"\n"
2278 "(string-capitalize! y) @result{} \"Hello World\"\n"
2279 "y @result{} \"Hello World\"\n"
2281 #define FUNC_NAME s_scm_string_capitalize_x
2283 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2288 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2290 "Return a freshly allocated string with the characters in\n"
2291 "@var{str}, where the first character of every word is\n"
2293 #define FUNC_NAME s_scm_string_capitalize
2295 return scm_string_capitalize_x (scm_string_copy (str
));
2300 /* Reverse the portion of @var{str} between str[cstart] (including)
2301 and str[cend] excluding. */
2303 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2307 str
= scm_i_string_start_writing (str
);
2311 while (cstart
< cend
)
2313 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2314 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2315 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2320 scm_i_string_stop_writing ();
2324 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2325 (SCM str
, SCM start
, SCM end
),
2326 "Reverse the string @var{str}. The optional arguments\n"
2327 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2329 #define FUNC_NAME s_scm_string_reverse
2331 size_t cstart
, cend
;
2334 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2337 result
= scm_string_copy (str
);
2338 string_reverse_x (result
, cstart
, cend
);
2339 scm_remember_upto_here_1 (str
);
2345 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2346 (SCM str
, SCM start
, SCM end
),
2347 "Reverse the string @var{str} in-place. The optional arguments\n"
2348 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2349 "operate on. The return value is unspecified.")
2350 #define FUNC_NAME s_scm_string_reverse_x
2352 size_t cstart
, cend
;
2354 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2358 string_reverse_x (str
, cstart
, cend
);
2359 scm_remember_upto_here_1 (str
);
2360 return SCM_UNSPECIFIED
;
2365 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2367 "Like @code{string-append}, but the result may share memory\n"
2368 "with the argument strings.")
2369 #define FUNC_NAME s_scm_string_append_shared
2371 /* If "rest" contains just one non-empty string, return that.
2372 If it's entirely empty strings, then return scm_nullstr.
2373 Otherwise use scm_string_concatenate. */
2375 SCM ret
= scm_nullstr
;
2376 int seen_nonempty
= 0;
2379 SCM_VALIDATE_REST_ARGUMENT (rest
);
2381 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2384 if (!scm_is_string (s
))
2385 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2386 if (scm_i_string_length (s
) != 0)
2389 /* two or more non-empty strings, need full concat */
2390 return scm_string_append (rest
);
2401 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2403 "Append the elements of @var{ls} (which must be strings)\n"
2404 "together into a single string. Guaranteed to return a freshly\n"
2405 "allocated string.")
2406 #define FUNC_NAME s_scm_string_concatenate
2408 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2409 return scm_string_append (ls
);
2414 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2415 (SCM ls
, SCM final_string
, SCM end
),
2416 "Without optional arguments, this procedure is equivalent to\n"
2419 "(string-concatenate (reverse ls))\n"
2422 "If the optional argument @var{final_string} is specified, it is\n"
2423 "consed onto the beginning to @var{ls} before performing the\n"
2424 "list-reverse and string-concatenate operations. If @var{end}\n"
2425 "is given, only the characters of @var{final_string} up to index\n"
2426 "@var{end} are used.\n"
2428 "Guaranteed to return a freshly allocated string.")
2429 #define FUNC_NAME s_scm_string_concatenate_reverse
2431 if (!SCM_UNBNDP (end
))
2432 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2434 if (!SCM_UNBNDP (final_string
))
2435 ls
= scm_cons (final_string
, ls
);
2437 return scm_string_concatenate (scm_reverse (ls
));
2442 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2444 "Like @code{string-concatenate}, but the result may share memory\n"
2445 "with the strings in the list @var{ls}.")
2446 #define FUNC_NAME s_scm_string_concatenate_shared
2448 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2449 return scm_string_append_shared (ls
);
2454 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2455 (SCM ls
, SCM final_string
, SCM end
),
2456 "Like @code{string-concatenate-reverse}, but the result may\n"
2457 "share memory with the the strings in the @var{ls} arguments.")
2458 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2460 /* Just call the non-sharing version. */
2461 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2466 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2467 (SCM proc
, SCM s
, SCM start
, SCM end
),
2468 "@var{proc} is a char->char procedure, it is mapped over\n"
2469 "@var{s}. The order in which the procedure is applied to the\n"
2470 "string elements is not specified.")
2471 #define FUNC_NAME s_scm_string_map
2474 size_t cstart
, cend
;
2477 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2478 proc
, SCM_ARG1
, FUNC_NAME
);
2479 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2482 result
= scm_i_make_string (cend
- cstart
, NULL
);
2484 while (cstart
< cend
)
2486 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2487 if (!SCM_CHARP (ch
))
2488 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2490 result
= scm_i_string_start_writing (result
);
2491 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2492 scm_i_string_stop_writing ();
2501 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2502 (SCM proc
, SCM s
, SCM start
, SCM end
),
2503 "@var{proc} is a char->char procedure, it is mapped over\n"
2504 "@var{s}. The order in which the procedure is applied to the\n"
2505 "string elements is not specified. The string @var{s} is\n"
2506 "modified in-place, the return value is not specified.")
2507 #define FUNC_NAME s_scm_string_map_x
2509 size_t cstart
, cend
;
2511 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2512 proc
, SCM_ARG1
, FUNC_NAME
);
2513 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2516 while (cstart
< cend
)
2518 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2519 if (!SCM_CHARP (ch
))
2520 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2521 s
= scm_i_string_start_writing (s
);
2522 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2523 scm_i_string_stop_writing ();
2526 return SCM_UNSPECIFIED
;
2531 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2532 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2533 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2534 "as the terminating element, from left to right. @var{kons}\n"
2535 "must expect two arguments: The actual character and the last\n"
2536 "result of @var{kons}' application.")
2537 #define FUNC_NAME s_scm_string_fold
2539 size_t cstart
, cend
;
2542 SCM_VALIDATE_PROC (1, kons
);
2543 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2547 while (cstart
< cend
)
2549 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2553 scm_remember_upto_here_1 (s
);
2559 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2560 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2561 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2562 "as the terminating element, from right to left. @var{kons}\n"
2563 "must expect two arguments: The actual character and the last\n"
2564 "result of @var{kons}' application.")
2565 #define FUNC_NAME s_scm_string_fold_right
2567 size_t cstart
, cend
;
2570 SCM_VALIDATE_PROC (1, kons
);
2571 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2575 while (cstart
< cend
)
2577 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2581 scm_remember_upto_here_1 (s
);
2587 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2588 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2589 "@itemize @bullet\n"
2590 "@item @var{g} is used to generate a series of @emph{seed}\n"
2591 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2592 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2594 "@item @var{p} tells us when to stop -- when it returns true\n"
2595 "when applied to one of these seed values.\n"
2596 "@item @var{f} maps each seed value to the corresponding\n"
2597 "character in the result string. These chars are assembled\n"
2598 "into the string in a left-to-right order.\n"
2599 "@item @var{base} is the optional initial/leftmost portion\n"
2600 "of the constructed string; it default to the empty\n"
2602 "@item @var{make_final} is applied to the terminal seed\n"
2603 "value (on which @var{p} returns true) to produce\n"
2604 "the final/rightmost portion of the constructed string.\n"
2605 "It defaults to @code{(lambda (x) "")}.\n"
2607 #define FUNC_NAME s_scm_string_unfold
2611 SCM_VALIDATE_PROC (1, p
);
2612 SCM_VALIDATE_PROC (2, f
);
2613 SCM_VALIDATE_PROC (3, g
);
2614 if (!SCM_UNBNDP (base
))
2616 SCM_VALIDATE_STRING (5, base
);
2620 ans
= scm_i_make_string (0, NULL
);
2621 if (!SCM_UNBNDP (make_final
))
2622 SCM_VALIDATE_PROC (6, make_final
);
2624 res
= scm_call_1 (p
, seed
);
2625 while (scm_is_false (res
))
2629 SCM ch
= scm_call_1 (f
, seed
);
2630 if (!SCM_CHARP (ch
))
2631 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2632 str
= scm_i_make_string (1, NULL
);
2633 str
= scm_i_string_start_writing (str
);
2634 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2635 scm_i_string_stop_writing ();
2638 ans
= scm_string_append (scm_list_2 (ans
, str
));
2639 seed
= scm_call_1 (g
, seed
);
2640 res
= scm_call_1 (p
, seed
);
2642 if (!SCM_UNBNDP (make_final
))
2644 res
= scm_call_1 (make_final
, seed
);
2645 return scm_string_append (scm_list_2 (ans
, res
));
2653 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2654 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2655 "@itemize @bullet\n"
2656 "@item @var{g} is used to generate a series of @emph{seed}\n"
2657 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2658 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2660 "@item @var{p} tells us when to stop -- when it returns true\n"
2661 "when applied to one of these seed values.\n"
2662 "@item @var{f} maps each seed value to the corresponding\n"
2663 "character in the result string. These chars are assembled\n"
2664 "into the string in a right-to-left order.\n"
2665 "@item @var{base} is the optional initial/rightmost portion\n"
2666 "of the constructed string; it default to the empty\n"
2668 "@item @var{make_final} is applied to the terminal seed\n"
2669 "value (on which @var{p} returns true) to produce\n"
2670 "the final/leftmost portion of the constructed string.\n"
2671 "It defaults to @code{(lambda (x) "")}.\n"
2673 #define FUNC_NAME s_scm_string_unfold_right
2677 SCM_VALIDATE_PROC (1, p
);
2678 SCM_VALIDATE_PROC (2, f
);
2679 SCM_VALIDATE_PROC (3, g
);
2680 if (!SCM_UNBNDP (base
))
2682 SCM_VALIDATE_STRING (5, base
);
2686 ans
= scm_i_make_string (0, NULL
);
2687 if (!SCM_UNBNDP (make_final
))
2688 SCM_VALIDATE_PROC (6, make_final
);
2690 res
= scm_call_1 (p
, seed
);
2691 while (scm_is_false (res
))
2695 SCM ch
= scm_call_1 (f
, seed
);
2696 if (!SCM_CHARP (ch
))
2697 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2698 str
= scm_i_make_string (1, NULL
);
2699 str
= scm_i_string_start_writing (str
);
2700 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2701 scm_i_string_stop_writing ();
2704 ans
= scm_string_append (scm_list_2 (str
, ans
));
2705 seed
= scm_call_1 (g
, seed
);
2706 res
= scm_call_1 (p
, seed
);
2708 if (!SCM_UNBNDP (make_final
))
2710 res
= scm_call_1 (make_final
, seed
);
2711 return scm_string_append (scm_list_2 (res
, ans
));
2719 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2720 (SCM proc
, SCM s
, SCM start
, SCM end
),
2721 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2722 "return value is not specified.")
2723 #define FUNC_NAME s_scm_string_for_each
2725 size_t cstart
, cend
;
2727 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2728 proc
, SCM_ARG1
, FUNC_NAME
);
2729 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2732 while (cstart
< cend
)
2734 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2738 scm_remember_upto_here_1 (s
);
2739 return SCM_UNSPECIFIED
;
2743 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2744 (SCM proc
, SCM s
, SCM start
, SCM end
),
2745 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2748 "For example, to change characters to alternately upper and\n"
2752 "(define str (string-copy \"studly\"))\n"
2753 "(string-for-each-index\n"
2755 " (string-set! str i\n"
2756 " ((if (even? i) char-upcase char-downcase)\n"
2757 " (string-ref str i))))\n"
2759 "str @result{} \"StUdLy\"\n"
2761 #define FUNC_NAME s_scm_string_for_each_index
2763 size_t cstart
, cend
;
2765 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2766 proc
, SCM_ARG1
, FUNC_NAME
);
2767 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2771 while (cstart
< cend
)
2773 scm_call_1 (proc
, scm_from_size_t (cstart
));
2777 scm_remember_upto_here_1 (s
);
2778 return SCM_UNSPECIFIED
;
2782 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2783 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2784 "This is the @emph{extended substring} procedure that implements\n"
2785 "replicated copying of a substring of some string.\n"
2787 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2788 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2789 "0 and the length of @var{s}. Replicate this substring up and\n"
2790 "down index space, in both the positive and negative directions.\n"
2791 "@code{xsubstring} returns the substring of this string\n"
2792 "beginning at index @var{from}, and ending at @var{to}, which\n"
2793 "defaults to @var{from} + (@var{end} - @var{start}).")
2794 #define FUNC_NAME s_scm_xsubstring
2797 size_t cstart
, cend
;
2801 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2805 cfrom
= scm_to_int (from
);
2806 if (SCM_UNBNDP (to
))
2807 cto
= cfrom
+ (cend
- cstart
);
2809 cto
= scm_to_int (to
);
2810 if (cstart
== cend
&& cfrom
!= cto
)
2811 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2813 result
= scm_i_make_string (cto
- cfrom
, NULL
);
2814 result
= scm_i_string_start_writing (result
);
2819 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2821 scm_i_string_set_x (result
, p
,
2822 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2824 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2828 scm_i_string_stop_writing ();
2830 scm_remember_upto_here_1 (s
);
2836 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2837 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2838 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2839 "is written into the string @var{target} starting at index\n"
2840 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2841 "@var{target} @var{s})} or these arguments share storage -- you\n"
2842 "cannot copy a string on top of itself.")
2843 #define FUNC_NAME s_scm_string_xcopy_x
2846 size_t ctstart
, cstart
, cend
;
2848 SCM dummy
= SCM_UNDEFINED
;
2851 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2854 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2857 csfrom
= scm_to_int (sfrom
);
2858 if (SCM_UNBNDP (sto
))
2859 csto
= csfrom
+ (cend
- cstart
);
2861 csto
= scm_to_int (sto
);
2862 if (cstart
== cend
&& csfrom
!= csto
)
2863 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2864 SCM_ASSERT_RANGE (1, tstart
,
2865 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2868 target
= scm_i_string_start_writing (target
);
2869 while (csfrom
< csto
)
2871 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2873 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2875 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2879 scm_i_string_stop_writing ();
2881 scm_remember_upto_here_2 (target
, s
);
2882 return SCM_UNSPECIFIED
;
2887 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2888 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2889 "Return the string @var{s1}, but with the characters\n"
2890 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2891 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2892 #define FUNC_NAME s_scm_string_replace
2894 size_t cstart1
, cend1
, cstart2
, cend2
;
2897 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2900 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2903 return (scm_string_append
2904 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2905 scm_i_substring (s2
, cstart2
, cend2
),
2906 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2912 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2913 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2914 "Split the string @var{s} into a list of substrings, where each\n"
2915 "substring is a maximal non-empty contiguous sequence of\n"
2916 "characters from the character set @var{token_set}, which\n"
2917 "defaults to @code{char-set:graphic}.\n"
2918 "If @var{start} or @var{end} indices are provided, they restrict\n"
2919 "@code{string-tokenize} to operating on the indicated substring\n"
2921 #define FUNC_NAME s_scm_string_tokenize
2923 size_t cstart
, cend
;
2924 SCM result
= SCM_EOL
;
2926 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2930 if (SCM_UNBNDP (token_set
))
2931 token_set
= scm_char_set_graphic
;
2933 if (SCM_CHARSETP (token_set
))
2937 while (cstart
< cend
)
2939 while (cstart
< cend
)
2941 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2948 while (cstart
< cend
)
2950 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2954 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2958 SCM_WRONG_TYPE_ARG (2, token_set
);
2960 scm_remember_upto_here_1 (s
);
2965 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2967 "Split the string @var{str} into the a list of the substrings delimited\n"
2968 "by appearances of the character @var{chr}. Note that an empty substring\n"
2969 "between separator characters will result in an empty string in the\n"
2973 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2975 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2977 "(string-split \"::\" #\\:)\n"
2979 "(\"\" \"\" \"\")\n"
2981 "(string-split \"\" #\\:)\n"
2985 #define FUNC_NAME s_scm_string_split
2991 SCM_VALIDATE_STRING (1, str
);
2992 SCM_VALIDATE_CHAR (2, chr
);
2994 /* This is explicit wide/narrow logic (instead of using
2995 scm_i_string_ref) is a speed optimization. */
2996 idx
= scm_i_string_length (str
);
2997 narrow
= scm_i_is_narrow_string (str
);
3000 const char *buf
= scm_i_string_chars (str
);
3004 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
3008 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3015 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3019 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3023 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3028 scm_remember_upto_here_1 (str
);
3034 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3035 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3036 "Filter the string @var{s}, retaining only those characters\n"
3037 "which satisfy @var{char_pred}.\n"
3039 "If @var{char_pred} is a procedure, it is applied to each\n"
3040 "character as a predicate, if it is a character, it is tested\n"
3041 "for equality and if it is a character set, it is tested for\n"
3043 #define FUNC_NAME s_scm_string_filter
3045 size_t cstart
, cend
;
3049 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3053 /* The explicit loops below stripping leading and trailing non-matches
3054 mean we can return a substring if those are the only deletions, making
3055 string-filter as efficient as string-trim-both in that case. */
3057 if (SCM_CHARP (char_pred
))
3061 /* strip leading non-matches by incrementing cstart */
3062 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3065 /* strip trailing non-matches by decrementing cend */
3066 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3069 /* count chars to keep */
3071 for (idx
= cstart
; idx
< cend
; idx
++)
3072 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3075 if (count
== cend
- cstart
)
3077 /* whole of cstart to cend is to be kept, return a copy-on-write
3080 result
= scm_i_substring (s
, cstart
, cend
);
3083 result
= scm_c_make_string (count
, char_pred
);
3085 else if (SCM_CHARSETP (char_pred
))
3089 /* strip leading non-matches by incrementing cstart */
3090 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3093 /* strip trailing non-matches by decrementing cend */
3094 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3097 /* count chars to be kept */
3099 for (idx
= cstart
; idx
< cend
; idx
++)
3100 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3103 /* if whole of start to end kept then return substring */
3104 if (count
== cend
- cstart
)
3105 goto result_substring
;
3109 result
= scm_i_make_string (count
, NULL
);
3110 result
= scm_i_string_start_writing (result
);
3112 /* decrement "count" in this loop as well as using idx, so that if
3113 another thread is simultaneously changing "s" there's no chance
3114 it'll make us copy more than count characters */
3115 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3117 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3119 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3124 scm_i_string_stop_writing ();
3131 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3132 char_pred
, SCM_ARG2
, FUNC_NAME
);
3137 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3138 res
= scm_call_1 (char_pred
, ch
);
3139 if (scm_is_true (res
))
3140 ls
= scm_cons (ch
, ls
);
3143 result
= scm_reverse_list_to_string (ls
);
3146 scm_remember_upto_here_1 (s
);
3152 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3153 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3154 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3156 "If @var{char_pred} is a procedure, it is applied to each\n"
3157 "character as a predicate, if it is a character, it is tested\n"
3158 "for equality and if it is a character set, it is tested for\n"
3160 #define FUNC_NAME s_scm_string_delete
3162 size_t cstart
, cend
;
3166 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3170 /* The explicit loops below stripping leading and trailing matches mean we
3171 can return a substring if those are the only deletions, making
3172 string-delete as efficient as string-trim-both in that case. */
3174 if (SCM_CHARP (char_pred
))
3178 /* strip leading matches by incrementing cstart */
3179 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3182 /* strip trailing matches by decrementing cend */
3183 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3186 /* count chars to be kept */
3188 for (idx
= cstart
; idx
< cend
; idx
++)
3189 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3192 if (count
== cend
- cstart
)
3194 /* whole of cstart to cend is to be kept, return a copy-on-write
3197 result
= scm_i_substring (s
, cstart
, cend
);
3202 /* new string for retained portion */
3203 result
= scm_i_make_string (count
, NULL
);
3204 result
= scm_i_string_start_writing (result
);
3205 /* decrement "count" in this loop as well as using idx, so that if
3206 another thread is simultaneously changing "s" there's no chance
3207 it'll make us copy more than count characters */
3208 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3210 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3211 if (c
!= SCM_CHAR (char_pred
))
3213 scm_i_string_set_x (result
, i
, c
);
3218 scm_i_string_stop_writing ();
3221 else if (SCM_CHARSETP (char_pred
))
3225 /* strip leading matches by incrementing cstart */
3226 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3229 /* strip trailing matches by decrementing cend */
3230 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3233 /* count chars to be kept */
3235 for (idx
= cstart
; idx
< cend
; idx
++)
3236 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3239 if (count
== cend
- cstart
)
3240 goto result_substring
;
3244 /* new string for retained portion */
3245 result
= scm_i_make_string (count
, NULL
);
3246 result
= scm_i_string_start_writing (result
);
3248 /* decrement "count" in this loop as well as using idx, so that if
3249 another thread is simultaneously changing "s" there's no chance
3250 it'll make us copy more than count characters */
3251 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3253 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3255 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3260 scm_i_string_stop_writing ();
3266 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3267 char_pred
, SCM_ARG2
, FUNC_NAME
);
3272 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3273 res
= scm_call_1 (char_pred
, ch
);
3274 if (scm_is_false (res
))
3275 ls
= scm_cons (ch
, ls
);
3278 result
= scm_reverse_list_to_string (ls
);
3281 scm_remember_upto_here_1 (s
);
3287 scm_init_srfi_13 (void)
3289 #include "libguile/srfi-13.x"
3292 /* End of srfi-13.c. */