1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005 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
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful,
11 * but 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 02110-1301 USA
26 #include "libguile/srfi-13.h"
27 #include "libguile/srfi-14.h"
29 /* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
30 messing with the internal representation of strings. We define our
31 own version since we use it so much and are messing with Guile
35 #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 c_str = scm_i_string_chars (str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_VALIDATE_STRING (pos_str, str); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
56 "Return @code{#t} if @var{str}'s length is zero, and\n"
57 "@code{#f} otherwise.\n"
59 "(string-null? \"\") @result{} #t\n"
60 "y @result{} \"foo\"\n"
61 "(string-null? y) @result{} #f\n"
63 #define FUNC_NAME s_scm_string_null_p
65 SCM_VALIDATE_STRING (1, str
);
66 return scm_from_bool (scm_i_string_length (str
) == 0);
74 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
78 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
79 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
80 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
82 "@var{char_pred} can be a character to check for any equal to that, or\n"
83 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
84 "or a predicate procedure to call.\n"
86 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
87 "successively on the characters from @var{start} to @var{end}. If\n"
88 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
89 "stops and that return value is the return from @code{string-any}. The\n"
90 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
91 "point is reached, is a tail call.\n"
93 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
94 "@var{end}) then the return is @code{#f}.\n")
95 #define FUNC_NAME s_scm_string_any
101 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
105 if (SCM_CHARP (char_pred
))
107 res
= (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
109 ? SCM_BOOL_F
: SCM_BOOL_T
);
111 else if (SCM_CHARSETP (char_pred
))
114 for (i
= cstart
; i
< cend
; i
++)
115 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
123 SCM_VALIDATE_PROC (1, char_pred
);
125 while (cstart
< cend
)
127 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
128 if (scm_is_true (res
))
130 cstr
= scm_i_string_chars (s
);
135 scm_remember_upto_here_1 (s
);
141 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
142 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
143 "Check if @var{char_pred} is true for every character in string\n"
146 "@var{char_pred} can be a character to check for every character equal\n"
147 "to that, or a character set (@pxref{Character Sets}) to check for\n"
148 "every character being in that set, or a predicate procedure to call.\n"
150 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
151 "successively on the characters from @var{start} to @var{end}. If\n"
152 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
153 "returns @code{#f}. The call on the last character (ie.@: at\n"
154 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
155 "return from that call is the return from @code{string-every}.\n"
157 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
158 "@var{end}) then the return is @code{#t}.\n")
159 #define FUNC_NAME s_scm_string_every
163 SCM res
= SCM_BOOL_T
;
165 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
168 if (SCM_CHARP (char_pred
))
170 char cchr
= SCM_CHAR (char_pred
);
172 for (i
= cstart
; i
< cend
; i
++)
179 else if (SCM_CHARSETP (char_pred
))
182 for (i
= cstart
; i
< cend
; i
++)
183 if (!SCM_CHARSET_GET (char_pred
, cstr
[i
]))
191 SCM_VALIDATE_PROC (1, char_pred
);
193 while (cstart
< cend
)
195 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
196 if (scm_is_false (res
))
198 cstr
= scm_i_string_chars (s
);
203 scm_remember_upto_here_1 (s
);
209 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
211 "@var{proc} is an integer->char procedure. Construct a string\n"
212 "of size @var{len} by applying @var{proc} to each index to\n"
213 "produce the corresponding string element. The order in which\n"
214 "@var{proc} is applied to the indices is not specified.")
215 #define FUNC_NAME s_scm_string_tabulate
222 SCM_VALIDATE_PROC (1, proc
);
223 clen
= scm_to_size_t (len
);
224 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
226 res
= scm_i_make_string (clen
, &p
);
230 /* The RES string remains untouched since nobody knows about it
231 yet. No need to refetch P.
233 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
235 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
236 *p
++ = SCM_CHAR (ch
);
244 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
245 (SCM str
, SCM start
, SCM end
),
246 "Convert the string @var{str} into a list of characters.")
247 #define FUNC_NAME s_scm_substring_to_list
251 SCM result
= SCM_EOL
;
253 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
256 while (cstart
< cend
)
259 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
260 cstr
= scm_i_string_chars (str
);
262 scm_remember_upto_here_1 (str
);
267 /* We export scm_substring_to_list as "string->list" since it is
268 compatible and more general. This function remains for the benefit
269 of C code that used it.
273 scm_string_to_list (SCM str
)
275 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
278 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
280 "An efficient implementation of @code{(compose string->list\n"
284 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
286 #define FUNC_NAME s_scm_reverse_list_to_string
289 long i
= scm_ilength (chrs
);
293 SCM_WRONG_TYPE_ARG (1, chrs
);
294 result
= scm_i_make_string (i
, &data
);
299 while (i
> 0 && scm_is_pair (chrs
))
301 SCM elt
= SCM_CAR (chrs
);
303 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
305 *data
= SCM_CHAR (elt
);
306 chrs
= SCM_CDR (chrs
);
316 SCM_SYMBOL (scm_sym_infix
, "infix");
317 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
318 SCM_SYMBOL (scm_sym_suffix
, "suffix");
319 SCM_SYMBOL (scm_sym_prefix
, "prefix");
322 append_string (char **sp
, size_t *lp
, SCM str
)
325 len
= scm_c_string_length (str
);
328 memcpy (*sp
, scm_i_string_chars (str
), len
);
333 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
334 (SCM ls
, SCM delimiter
, SCM grammar
),
335 "Append the string in the string list @var{ls}, using the string\n"
336 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
337 "@var{grammar} is a symbol which specifies how the delimiter is\n"
338 "placed between the strings, and defaults to the symbol\n"
343 "Insert the separator between list elements. An empty string\n"
344 "will produce an empty list.\n"
345 "@item string-infix\n"
346 "Like @code{infix}, but will raise an error if given the empty\n"
349 "Insert the separator after every list element.\n"
351 "Insert the separator before each list element.\n"
353 #define FUNC_NAME s_scm_string_join
356 #define GRAM_STRICT_INFIX 1
357 #define GRAM_SUFFIX 2
358 #define GRAM_PREFIX 3
361 int gram
= GRAM_INFIX
;
365 long strings
= scm_ilength (ls
);
367 /* Validate the string list. */
369 SCM_WRONG_TYPE_ARG (1, ls
);
371 /* Validate the delimiter and record its length. */
372 if (SCM_UNBNDP (delimiter
))
374 delimiter
= scm_from_locale_string (" ");
378 del_len
= scm_c_string_length (delimiter
);
380 /* Validate the grammar symbol and remember the grammar. */
381 if (SCM_UNBNDP (grammar
))
383 else if (scm_is_eq (grammar
, scm_sym_infix
))
385 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
386 gram
= GRAM_STRICT_INFIX
;
387 else if (scm_is_eq (grammar
, scm_sym_suffix
))
389 else if (scm_is_eq (grammar
, scm_sym_prefix
))
392 SCM_WRONG_TYPE_ARG (3, grammar
);
394 /* Check grammar constraints and calculate the space required for
399 if (!scm_is_null (ls
))
400 len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
402 case GRAM_STRICT_INFIX
:
404 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
406 len
= (strings
- 1) * del_len
;
409 len
= strings
* del_len
;
414 while (scm_is_pair (tmp
))
416 len
+= scm_c_string_length (SCM_CAR (tmp
));
420 result
= scm_i_make_string (len
, &p
);
426 case GRAM_STRICT_INFIX
:
427 while (scm_is_pair (tmp
))
429 append_string (&p
, &len
, SCM_CAR (tmp
));
430 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
431 append_string (&p
, &len
, delimiter
);
436 while (scm_is_pair (tmp
))
438 append_string (&p
, &len
, SCM_CAR (tmp
));
440 append_string (&p
, &len
, delimiter
);
445 while (scm_is_pair (tmp
))
448 append_string (&p
, &len
, delimiter
);
449 append_string (&p
, &len
, SCM_CAR (tmp
));
457 #undef GRAM_STRICT_INFIX
464 /* There are a number of functions to consider here for Scheme and C:
466 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
467 substring/copy STR start [end] ;; Guile variant of R5RS substring
469 scm_string_copy (str) ;; Old function from Guile
470 scm_substring_copy (str, [start, [end]])
471 ;; C version of SRFI-13 string-copy
472 ;; and C version of substring/copy
474 The C function underlying string-copy is not exported to C
475 programs. scm_substring_copy is defined in strings.c as the
476 underlying function of substring/copy and allows an optional START
480 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
482 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
483 (SCM str
, SCM start
, SCM end
),
484 "Return a freshly allocated copy of the string @var{str}. If\n"
485 "given, @var{start} and @var{end} delimit the portion of\n"
486 "@var{str} which is copied.")
487 #define FUNC_NAME s_scm_srfi13_substring_copy
492 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
495 return scm_c_substring_copy (str
, cstart
, cend
);
500 scm_string_copy (SCM str
)
502 return scm_c_substring (str
, 0, scm_c_string_length (str
));
505 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
506 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
507 "Copy the sequence of characters from index range [@var{start},\n"
508 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
509 "at index @var{tstart}. The characters are copied left-to-right\n"
510 "or right-to-left as needed -- the copy is guaranteed to work,\n"
511 "even if @var{target} and @var{s} are the same string. It is an\n"
512 "error if the copy operation runs off the end of the target\n"
514 #define FUNC_NAME s_scm_string_copy_x
518 size_t cstart
, cend
, ctstart
, dummy
, len
;
519 SCM sdummy
= SCM_UNDEFINED
;
521 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
524 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
528 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
530 ctarget
= scm_i_string_writable_chars (target
);
531 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
532 scm_i_string_stop_writing ();
533 scm_remember_upto_here_1 (target
);
535 return SCM_UNSPECIFIED
;
539 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
540 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
541 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
542 "into @var{str2} beginning at position @var{start2}.\n"
543 "@var{str1} and @var{str2} can be the same string.")
544 #define FUNC_NAME s_scm_substring_move_x
546 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
550 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
552 "Return the @var{n} first characters of @var{s}.")
553 #define FUNC_NAME s_scm_string_take
555 return scm_substring (s
, SCM_INUM0
, n
);
560 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
562 "Return all but the first @var{n} characters of @var{s}.")
563 #define FUNC_NAME s_scm_string_drop
565 return scm_substring (s
, n
, SCM_UNDEFINED
);
570 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
572 "Return the @var{n} last characters of @var{s}.")
573 #define FUNC_NAME s_scm_string_take_right
575 return scm_substring (s
,
576 scm_difference (scm_string_length (s
), n
),
582 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
584 "Return all but the last @var{n} characters of @var{s}.")
585 #define FUNC_NAME s_scm_string_drop_right
587 return scm_substring (s
,
589 scm_difference (scm_string_length (s
), n
));
594 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
595 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
596 "Take that characters from @var{start} to @var{end} from the\n"
597 "string @var{s} and return a new string, right-padded by the\n"
598 "character @var{chr} to length @var{len}. If the resulting\n"
599 "string is longer than @var{len}, it is truncated on the right.")
600 #define FUNC_NAME s_scm_string_pad
603 size_t cstart
, cend
, clen
;
605 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
608 clen
= scm_to_size_t (len
);
610 if (SCM_UNBNDP (chr
))
614 SCM_VALIDATE_CHAR (3, chr
);
615 cchr
= SCM_CHAR (chr
);
617 if (clen
< (cend
- cstart
))
618 return scm_c_substring (s
, cend
- clen
, cend
);
624 result
= scm_i_make_string (clen
, &dst
);
625 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
626 memmove (dst
+ clen
- (cend
- cstart
),
627 scm_i_string_chars (s
) + cstart
, cend
- cstart
);
634 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
635 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
636 "Take that characters from @var{start} to @var{end} from the\n"
637 "string @var{s} and return a new string, left-padded by the\n"
638 "character @var{chr} to length @var{len}. If the resulting\n"
639 "string is longer than @var{len}, it is truncated on the left.")
640 #define FUNC_NAME s_scm_string_pad_right
643 size_t cstart
, cend
, clen
;
645 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
648 clen
= scm_to_size_t (len
);
650 if (SCM_UNBNDP (chr
))
654 SCM_VALIDATE_CHAR (3, chr
);
655 cchr
= SCM_CHAR (chr
);
657 if (clen
< (cend
- cstart
))
658 return scm_c_substring (s
, cstart
, cstart
+ clen
);
664 result
= scm_i_make_string (clen
, &dst
);
665 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
666 memmove (dst
, scm_i_string_chars (s
) + cstart
, cend
- cstart
);
673 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
674 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
675 "Trim @var{s} by skipping over all characters on the left\n"
676 "that satisfy the parameter @var{char_pred}:\n"
680 "if it is the character @var{ch}, characters equal to\n"
681 "@var{ch} are trimmed,\n"
684 "if it is a procedure @var{pred} characters that\n"
685 "satisfy @var{pred} are trimmed,\n"
688 "if it is a character set, characters in that set are trimmed.\n"
691 "If called without a @var{char_pred} argument, all whitespace is\n"
693 #define FUNC_NAME s_scm_string_trim
698 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
701 if (SCM_UNBNDP (char_pred
))
703 while (cstart
< cend
)
705 if (!isspace((int) (unsigned char) cstr
[cstart
]))
710 else if (SCM_CHARP (char_pred
))
712 char chr
= SCM_CHAR (char_pred
);
713 while (cstart
< cend
)
715 if (chr
!= cstr
[cstart
])
720 else if (SCM_CHARSETP (char_pred
))
722 while (cstart
< cend
)
724 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
731 SCM_VALIDATE_PROC (2, char_pred
);
732 while (cstart
< cend
)
736 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
737 if (scm_is_false (res
))
739 cstr
= scm_i_string_chars (s
);
743 return scm_c_substring (s
, cstart
, cend
);
748 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
749 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
750 "Trim @var{s} by skipping over all characters on the rightt\n"
751 "that satisfy the parameter @var{char_pred}:\n"
755 "if it is the character @var{ch}, characters equal to @var{ch}\n"
759 "if it is a procedure @var{pred} characters that satisfy\n"
760 "@var{pred} are trimmed,\n"
763 "if it is a character sets, all characters in that set are\n"
767 "If called without a @var{char_pred} argument, all whitespace is\n"
769 #define FUNC_NAME s_scm_string_trim_right
774 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
777 if (SCM_UNBNDP (char_pred
))
779 while (cstart
< cend
)
781 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
786 else if (SCM_CHARP (char_pred
))
788 char chr
= SCM_CHAR (char_pred
);
789 while (cstart
< cend
)
791 if (chr
!= cstr
[cend
- 1])
796 else if (SCM_CHARSETP (char_pred
))
798 while (cstart
< cend
)
800 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
807 SCM_VALIDATE_PROC (2, char_pred
);
808 while (cstart
< cend
)
812 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
813 if (scm_is_false (res
))
815 cstr
= scm_i_string_chars (s
);
819 return scm_c_substring (s
, cstart
, cend
);
824 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
825 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
826 "Trim @var{s} by skipping over all characters on both sides of\n"
827 "the string that satisfy the parameter @var{char_pred}:\n"
831 "if it is the character @var{ch}, characters equal to @var{ch}\n"
835 "if it is a procedure @var{pred} characters that satisfy\n"
836 "@var{pred} are trimmed,\n"
839 "if it is a character set, the characters in the set are\n"
843 "If called without a @var{char_pred} argument, all whitespace is\n"
845 #define FUNC_NAME s_scm_string_trim_both
850 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
853 if (SCM_UNBNDP (char_pred
))
855 while (cstart
< cend
)
857 if (!isspace((int) (unsigned char) cstr
[cstart
]))
861 while (cstart
< cend
)
863 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
868 else if (SCM_CHARP (char_pred
))
870 char chr
= SCM_CHAR (char_pred
);
871 while (cstart
< cend
)
873 if (chr
!= cstr
[cstart
])
877 while (cstart
< cend
)
879 if (chr
!= cstr
[cend
- 1])
884 else if (SCM_CHARSETP (char_pred
))
886 while (cstart
< cend
)
888 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
892 while (cstart
< cend
)
894 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
901 SCM_VALIDATE_PROC (2, char_pred
);
902 while (cstart
< cend
)
906 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
907 if (scm_is_false (res
))
909 cstr
= scm_i_string_chars (s
);
912 while (cstart
< cend
)
916 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
917 if (scm_is_false (res
))
919 cstr
= scm_i_string_chars (s
);
923 return scm_c_substring (s
, cstart
, cend
);
928 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
929 (SCM str
, SCM chr
, SCM start
, SCM end
),
930 "Stores @var{chr} in every element of the given @var{str} and\n"
931 "returns an unspecified value.")
932 #define FUNC_NAME s_scm_substring_fill_x
939 /* Older versions of Guile provided the function
940 scm_substring_fill_x with the following order of arguments:
944 We accomodate this here by detecting such a usage and reordering
955 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
958 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
960 cstr
= scm_i_string_writable_chars (str
);
961 for (k
= cstart
; k
< cend
; k
++)
963 scm_i_string_stop_writing ();
964 scm_remember_upto_here_1 (str
);
966 return SCM_UNSPECIFIED
;
971 scm_string_fill_x (SCM str
, SCM chr
)
973 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
976 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
977 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
978 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
979 "mismatch index, depending upon whether @var{s1} is less than,\n"
980 "equal to, or greater than @var{s2}. The mismatch index is the\n"
981 "largest index @var{i} such that for every 0 <= @var{j} <\n"
982 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
983 "@var{i} is the first position that does not match.")
984 #define FUNC_NAME s_scm_string_compare
986 const char *cstr1
, *cstr2
;
987 size_t cstart1
, cend1
, cstart2
, cend2
;
990 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
993 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
996 SCM_VALIDATE_PROC (3, proc_lt
);
997 SCM_VALIDATE_PROC (4, proc_eq
);
998 SCM_VALIDATE_PROC (5, proc_gt
);
1000 while (cstart1
< cend1
&& cstart2
< cend2
)
1002 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1007 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1015 if (cstart1
< cend1
)
1017 else if (cstart2
< cend2
)
1023 scm_remember_upto_here_2 (s1
, s2
);
1024 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1029 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1030 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1031 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1032 "mismatch index, depending upon whether @var{s1} is less than,\n"
1033 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1034 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1035 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1036 "@var{i} is the first position that does not match. The\n"
1037 "character comparison is done case-insensitively.")
1038 #define FUNC_NAME s_scm_string_compare_ci
1040 const char *cstr1
, *cstr2
;
1041 size_t cstart1
, cend1
, cstart2
, cend2
;
1044 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1047 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1050 SCM_VALIDATE_PROC (3, proc_lt
);
1051 SCM_VALIDATE_PROC (4, proc_eq
);
1052 SCM_VALIDATE_PROC (5, proc_gt
);
1054 while (cstart1
< cend1
&& cstart2
< cend2
)
1056 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1061 else if (scm_c_downcase (cstr1
[cstart1
])
1062 > scm_c_downcase (cstr2
[cstart2
]))
1071 if (cstart1
< cend1
)
1073 else if (cstart2
< cend2
)
1079 scm_remember_upto_here (s1
, s2
);
1080 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1085 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1086 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1087 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1089 #define FUNC_NAME s_scm_string_eq
1091 const char *cstr1
, *cstr2
;
1092 size_t cstart1
, cend1
, cstart2
, cend2
;
1094 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1097 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1101 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1104 while (cstart1
< cend1
)
1106 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1108 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1114 scm_remember_upto_here_2 (s1
, s2
);
1115 return scm_from_size_t (cstart1
);
1118 scm_remember_upto_here_2 (s1
, s2
);
1124 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1125 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1126 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1128 #define FUNC_NAME s_scm_string_neq
1130 const char *cstr1
, *cstr2
;
1131 size_t cstart1
, cend1
, cstart2
, cend2
;
1133 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1136 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1140 while (cstart1
< cend1
&& cstart2
< cend2
)
1142 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1144 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1149 if (cstart1
< cend1
)
1151 else if (cstart2
< cend2
)
1157 scm_remember_upto_here_2 (s1
, s2
);
1158 return scm_from_size_t (cstart1
);
1161 scm_remember_upto_here_2 (s1
, s2
);
1167 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1168 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1169 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1170 "true value otherwise.")
1171 #define FUNC_NAME s_scm_string_lt
1173 const char *cstr1
, *cstr2
;
1174 size_t cstart1
, cend1
, cstart2
, cend2
;
1176 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1179 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1183 while (cstart1
< cend1
&& cstart2
< cend2
)
1185 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1187 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1192 if (cstart1
< cend1
)
1194 else if (cstart2
< cend2
)
1200 scm_remember_upto_here_2 (s1
, s2
);
1201 return scm_from_size_t (cstart1
);
1204 scm_remember_upto_here_2 (s1
, s2
);
1210 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1211 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1212 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1213 "true value otherwise.")
1214 #define FUNC_NAME s_scm_string_gt
1216 const char *cstr1
, *cstr2
;
1217 size_t cstart1
, cend1
, cstart2
, cend2
;
1219 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1222 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1226 while (cstart1
< cend1
&& cstart2
< cend2
)
1228 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1230 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1235 if (cstart1
< cend1
)
1237 else if (cstart2
< cend2
)
1243 scm_remember_upto_here_2 (s1
, s2
);
1244 return scm_from_size_t (cstart1
);
1247 scm_remember_upto_here_2 (s1
, s2
);
1253 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1254 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1255 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1257 #define FUNC_NAME s_scm_string_le
1259 const char *cstr1
, *cstr2
;
1260 size_t cstart1
, cend1
, cstart2
, cend2
;
1262 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1265 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1269 while (cstart1
< cend1
&& cstart2
< cend2
)
1271 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1273 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1278 if (cstart1
< cend1
)
1280 else if (cstart2
< cend2
)
1286 scm_remember_upto_here_2 (s1
, s2
);
1287 return scm_from_size_t (cstart1
);
1290 scm_remember_upto_here_2 (s1
, s2
);
1296 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1297 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1298 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1300 #define FUNC_NAME s_scm_string_ge
1302 const char *cstr1
, *cstr2
;
1303 size_t cstart1
, cend1
, cstart2
, cend2
;
1305 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1308 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1312 while (cstart1
< cend1
&& cstart2
< cend2
)
1314 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1316 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1321 if (cstart1
< cend1
)
1323 else if (cstart2
< cend2
)
1329 scm_remember_upto_here_2 (s1
, s2
);
1330 return scm_from_size_t (cstart1
);
1333 scm_remember_upto_here_2 (s1
, s2
);
1339 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1340 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1341 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1342 "value otherwise. The character comparison is done\n"
1343 "case-insensitively.")
1344 #define FUNC_NAME s_scm_string_ci_eq
1346 const char *cstr1
, *cstr2
;
1347 size_t cstart1
, cend1
, cstart2
, cend2
;
1349 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1352 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1356 while (cstart1
< cend1
&& cstart2
< cend2
)
1358 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1360 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1365 if (cstart1
< cend1
)
1367 else if (cstart2
< cend2
)
1373 scm_remember_upto_here_2 (s1
, s2
);
1374 return scm_from_size_t (cstart1
);
1377 scm_remember_upto_here_2 (s1
, s2
);
1383 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1384 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1385 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1386 "value otherwise. The character comparison is done\n"
1387 "case-insensitively.")
1388 #define FUNC_NAME s_scm_string_ci_neq
1390 const char *cstr1
, *cstr2
;
1391 size_t cstart1
, cend1
, cstart2
, cend2
;
1393 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1396 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1400 while (cstart1
< cend1
&& cstart2
< cend2
)
1402 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1404 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1409 if (cstart1
< cend1
)
1411 else if (cstart2
< cend2
)
1417 scm_remember_upto_here_2 (s1
, s2
);
1418 return scm_from_size_t (cstart1
);
1421 scm_remember_upto_here_2 (s1
, s2
);
1427 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1428 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1429 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1430 "true value otherwise. The character comparison is done\n"
1431 "case-insensitively.")
1432 #define FUNC_NAME s_scm_string_ci_lt
1434 const char *cstr1
, *cstr2
;
1435 size_t cstart1
, cend1
, cstart2
, cend2
;
1437 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1440 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1444 while (cstart1
< cend1
&& cstart2
< cend2
)
1446 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1448 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1453 if (cstart1
< cend1
)
1455 else if (cstart2
< cend2
)
1461 scm_remember_upto_here_2 (s1
, s2
);
1462 return scm_from_size_t (cstart1
);
1465 scm_remember_upto_here_2 (s1
, s2
);
1471 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1472 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1473 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1474 "true value otherwise. The character comparison is done\n"
1475 "case-insensitively.")
1476 #define FUNC_NAME s_scm_string_ci_gt
1478 const char *cstr1
, *cstr2
;
1479 size_t cstart1
, cend1
, cstart2
, cend2
;
1481 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1484 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1488 while (cstart1
< cend1
&& cstart2
< cend2
)
1490 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1492 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1497 if (cstart1
< cend1
)
1499 else if (cstart2
< cend2
)
1505 scm_remember_upto_here_2 (s1
, s2
);
1506 return scm_from_size_t (cstart1
);
1509 scm_remember_upto_here_2 (s1
, s2
);
1515 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1516 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1517 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1518 "value otherwise. The character comparison is done\n"
1519 "case-insensitively.")
1520 #define FUNC_NAME s_scm_string_ci_le
1522 const char *cstr1
, *cstr2
;
1523 size_t cstart1
, cend1
, cstart2
, cend2
;
1525 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1528 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1532 while (cstart1
< cend1
&& cstart2
< cend2
)
1534 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1536 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1541 if (cstart1
< cend1
)
1543 else if (cstart2
< cend2
)
1549 scm_remember_upto_here_2 (s1
, s2
);
1550 return scm_from_size_t (cstart1
);
1553 scm_remember_upto_here_2 (s1
, s2
);
1559 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1560 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1561 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1562 "otherwise. The character comparison is done\n"
1563 "case-insensitively.")
1564 #define FUNC_NAME s_scm_string_ci_ge
1566 const char *cstr1
, *cstr2
;
1567 size_t cstart1
, cend1
, cstart2
, cend2
;
1569 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1572 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1576 while (cstart1
< cend1
&& cstart2
< cend2
)
1578 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1580 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1585 if (cstart1
< cend1
)
1587 else if (cstart2
< cend2
)
1593 scm_remember_upto_here_2 (s1
, s2
);
1594 return scm_from_size_t (cstart1
);
1597 scm_remember_upto_here_2 (s1
, s2
);
1602 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1603 (SCM s
, SCM bound
, SCM start
, SCM end
),
1604 "Compute a hash value for @var{S}. the optional argument "
1605 "@var{bound} is a non-negative exact "
1606 "integer specifying the range of the hash function. "
1607 "A positive value restricts the return value to the "
1609 #define FUNC_NAME s_scm_substring_hash
1611 if (SCM_UNBNDP (bound
))
1612 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1613 if (SCM_UNBNDP (start
))
1615 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1619 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1620 (SCM s
, SCM bound
, SCM start
, SCM end
),
1621 "Compute a hash value for @var{S}. the optional argument "
1622 "@var{bound} is a non-negative exact "
1623 "integer specifying the range of the hash function. "
1624 "A positive value restricts the return value to the "
1626 #define FUNC_NAME s_scm_substring_hash_ci
1628 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1630 SCM_UNDEFINED
, SCM_UNDEFINED
);
1634 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1635 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1636 "Return the length of the longest common prefix of the two\n"
1638 #define FUNC_NAME s_scm_string_prefix_length
1640 const char *cstr1
, *cstr2
;
1641 size_t cstart1
, cend1
, cstart2
, cend2
;
1644 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1647 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1650 while (cstart1
< cend1
&& cstart2
< cend2
)
1652 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1660 scm_remember_upto_here_2 (s1
, s2
);
1661 return scm_from_size_t (len
);
1666 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1667 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1668 "Return the length of the longest common prefix of the two\n"
1669 "strings, ignoring character case.")
1670 #define FUNC_NAME s_scm_string_prefix_length_ci
1672 const char *cstr1
, *cstr2
;
1673 size_t cstart1
, cend1
, cstart2
, cend2
;
1676 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1679 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1682 while (cstart1
< cend1
&& cstart2
< cend2
)
1684 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1692 scm_remember_upto_here_2 (s1
, s2
);
1693 return scm_from_size_t (len
);
1698 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1699 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1700 "Return the length of the longest common suffix of the two\n"
1702 #define FUNC_NAME s_scm_string_suffix_length
1704 const char *cstr1
, *cstr2
;
1705 size_t cstart1
, cend1
, cstart2
, cend2
;
1708 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1711 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1714 while (cstart1
< cend1
&& cstart2
< cend2
)
1718 if (cstr1
[cend1
] != cstr2
[cend2
])
1724 scm_remember_upto_here_2 (s1
, s2
);
1725 return scm_from_size_t (len
);
1730 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1731 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1732 "Return the length of the longest common suffix of the two\n"
1733 "strings, ignoring character case.")
1734 #define FUNC_NAME s_scm_string_suffix_length_ci
1736 const char *cstr1
, *cstr2
;
1737 size_t cstart1
, cend1
, cstart2
, cend2
;
1740 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1743 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1746 while (cstart1
< cend1
&& cstart2
< cend2
)
1750 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1756 scm_remember_upto_here_2 (s1
, s2
);
1757 return scm_from_size_t (len
);
1762 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1763 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1764 "Is @var{s1} a prefix of @var{s2}?")
1765 #define FUNC_NAME s_scm_string_prefix_p
1767 const char *cstr1
, *cstr2
;
1768 size_t cstart1
, cend1
, cstart2
, cend2
;
1769 size_t len
= 0, len1
;
1771 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1774 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1777 len1
= cend1
- cstart1
;
1778 while (cstart1
< cend1
&& cstart2
< cend2
)
1780 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1788 scm_remember_upto_here_2 (s1
, s2
);
1789 return scm_from_bool (len
== len1
);
1794 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1795 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1796 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1797 #define FUNC_NAME s_scm_string_prefix_ci_p
1799 const char *cstr1
, *cstr2
;
1800 size_t cstart1
, cend1
, cstart2
, cend2
;
1801 size_t len
= 0, len1
;
1803 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1806 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1809 len1
= cend1
- cstart1
;
1810 while (cstart1
< cend1
&& cstart2
< cend2
)
1812 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1820 scm_remember_upto_here_2 (s1
, s2
);
1821 return scm_from_bool (len
== len1
);
1826 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1827 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1828 "Is @var{s1} a suffix of @var{s2}?")
1829 #define FUNC_NAME s_scm_string_suffix_p
1831 const char *cstr1
, *cstr2
;
1832 size_t cstart1
, cend1
, cstart2
, cend2
;
1833 size_t len
= 0, len1
;
1835 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1838 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1841 len1
= cend1
- cstart1
;
1842 while (cstart1
< cend1
&& cstart2
< cend2
)
1846 if (cstr1
[cend1
] != cstr2
[cend2
])
1852 scm_remember_upto_here_2 (s1
, s2
);
1853 return scm_from_bool (len
== len1
);
1858 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1859 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1860 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1861 #define FUNC_NAME s_scm_string_suffix_ci_p
1863 const char *cstr1
, *cstr2
;
1864 size_t cstart1
, cend1
, cstart2
, cend2
;
1865 size_t len
= 0, len1
;
1867 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1870 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1873 len1
= cend1
- cstart1
;
1874 while (cstart1
< cend1
&& cstart2
< cend2
)
1878 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1884 scm_remember_upto_here_2 (s1
, s2
);
1885 return scm_from_bool (len
== len1
);
1890 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1891 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1892 "Search through the string @var{s} from left to right, returning\n"
1893 "the index of the first occurence of a character which\n"
1895 "@itemize @bullet\n"
1897 "equals @var{char_pred}, if it is character,\n"
1900 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1903 "is in the set @var{char_pred}, if it is a character set.\n"
1905 #define FUNC_NAME s_scm_string_index
1908 size_t cstart
, cend
;
1910 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1913 if (SCM_CHARP (char_pred
))
1915 char cchr
= SCM_CHAR (char_pred
);
1916 while (cstart
< cend
)
1918 if (cchr
== cstr
[cstart
])
1923 else if (SCM_CHARSETP (char_pred
))
1925 while (cstart
< cend
)
1927 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1934 SCM_VALIDATE_PROC (2, char_pred
);
1935 while (cstart
< cend
)
1938 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1939 if (scm_is_true (res
))
1941 cstr
= scm_i_string_chars (s
);
1946 scm_remember_upto_here_1 (s
);
1950 scm_remember_upto_here_1 (s
);
1951 return scm_from_size_t (cstart
);
1955 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1956 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1957 "Search through the string @var{s} from right to left, returning\n"
1958 "the index of the last occurence of a character which\n"
1960 "@itemize @bullet\n"
1962 "equals @var{char_pred}, if it is character,\n"
1965 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1968 "is in the set if @var{char_pred} is a character set.\n"
1970 #define FUNC_NAME s_scm_string_index_right
1973 size_t cstart
, cend
;
1975 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1978 if (SCM_CHARP (char_pred
))
1980 char cchr
= SCM_CHAR (char_pred
);
1981 while (cstart
< cend
)
1984 if (cchr
== cstr
[cend
])
1988 else if (SCM_CHARSETP (char_pred
))
1990 while (cstart
< cend
)
1993 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1999 SCM_VALIDATE_PROC (2, char_pred
);
2000 while (cstart
< cend
)
2004 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2005 if (scm_is_true (res
))
2007 cstr
= scm_i_string_chars (s
);
2011 scm_remember_upto_here_1 (s
);
2015 scm_remember_upto_here_1 (s
);
2016 return scm_from_size_t (cend
);
2020 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
2021 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2022 "Search through the string @var{s} from right to left, returning\n"
2023 "the index of the last occurence of a character which\n"
2025 "@itemize @bullet\n"
2027 "equals @var{char_pred}, if it is character,\n"
2030 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2033 "is in the set if @var{char_pred} is a character set.\n"
2035 #define FUNC_NAME s_scm_string_rindex
2037 return scm_string_index_right (s
, char_pred
, start
, end
);
2041 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
2042 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2043 "Search through the string @var{s} from left to right, returning\n"
2044 "the index of the first occurence of a character which\n"
2046 "@itemize @bullet\n"
2048 "does not equal @var{char_pred}, if it is character,\n"
2051 "does not satisify the predicate @var{char_pred}, if it is a\n"
2055 "is not in the set if @var{char_pred} is a character set.\n"
2057 #define FUNC_NAME s_scm_string_skip
2060 size_t cstart
, cend
;
2062 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2065 if (SCM_CHARP (char_pred
))
2067 char cchr
= SCM_CHAR (char_pred
);
2068 while (cstart
< cend
)
2070 if (cchr
!= cstr
[cstart
])
2075 else if (SCM_CHARSETP (char_pred
))
2077 while (cstart
< cend
)
2079 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2086 SCM_VALIDATE_PROC (2, char_pred
);
2087 while (cstart
< cend
)
2090 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2091 if (scm_is_false (res
))
2093 cstr
= scm_i_string_chars (s
);
2098 scm_remember_upto_here_1 (s
);
2102 scm_remember_upto_here_1 (s
);
2103 return scm_from_size_t (cstart
);
2108 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2109 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2110 "Search through the string @var{s} from right to left, returning\n"
2111 "the index of the last occurence of a character which\n"
2113 "@itemize @bullet\n"
2115 "does not equal @var{char_pred}, if it is character,\n"
2118 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2122 "is not in the set if @var{char_pred} is a character set.\n"
2124 #define FUNC_NAME s_scm_string_skip_right
2127 size_t cstart
, cend
;
2129 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2132 if (SCM_CHARP (char_pred
))
2134 char cchr
= SCM_CHAR (char_pred
);
2135 while (cstart
< cend
)
2138 if (cchr
!= cstr
[cend
])
2142 else if (SCM_CHARSETP (char_pred
))
2144 while (cstart
< cend
)
2147 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2153 SCM_VALIDATE_PROC (2, char_pred
);
2154 while (cstart
< cend
)
2158 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2159 if (scm_is_false (res
))
2161 cstr
= scm_i_string_chars (s
);
2165 scm_remember_upto_here_1 (s
);
2169 scm_remember_upto_here_1 (s
);
2170 return scm_from_size_t (cend
);
2176 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2177 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2178 "Return the count of the number of characters in the string\n"
2181 "@itemize @bullet\n"
2183 "equals @var{char_pred}, if it is character,\n"
2186 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2189 "is in the set @var{char_pred}, if it is a character set.\n"
2191 #define FUNC_NAME s_scm_string_count
2194 size_t cstart
, cend
;
2197 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2200 if (SCM_CHARP (char_pred
))
2202 char cchr
= SCM_CHAR (char_pred
);
2203 while (cstart
< cend
)
2205 if (cchr
== cstr
[cstart
])
2210 else if (SCM_CHARSETP (char_pred
))
2212 while (cstart
< cend
)
2214 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2221 SCM_VALIDATE_PROC (2, char_pred
);
2222 while (cstart
< cend
)
2225 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2226 if (scm_is_true (res
))
2228 cstr
= scm_i_string_chars (s
);
2233 scm_remember_upto_here_1 (s
);
2234 return scm_from_size_t (count
);
2239 /* FIXME::martin: This should definitely get implemented more
2240 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2242 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2243 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2244 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2245 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2246 "The optional start/end indices restrict the operation to the\n"
2247 "indicated substrings.")
2248 #define FUNC_NAME s_scm_string_contains
2250 const char *cs1
, * cs2
;
2251 size_t cstart1
, cend1
, cstart2
, cend2
;
2254 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2257 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2260 len2
= cend2
- cstart2
;
2261 if (cend1
- cstart1
>= len2
)
2262 while (cstart1
<= cend1
- len2
)
2266 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2273 scm_remember_upto_here_2 (s1
, s2
);
2274 return scm_from_size_t (cstart1
);
2279 scm_remember_upto_here_2 (s1
, s2
);
2285 /* FIXME::martin: This should definitely get implemented more
2286 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2288 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2289 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2290 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2291 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2292 "The optional start/end indices restrict the operation to the\n"
2293 "indicated substrings. Character comparison is done\n"
2294 "case-insensitively.")
2295 #define FUNC_NAME s_scm_string_contains_ci
2297 const char *cs1
, * cs2
;
2298 size_t cstart1
, cend1
, cstart2
, cend2
;
2301 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2304 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2307 len2
= cend2
- cstart2
;
2308 if (cend1
- cstart1
>= len2
)
2309 while (cstart1
<= cend1
- len2
)
2313 while (i
< cend1
&& j
< cend2
&&
2314 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2321 scm_remember_upto_here_2 (s1
, s2
);
2322 return scm_from_size_t (cstart1
);
2327 scm_remember_upto_here_2 (s1
, s2
);
2333 /* Helper function for the string uppercase conversion functions.
2334 * No argument checking is performed. */
2336 string_upcase_x (SCM v
, size_t start
, size_t end
)
2341 dst
= scm_i_string_writable_chars (v
);
2342 for (k
= start
; k
< end
; ++k
)
2343 dst
[k
] = scm_c_upcase (dst
[k
]);
2344 scm_i_string_stop_writing ();
2345 scm_remember_upto_here_1 (v
);
2350 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2351 (SCM str
, SCM start
, SCM end
),
2352 "Destructively upcase every character in @code{str}.\n"
2355 "(string-upcase! y)\n"
2356 "@result{} \"ARRDEFG\"\n"
2358 "@result{} \"ARRDEFG\"\n"
2360 #define FUNC_NAME s_scm_substring_upcase_x
2363 size_t cstart
, cend
;
2365 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2368 return string_upcase_x (str
, cstart
, cend
);
2373 scm_string_upcase_x (SCM str
)
2375 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2378 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2379 (SCM str
, SCM start
, SCM end
),
2380 "Upcase every character in @code{str}.")
2381 #define FUNC_NAME s_scm_substring_upcase
2384 size_t cstart
, cend
;
2386 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2389 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2394 scm_string_upcase (SCM str
)
2396 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2399 /* Helper function for the string lowercase conversion functions.
2400 * No argument checking is performed. */
2402 string_downcase_x (SCM v
, size_t start
, size_t end
)
2407 dst
= scm_i_string_writable_chars (v
);
2408 for (k
= start
; k
< end
; ++k
)
2409 dst
[k
] = scm_c_downcase (dst
[k
]);
2410 scm_i_string_stop_writing ();
2411 scm_remember_upto_here_1 (v
);
2416 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2417 (SCM str
, SCM start
, SCM end
),
2418 "Destructively downcase every character in @var{str}.\n"
2422 "@result{} \"ARRDEFG\"\n"
2423 "(string-downcase! y)\n"
2424 "@result{} \"arrdefg\"\n"
2426 "@result{} \"arrdefg\"\n"
2428 #define FUNC_NAME s_scm_substring_downcase_x
2431 size_t cstart
, cend
;
2433 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2436 return string_downcase_x (str
, cstart
, cend
);
2441 scm_string_downcase_x (SCM str
)
2443 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2446 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2447 (SCM str
, SCM start
, SCM end
),
2448 "Downcase every character in @var{str}.")
2449 #define FUNC_NAME s_scm_substring_downcase
2452 size_t cstart
, cend
;
2454 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2457 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2462 scm_string_downcase (SCM str
)
2464 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2467 /* Helper function for the string capitalization functions.
2468 * No argument checking is performed. */
2470 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2476 sz
= (unsigned char *) scm_i_string_writable_chars (str
);
2477 for(i
= start
; i
< end
; i
++)
2479 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2483 sz
[i
] = scm_c_upcase(sz
[i
]);
2488 sz
[i
] = scm_c_downcase(sz
[i
]);
2494 scm_i_string_stop_writing ();
2495 scm_remember_upto_here_1 (str
);
2501 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2502 (SCM str
, SCM start
, SCM end
),
2503 "Destructively titlecase every first character in a word in\n"
2505 #define FUNC_NAME s_scm_string_titlecase_x
2508 size_t cstart
, cend
;
2510 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2513 return string_titlecase_x (str
, cstart
, cend
);
2518 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2519 (SCM str
, SCM start
, SCM end
),
2520 "Titlecase every first character in a word in @var{str}.")
2521 #define FUNC_NAME s_scm_string_titlecase
2524 size_t cstart
, cend
;
2526 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2529 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2533 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2535 "Upcase the first character of every word in @var{str}\n"
2536 "destructively and return @var{str}.\n"
2539 "y @result{} \"hello world\"\n"
2540 "(string-capitalize! y) @result{} \"Hello World\"\n"
2541 "y @result{} \"Hello World\"\n"
2543 #define FUNC_NAME s_scm_string_capitalize_x
2545 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2550 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2552 "Return a freshly allocated string with the characters in\n"
2553 "@var{str}, where the first character of every word is\n"
2555 #define FUNC_NAME s_scm_string_capitalize
2557 return scm_string_capitalize_x (scm_string_copy (str
));
2562 /* Reverse the portion of @var{str} between str[cstart] (including)
2563 and str[cend] excluding. */
2565 string_reverse_x (char * str
, size_t cstart
, size_t cend
)
2572 while (cstart
< cend
)
2575 str
[cstart
] = str
[cend
];
2584 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2585 (SCM str
, SCM start
, SCM end
),
2586 "Reverse the string @var{str}. The optional arguments\n"
2587 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2589 #define FUNC_NAME s_scm_string_reverse
2593 size_t cstart
, cend
;
2596 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2599 result
= scm_string_copy (str
);
2600 ctarget
= scm_i_string_writable_chars (result
);
2601 string_reverse_x (ctarget
, cstart
, cend
);
2602 scm_i_string_stop_writing ();
2603 scm_remember_upto_here_1 (str
);
2609 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2610 (SCM str
, SCM start
, SCM end
),
2611 "Reverse the string @var{str} in-place. The optional arguments\n"
2612 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2613 "operate on. The return value is unspecified.")
2614 #define FUNC_NAME s_scm_string_reverse_x
2617 size_t cstart
, cend
;
2619 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2623 cstr
= scm_i_string_writable_chars (str
);
2624 string_reverse_x (cstr
, cstart
, cend
);
2625 scm_i_string_stop_writing ();
2626 scm_remember_upto_here_1 (str
);
2627 return SCM_UNSPECIFIED
;
2632 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2634 "Like @code{string-append}, but the result may share memory\n"
2635 "with the argument strings.")
2636 #define FUNC_NAME s_scm_string_append_shared
2640 SCM_VALIDATE_REST_ARGUMENT (ls
);
2642 /* Optimize the one-argument case. */
2643 i
= scm_ilength (ls
);
2645 return SCM_CAR (ls
);
2647 return scm_string_append (ls
);
2652 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2654 "Append the elements of @var{ls} (which must be strings)\n"
2655 "together into a single string. Guaranteed to return a freshly\n"
2656 "allocated string.")
2657 #define FUNC_NAME s_scm_string_concatenate
2659 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2660 return scm_string_append (ls
);
2665 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2666 (SCM ls
, SCM final_string
, SCM end
),
2667 "Without optional arguments, this procedure is equivalent to\n"
2670 "(string-concatenate (reverse ls))\n"
2673 "If the optional argument @var{final_string} is specified, it is\n"
2674 "consed onto the beginning to @var{ls} before performing the\n"
2675 "list-reverse and string-concatenate operations. If @var{end}\n"
2676 "is given, only the characters of @var{final_string} up to index\n"
2677 "@var{end} are used.\n"
2679 "Guaranteed to return a freshly allocated string.")
2680 #define FUNC_NAME s_scm_string_concatenate_reverse
2682 if (!SCM_UNBNDP (end
))
2683 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2685 if (!SCM_UNBNDP (final_string
))
2686 ls
= scm_cons (final_string
, ls
);
2688 return scm_string_concatenate (scm_reverse (ls
));
2693 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2695 "Like @code{string-concatenate}, but the result may share memory\n"
2696 "with the strings in the list @var{ls}.")
2697 #define FUNC_NAME s_scm_string_concatenate_shared
2699 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2700 return scm_string_append_shared (ls
);
2705 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2706 (SCM ls
, SCM final_string
, SCM end
),
2707 "Like @code{string-concatenate-reverse}, but the result may\n"
2708 "share memory with the the strings in the @var{ls} arguments.")
2709 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2711 /* Just call the non-sharing version. */
2712 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2717 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2718 (SCM proc
, SCM s
, SCM start
, SCM end
),
2719 "@var{proc} is a char->char procedure, it is mapped over\n"
2720 "@var{s}. The order in which the procedure is applied to the\n"
2721 "string elements is not specified.")
2722 #define FUNC_NAME s_scm_string_map
2725 size_t cstart
, cend
;
2728 SCM_VALIDATE_PROC (1, proc
);
2729 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2732 result
= scm_i_make_string (cend
- cstart
, &p
);
2733 while (cstart
< cend
)
2735 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2736 if (!SCM_CHARP (ch
))
2737 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2739 *p
++ = SCM_CHAR (ch
);
2746 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2747 (SCM proc
, SCM s
, SCM start
, SCM end
),
2748 "@var{proc} is a char->char procedure, it is mapped over\n"
2749 "@var{s}. The order in which the procedure is applied to the\n"
2750 "string elements is not specified. The string @var{s} is\n"
2751 "modified in-place, the return value is not specified.")
2752 #define FUNC_NAME s_scm_string_map_x
2754 size_t cstart
, cend
;
2756 SCM_VALIDATE_PROC (1, proc
);
2757 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2760 while (cstart
< cend
)
2762 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2763 if (!SCM_CHARP (ch
))
2764 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2765 scm_c_string_set_x (s
, cstart
, ch
);
2768 return SCM_UNSPECIFIED
;
2773 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2774 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2775 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2776 "as the terminating element, from left to right. @var{kons}\n"
2777 "must expect two arguments: The actual character and the last\n"
2778 "result of @var{kons}' application.")
2779 #define FUNC_NAME s_scm_string_fold
2782 size_t cstart
, cend
;
2785 SCM_VALIDATE_PROC (1, kons
);
2786 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2790 while (cstart
< cend
)
2792 unsigned int c
= (unsigned char) cstr
[cstart
];
2793 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2794 cstr
= scm_i_string_chars (s
);
2798 scm_remember_upto_here_1 (s
);
2804 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2805 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2806 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2807 "as the terminating element, from right to left. @var{kons}\n"
2808 "must expect two arguments: The actual character and the last\n"
2809 "result of @var{kons}' application.")
2810 #define FUNC_NAME s_scm_string_fold_right
2813 size_t cstart
, cend
;
2816 SCM_VALIDATE_PROC (1, kons
);
2817 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2821 while (cstart
< cend
)
2823 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2824 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2825 cstr
= scm_i_string_chars (s
);
2829 scm_remember_upto_here_1 (s
);
2835 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2836 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2837 "@itemize @bullet\n"
2838 "@item @var{g} is used to generate a series of @emph{seed}\n"
2839 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2840 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2842 "@item @var{p} tells us when to stop -- when it returns true\n"
2843 "when applied to one of these seed values.\n"
2844 "@item @var{f} maps each seed value to the corresponding\n"
2845 "character in the result string. These chars are assembled\n"
2846 "into the string in a left-to-right order.\n"
2847 "@item @var{base} is the optional initial/leftmost portion\n"
2848 "of the constructed string; it default to the empty\n"
2850 "@item @var{make_final} is applied to the terminal seed\n"
2851 "value (on which @var{p} returns true) to produce\n"
2852 "the final/rightmost portion of the constructed string.\n"
2853 "It defaults to @code{(lambda (x) "")}.\n"
2855 #define FUNC_NAME s_scm_string_unfold
2859 SCM_VALIDATE_PROC (1, p
);
2860 SCM_VALIDATE_PROC (2, f
);
2861 SCM_VALIDATE_PROC (3, g
);
2862 if (!SCM_UNBNDP (base
))
2864 SCM_VALIDATE_STRING (5, base
);
2868 ans
= scm_i_make_string (0, NULL
);
2869 if (!SCM_UNBNDP (make_final
))
2870 SCM_VALIDATE_PROC (6, make_final
);
2872 res
= scm_call_1 (p
, seed
);
2873 while (scm_is_false (res
))
2877 SCM ch
= scm_call_1 (f
, seed
);
2878 if (!SCM_CHARP (ch
))
2879 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2880 str
= scm_i_make_string (1, &ptr
);
2881 *ptr
= SCM_CHAR (ch
);
2883 ans
= scm_string_append (scm_list_2 (ans
, str
));
2884 seed
= scm_call_1 (g
, seed
);
2885 res
= scm_call_1 (p
, seed
);
2887 if (!SCM_UNBNDP (make_final
))
2889 res
= scm_call_1 (make_final
, seed
);
2890 return scm_string_append (scm_list_2 (ans
, res
));
2898 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2899 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2900 "@itemize @bullet\n"
2901 "@item @var{g} is used to generate a series of @emph{seed}\n"
2902 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2903 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2905 "@item @var{p} tells us when to stop -- when it returns true\n"
2906 "when applied to one of these seed values.\n"
2907 "@item @var{f} maps each seed value to the corresponding\n"
2908 "character in the result string. These chars are assembled\n"
2909 "into the string in a right-to-left order.\n"
2910 "@item @var{base} is the optional initial/rightmost portion\n"
2911 "of the constructed string; it default to the empty\n"
2913 "@item @var{make_final} is applied to the terminal seed\n"
2914 "value (on which @var{p} returns true) to produce\n"
2915 "the final/leftmost portion of the constructed string.\n"
2916 "It defaults to @code{(lambda (x) "")}.\n"
2918 #define FUNC_NAME s_scm_string_unfold_right
2922 SCM_VALIDATE_PROC (1, p
);
2923 SCM_VALIDATE_PROC (2, f
);
2924 SCM_VALIDATE_PROC (3, g
);
2925 if (!SCM_UNBNDP (base
))
2927 SCM_VALIDATE_STRING (5, base
);
2931 ans
= scm_i_make_string (0, NULL
);
2932 if (!SCM_UNBNDP (make_final
))
2933 SCM_VALIDATE_PROC (6, make_final
);
2935 res
= scm_call_1 (p
, seed
);
2936 while (scm_is_false (res
))
2940 SCM ch
= scm_call_1 (f
, seed
);
2941 if (!SCM_CHARP (ch
))
2942 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2943 str
= scm_i_make_string (1, &ptr
);
2944 *ptr
= SCM_CHAR (ch
);
2946 ans
= scm_string_append (scm_list_2 (str
, ans
));
2947 seed
= scm_call_1 (g
, seed
);
2948 res
= scm_call_1 (p
, seed
);
2950 if (!SCM_UNBNDP (make_final
))
2952 res
= scm_call_1 (make_final
, seed
);
2953 return scm_string_append (scm_list_2 (res
, ans
));
2961 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2962 (SCM proc
, SCM s
, SCM start
, SCM end
),
2963 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2964 "return value is not specified.")
2965 #define FUNC_NAME s_scm_string_for_each
2968 size_t cstart
, cend
;
2970 SCM_VALIDATE_PROC (1, proc
);
2971 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2974 while (cstart
< cend
)
2976 unsigned int c
= (unsigned char) cstr
[cstart
];
2977 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2978 cstr
= scm_i_string_chars (s
);
2982 scm_remember_upto_here_1 (s
);
2983 return SCM_UNSPECIFIED
;
2987 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2988 (SCM proc
, SCM s
, SCM start
, SCM end
),
2989 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2990 "return value is not specified.")
2991 #define FUNC_NAME s_scm_string_for_each_index
2993 size_t cstart
, cend
;
2995 SCM_VALIDATE_PROC (1, proc
);
2996 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3000 while (cstart
< cend
)
3002 scm_call_1 (proc
, scm_from_size_t (cstart
));
3006 scm_remember_upto_here_1 (s
);
3007 return SCM_UNSPECIFIED
;
3011 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
3012 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
3013 "This is the @emph{extended substring} procedure that implements\n"
3014 "replicated copying of a substring of some string.\n"
3016 "@var{s} is a string, @var{start} and @var{end} are optional\n"
3017 "arguments that demarcate a substring of @var{s}, defaulting to\n"
3018 "0 and the length of @var{s}. Replicate this substring up and\n"
3019 "down index space, in both the positive and negative directions.\n"
3020 "@code{xsubstring} returns the substring of this string\n"
3021 "beginning at index @var{from}, and ending at @var{to}, which\n"
3022 "defaults to @var{from} + (@var{end} - @var{start}).")
3023 #define FUNC_NAME s_scm_xsubstring
3027 size_t cstart
, cend
;
3031 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3035 cfrom
= scm_to_int (from
);
3036 if (SCM_UNBNDP (to
))
3037 cto
= cfrom
+ (cend
- cstart
);
3039 cto
= scm_to_int (to
);
3040 if (cstart
== cend
&& cfrom
!= cto
)
3041 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3043 result
= scm_i_make_string (cto
- cfrom
, &p
);
3045 cs
= scm_i_string_chars (s
);
3048 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
3050 *p
= cs
[(cend
- cstart
) - t
];
3057 scm_remember_upto_here_1 (s
);
3063 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3064 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3065 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3066 "is written into the string @var{target} starting at index\n"
3067 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3068 "@var{target} @var{s})} or these arguments share storage -- you\n"
3069 "cannot copy a string on top of itself.")
3070 #define FUNC_NAME s_scm_string_xcopy_x
3074 size_t ctstart
, cstart
, cend
;
3076 SCM dummy
= SCM_UNDEFINED
;
3079 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3082 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
3085 csfrom
= scm_to_int (sfrom
);
3086 if (SCM_UNBNDP (sto
))
3087 csto
= csfrom
+ (cend
- cstart
);
3089 csto
= scm_to_int (sto
);
3090 if (cstart
== cend
&& csfrom
!= csto
)
3091 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3092 SCM_ASSERT_RANGE (1, tstart
,
3093 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3095 p
= scm_i_string_writable_chars (target
) + ctstart
;
3096 cs
= scm_i_string_chars (s
);
3097 while (csfrom
< csto
)
3099 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3101 *p
= cs
[(cend
- cstart
) - t
];
3107 scm_i_string_stop_writing ();
3109 scm_remember_upto_here_2 (target
, s
);
3110 return SCM_UNSPECIFIED
;
3115 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3116 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3117 "Return the string @var{s1}, but with the characters\n"
3118 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3119 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3120 #define FUNC_NAME s_scm_string_replace
3122 const char *cstr1
, *cstr2
;
3124 size_t cstart1
, cend1
, cstart2
, cend2
;
3127 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
3130 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
3133 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3134 scm_i_string_length (s1
) - cend1
, &p
);
3135 cstr1
= scm_i_string_chars (s1
);
3136 cstr2
= scm_i_string_chars (s2
);
3137 memmove (p
, cstr1
, cstart1
* sizeof (char));
3138 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3139 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3141 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3142 scm_remember_upto_here_2 (s1
, s2
);
3148 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3149 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3150 "Split the string @var{s} into a list of substrings, where each\n"
3151 "substring is a maximal non-empty contiguous sequence of\n"
3152 "characters from the character set @var{token_set}, which\n"
3153 "defaults to @code{char-set:graphic}.\n"
3154 "If @var{start} or @var{end} indices are provided, they restrict\n"
3155 "@code{string-tokenize} to operating on the indicated substring\n"
3157 #define FUNC_NAME s_scm_string_tokenize
3160 size_t cstart
, cend
;
3161 SCM result
= SCM_EOL
;
3163 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3167 if (SCM_UNBNDP (token_set
))
3168 token_set
= scm_char_set_graphic
;
3170 if (SCM_CHARSETP (token_set
))
3174 while (cstart
< cend
)
3176 while (cstart
< cend
)
3178 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3185 while (cstart
< cend
)
3187 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3191 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3192 cstr
= scm_i_string_chars (s
);
3196 SCM_WRONG_TYPE_ARG (2, token_set
);
3198 scm_remember_upto_here_1 (s
);
3203 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3205 "Split the string @var{str} into the a list of the substrings delimited\n"
3206 "by appearances of the character @var{chr}. Note that an empty substring\n"
3207 "between separator characters will result in an empty string in the\n"
3211 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3213 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3215 "(string-split \"::\" #\\:)\n"
3217 "(\"\" \"\" \"\")\n"
3219 "(string-split \"\" #\\:)\n"
3223 #define FUNC_NAME s_scm_string_split
3230 SCM_VALIDATE_STRING (1, str
);
3231 SCM_VALIDATE_CHAR (2, chr
);
3233 idx
= scm_i_string_length (str
);
3234 p
= scm_i_string_chars (str
);
3235 ch
= SCM_CHAR (chr
);
3239 while (idx
> 0 && p
[idx
- 1] != ch
)
3243 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3244 p
= scm_i_string_chars (str
);
3248 scm_remember_upto_here_1 (str
);
3254 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3255 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3256 "Filter the string @var{s}, retaining only those characters\n"
3257 "which satisfy @var{char_pred}. The result may share storage\n"
3260 "If @var{char_pred} is a procedure, it is applied to each\n"
3261 "character as a predicate, if it is a character, it is tested\n"
3262 "for equality and if it is a character set, it is tested for\n"
3264 #define FUNC_NAME s_scm_string_filter
3267 size_t cstart
, cend
;
3271 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3274 if (SCM_CHARP (char_pred
))
3279 /* count chars to keep */
3280 chr
= SCM_CHAR (char_pred
);
3282 for (idx
= cstart
; idx
< cend
; idx
++)
3283 if (cstr
[idx
] == chr
)
3286 /* if whole of start to end kept then return substring */
3287 if (count
== cend
- cstart
)
3290 result
= scm_i_substring (s
, cstart
, cend
);
3293 result
= scm_c_make_string (count
, char_pred
);
3295 else if (SCM_CHARSETP (char_pred
))
3299 /* count chars to be kept */
3301 for (idx
= cstart
; idx
< cend
; idx
++)
3302 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3305 /* if whole of start to end kept then return substring */
3306 if (count
== cend
- cstart
)
3307 goto result_substring
;
3311 result
= scm_i_make_string (count
, &dst
);
3312 cstr
= scm_i_string_chars (s
);
3314 /* decrement "count" in this loop as well as using idx, so that if
3315 another thread is simultaneously changing "s" there's no chance
3316 it'll make us copy more than count characters */
3317 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3319 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3331 SCM_VALIDATE_PROC (2, char_pred
);
3336 ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3337 res
= scm_call_1 (char_pred
, ch
);
3338 if (scm_is_true (res
))
3339 ls
= scm_cons (ch
, ls
);
3340 cstr
= scm_i_string_chars (s
);
3343 result
= scm_reverse_list_to_string (ls
);
3346 scm_remember_upto_here_1 (s
);
3352 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3353 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3354 "Delete characters satisfying @var{char_pred} from @var{s}. The\n"
3355 "result may share storage with @var{s}.\n"
3357 "If @var{char_pred} is a procedure, it is applied to each\n"
3358 "character as a predicate, if it is a character, it is tested\n"
3359 "for equality and if it is a character set, it is tested for\n"
3361 #define FUNC_NAME s_scm_string_delete
3364 size_t cstart
, cend
;
3368 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3371 if (SCM_CHARP (char_pred
))
3376 chr
= SCM_CHAR (char_pred
);
3378 /* count chars to be kept */
3380 for (idx
= cstart
; idx
< cend
; idx
++)
3381 if (cstr
[idx
] != chr
)
3384 /* if whole of start to end kept then return substring */
3385 if (count
== cend
- cstart
)
3388 result
= scm_i_substring (s
, cstart
, cend
);
3392 /* new string for retained portion */
3394 result
= scm_i_make_string (count
, &dst
);
3395 cstr
= scm_i_string_chars (s
);
3397 /* decrement "count" in this loop as well as using idx, so that if
3398 another thread is simultaneously changing "s" there's no chance
3399 it'll make us copy more than count characters */
3400 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3402 if (cstr
[idx
] != chr
)
3410 else if (SCM_CHARSETP (char_pred
))
3414 /* count chars to be kept */
3416 for (idx
= cstart
; idx
< cend
; idx
++)
3417 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3420 /* if whole of start to end kept then return substring, including
3421 possibly s itself */
3422 if (count
== cend
- cstart
)
3423 goto result_substring
;
3426 /* new string for retained portion */
3428 result
= scm_i_make_string (count
, &dst
);
3429 cstr
= scm_i_string_chars (s
);
3431 /* decrement "count" in this loop as well as using idx, so that if
3432 another thread is simultaneously changing "s" there's no chance
3433 it'll make us copy more than count characters */
3434 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3436 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3448 SCM_VALIDATE_PROC (2, char_pred
);
3452 SCM res
, ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3453 res
= scm_call_1 (char_pred
, ch
);
3454 if (scm_is_false (res
))
3455 ls
= scm_cons (ch
, ls
);
3456 cstr
= scm_i_string_chars (s
);
3459 result
= scm_reverse_list_to_string (ls
);
3462 scm_remember_upto_here_1 (s
);
3468 scm_init_srfi_13 (void)
3470 #include "libguile/srfi-13.x"
3473 /* End of srfi-13.c. */