1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
32 #include <libguile/deprecation.h>
33 #include "libguile/srfi-13.h"
34 #include "libguile/srfi-14.h"
36 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
37 pos_start, start, c_start, \
38 pos_end, end, c_end) \
40 SCM_VALIDATE_STRING (pos_str, str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 #define REF_IN_CHARSET(s, i, cs) \
55 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
57 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
59 "Return @code{#t} if @var{str}'s length is zero, and\n"
60 "@code{#f} otherwise.\n"
62 "(string-null? \"\") @result{} #t\n"
63 "y @result{} \"foo\"\n"
64 "(string-null? y) @result{} #f\n"
66 #define FUNC_NAME s_scm_string_null_p
68 SCM_VALIDATE_STRING (1, str
);
69 return scm_from_bool (scm_i_string_length (str
) == 0);
77 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
81 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
82 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
83 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
85 "@var{char_pred} can be a character to check for any equal to that, or\n"
86 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
87 "or a predicate procedure to call.\n"
89 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
90 "successively on the characters from @var{start} to @var{end}. If\n"
91 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
92 "stops and that return value is the return from @code{string-any}. The\n"
93 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
94 "point is reached, is a tail call.\n"
96 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
97 "@var{end}) then the return is @code{#f}.\n")
98 #define FUNC_NAME s_scm_string_any
101 SCM res
= SCM_BOOL_F
;
103 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
107 if (SCM_CHARP (char_pred
))
110 for (i
= cstart
; i
< cend
; i
++)
111 if (scm_i_string_ref (s
, i
) == SCM_CHAR (char_pred
))
117 else if (SCM_CHARSETP (char_pred
))
120 for (i
= cstart
; i
< cend
; i
++)
121 if (REF_IN_CHARSET (s
, i
, char_pred
))
129 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
130 char_pred
, SCM_ARG1
, FUNC_NAME
);
132 while (cstart
< cend
)
134 res
= scm_call_1 (char_pred
,
135 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
136 if (scm_is_true (res
))
142 scm_remember_upto_here_1 (s
);
148 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
149 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
150 "Check if @var{char_pred} is true for every character in string\n"
153 "@var{char_pred} can be a character to check for every character equal\n"
154 "to that, or a character set (@pxref{Character Sets}) to check for\n"
155 "every character being in that set, or a predicate procedure to call.\n"
157 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
158 "successively on the characters from @var{start} to @var{end}. If\n"
159 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
160 "returns @code{#f}. The call on the last character (ie.@: at\n"
161 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
162 "return from that call is the return from @code{string-every}.\n"
164 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
165 "@var{end}) then the return is @code{#t}.\n")
166 #define FUNC_NAME s_scm_string_every
169 SCM res
= SCM_BOOL_T
;
171 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
174 if (SCM_CHARP (char_pred
))
177 for (i
= cstart
; i
< cend
; i
++)
178 if (scm_i_string_ref (s
, i
) != SCM_CHAR (char_pred
))
184 else if (SCM_CHARSETP (char_pred
))
187 for (i
= cstart
; i
< cend
; i
++)
188 if (!REF_IN_CHARSET (s
, i
, char_pred
))
196 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
197 char_pred
, SCM_ARG1
, FUNC_NAME
);
199 while (cstart
< cend
)
201 res
= scm_call_1 (char_pred
,
202 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
203 if (scm_is_false (res
))
209 scm_remember_upto_here_1 (s
);
215 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
217 "@var{proc} is an integer->char procedure. Construct a string\n"
218 "of size @var{len} by applying @var{proc} to each index to\n"
219 "produce the corresponding string element. The order in which\n"
220 "@var{proc} is applied to the indices is not specified.")
221 #define FUNC_NAME s_scm_string_tabulate
227 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
228 proc
, SCM_ARG1
, FUNC_NAME
);
230 SCM_ASSERT_RANGE (2, len
, scm_to_int (len
) >= 0);
231 clen
= scm_to_size_t (len
);
234 /* This function is more complicated than necessary for the sake
236 scm_t_wchar
*buf
= scm_malloc (clen
* sizeof (scm_t_wchar
));
241 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
244 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
246 if (SCM_CHAR (ch
) > 255)
248 buf
[i
] = SCM_CHAR (ch
);
253 scm_t_wchar
*wbuf
= NULL
;
254 res
= scm_i_make_wide_string (clen
, &wbuf
, 0);
255 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
261 res
= scm_i_make_string (clen
, &nbuf
, 0);
262 for (i
= 0; i
< clen
; i
++)
263 nbuf
[i
] = (unsigned char) buf
[i
];
273 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
274 (SCM str
, SCM start
, SCM end
),
275 "Convert the string @var{str} into a list of characters.")
276 #define FUNC_NAME s_scm_substring_to_list
280 SCM result
= SCM_EOL
;
282 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
286 /* This explicit narrow/wide logic (instead of just using
287 scm_i_string_ref) is for speed optimizaion. */
288 narrow
= scm_i_is_narrow_string (str
);
291 const char *buf
= scm_i_string_chars (str
);
292 while (cstart
< cend
)
295 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
300 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
301 while (cstart
< cend
)
304 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
307 scm_remember_upto_here_1 (str
);
312 /* We export scm_substring_to_list as "string->list" since it is
313 compatible and more general. This function remains for the benefit
314 of C code that used it.
318 scm_string_to_list (SCM str
)
320 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
323 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
325 "An efficient implementation of @code{(compose string->list\n"
329 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
331 #define FUNC_NAME s_scm_reverse_list_to_string
334 long i
= scm_ilength (chrs
), j
;
338 SCM_WRONG_TYPE_ARG (1, chrs
);
339 result
= scm_i_make_string (i
, &data
, 0);
345 while (j
< i
&& scm_is_pair (rest
))
347 SCM elt
= SCM_CAR (rest
);
348 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
350 rest
= SCM_CDR (rest
);
354 result
= scm_i_string_start_writing (result
);
355 while (j
> 0 && scm_is_pair (rest
))
357 SCM elt
= SCM_CAR (rest
);
358 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
359 rest
= SCM_CDR (rest
);
362 scm_i_string_stop_writing ();
370 SCM_SYMBOL (scm_sym_infix
, "infix");
371 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
372 SCM_SYMBOL (scm_sym_suffix
, "suffix");
373 SCM_SYMBOL (scm_sym_prefix
, "prefix");
375 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
376 (SCM ls
, SCM delimiter
, SCM grammar
),
377 "Append the string in the string list @var{ls}, using the string\n"
378 "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
379 "@var{grammar} is a symbol which specifies how the delimiter is\n"
380 "placed between the strings, and defaults to the symbol\n"
385 "Insert the separator between list elements. An empty string\n"
386 "will produce an empty list.\n"
387 "@item strict-infix\n"
388 "Like @code{infix}, but will raise an error if given the empty\n"
391 "Insert the separator after every list element.\n"
393 "Insert the separator before each list element.\n"
395 #define FUNC_NAME s_scm_string_join
397 SCM append_list
= SCM_EOL
;
398 long list_len
= scm_ilength (ls
);
399 size_t delimiter_len
= 0;
401 /* Validate the string list. */
403 SCM_WRONG_TYPE_ARG (1, ls
);
405 /* Validate the delimiter and record its length. */
406 if (SCM_UNBNDP (delimiter
))
408 delimiter
= scm_from_locale_string (" ");
413 SCM_VALIDATE_STRING (2, delimiter
);
414 delimiter_len
= scm_i_string_length (delimiter
);
417 /* Validate the grammar symbol. */
418 if (SCM_UNBNDP (grammar
))
419 grammar
= scm_sym_infix
;
420 else if (!(scm_is_eq (grammar
, scm_sym_infix
)
421 || scm_is_eq (grammar
, scm_sym_strict_infix
)
422 || scm_is_eq (grammar
, scm_sym_suffix
)
423 || scm_is_eq (grammar
, scm_sym_prefix
)))
424 SCM_WRONG_TYPE_ARG (3, grammar
);
428 if (scm_is_eq (grammar
, scm_sym_strict_infix
))
429 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
432 /* Handle empty lists specially */
433 append_list
= SCM_EOL
;
435 else if (delimiter_len
== 0)
436 /* Handle empty delimiters specially */
440 SCM
*last_cdr_p
= &append_list
;
442 #define ADD_TO_APPEND_LIST(x) \
443 (last_cdr_p = SCM_CDRLOC (*last_cdr_p = scm_list_1 (x)))
445 /* Build a list of strings to pass to 'string-append'.
446 Here we assume that 'ls' has at least one element. */
448 /* If using the 'prefix' grammar, start with the delimiter. */
449 if (scm_is_eq (grammar
, scm_sym_prefix
))
450 ADD_TO_APPEND_LIST (delimiter
);
452 /* Handle the first element of 'ls' specially, so that in the loop
453 that follows we can unconditionally insert the delimiter before
454 every remaining element. */
455 ADD_TO_APPEND_LIST (SCM_CAR (ls
));
458 /* Insert the delimiter before every remaining element. */
459 while (scm_is_pair (ls
))
461 ADD_TO_APPEND_LIST (delimiter
);
462 ADD_TO_APPEND_LIST (SCM_CAR (ls
));
466 /* If using the 'suffix' grammar, add the delimiter to the end. */
467 if (scm_is_eq (grammar
, scm_sym_suffix
))
468 ADD_TO_APPEND_LIST (delimiter
);
470 #undef ADD_TO_APPEND_LIST
473 /* Construct the final result. */
474 return scm_string_append (append_list
);
479 /* There are a number of functions to consider here for Scheme and C:
481 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
482 substring/copy STR start [end] ;; Guile variant of R5RS substring
484 scm_string_copy (str) ;; Old function from Guile
485 scm_substring_copy (str, [start, [end]])
486 ;; C version of SRFI-13 string-copy
487 ;; and C version of substring/copy
489 The C function underlying string-copy is not exported to C
490 programs. scm_substring_copy is defined in strings.c as the
491 underlying function of substring/copy and allows an optional START
495 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
497 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
498 (SCM str
, SCM start
, SCM end
),
499 "Return a freshly allocated copy of the string @var{str}. If\n"
500 "given, @var{start} and @var{end} delimit the portion of\n"
501 "@var{str} which is copied.")
502 #define FUNC_NAME s_scm_srfi13_substring_copy
506 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
509 return scm_i_substring_copy (str
, cstart
, cend
);
514 scm_string_copy (SCM str
)
516 if (!scm_is_string (str
))
517 scm_wrong_type_arg ("scm_string_copy", 0, str
);
519 return scm_i_substring (str
, 0, scm_i_string_length (str
));
522 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
523 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
524 "Copy the sequence of characters from index range [@var{start},\n"
525 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
526 "at index @var{tstart}. The characters are copied left-to-right\n"
527 "or right-to-left as needed -- the copy is guaranteed to work,\n"
528 "even if @var{target} and @var{s} are the same string. It is an\n"
529 "error if the copy operation runs off the end of the target\n"
531 #define FUNC_NAME s_scm_string_copy_x
533 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
534 SCM sdummy
= SCM_UNDEFINED
;
536 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
539 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
545 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
547 target
= scm_i_string_start_writing (target
);
548 for (i
= 0; i
< cend
- cstart
; i
++)
550 scm_i_string_set_x (target
, ctstart
+ i
,
551 scm_i_string_ref (s
, cstart
+ i
));
553 scm_i_string_stop_writing ();
554 scm_remember_upto_here_1 (target
);
557 return SCM_UNSPECIFIED
;
561 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
562 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
563 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
564 "into @var{str2} beginning at position @var{start2}.\n"
565 "@var{str1} and @var{str2} can be the same string.")
566 #define FUNC_NAME s_scm_substring_move_x
568 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
572 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
574 "Return the @var{n} first characters of @var{s}.")
575 #define FUNC_NAME s_scm_string_take
577 return scm_substring (s
, SCM_INUM0
, n
);
582 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
584 "Return all but the first @var{n} characters of @var{s}.")
585 #define FUNC_NAME s_scm_string_drop
587 return scm_substring (s
, n
, SCM_UNDEFINED
);
592 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
594 "Return the @var{n} last characters of @var{s}.")
595 #define FUNC_NAME s_scm_string_take_right
597 return scm_substring (s
,
598 scm_difference (scm_string_length (s
), n
),
604 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
606 "Return all but the last @var{n} characters of @var{s}.")
607 #define FUNC_NAME s_scm_string_drop_right
609 return scm_substring (s
,
611 scm_difference (scm_string_length (s
), n
));
616 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
617 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
618 "Take that characters from @var{start} to @var{end} from the\n"
619 "string @var{s} and return a new string, right-padded by the\n"
620 "character @var{chr} to length @var{len}. If the resulting\n"
621 "string is longer than @var{len}, it is truncated on the right.")
622 #define FUNC_NAME s_scm_string_pad
624 size_t cstart
, cend
, clen
;
626 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
629 clen
= scm_to_size_t (len
);
631 if (SCM_UNBNDP (chr
))
632 chr
= SCM_MAKE_CHAR (' ');
635 SCM_VALIDATE_CHAR (3, chr
);
637 if (clen
< (cend
- cstart
))
638 return scm_i_substring (s
, cend
- clen
, cend
);
642 result
= (scm_string_append
643 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
644 scm_i_substring (s
, cstart
, cend
))));
651 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
652 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
653 "Take that characters from @var{start} to @var{end} from the\n"
654 "string @var{s} and return a new string, left-padded by the\n"
655 "character @var{chr} to length @var{len}. If the resulting\n"
656 "string is longer than @var{len}, it is truncated on the left.")
657 #define FUNC_NAME s_scm_string_pad_right
659 size_t cstart
, cend
, clen
;
661 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
664 clen
= scm_to_size_t (len
);
666 if (SCM_UNBNDP (chr
))
667 chr
= SCM_MAKE_CHAR (' ');
670 SCM_VALIDATE_CHAR (3, chr
);
672 if (clen
< (cend
- cstart
))
673 return scm_i_substring (s
, cstart
, cstart
+ clen
);
678 result
= (scm_string_append
679 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
680 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
688 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
689 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
690 "Trim @var{s} by skipping over all characters on the left\n"
691 "that satisfy the parameter @var{char_pred}:\n"
695 "if it is the character @var{ch}, characters equal to\n"
696 "@var{ch} are trimmed,\n"
699 "if it is a procedure @var{pred} characters that\n"
700 "satisfy @var{pred} are trimmed,\n"
703 "if it is a character set, characters in that set are trimmed.\n"
706 "If called without a @var{char_pred} argument, all whitespace is\n"
708 #define FUNC_NAME s_scm_string_trim
712 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
715 if (SCM_UNBNDP (char_pred
)
716 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
718 while (cstart
< cend
)
720 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
725 else if (SCM_CHARP (char_pred
))
727 while (cstart
< cend
)
729 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
734 else if (SCM_CHARSETP (char_pred
))
736 while (cstart
< cend
)
738 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
745 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
746 char_pred
, SCM_ARG2
, FUNC_NAME
);
748 while (cstart
< cend
)
752 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
753 if (scm_is_false (res
))
758 return scm_i_substring (s
, cstart
, cend
);
763 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
764 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
765 "Trim @var{s} by skipping over all characters on the right\n"
766 "that satisfy the parameter @var{char_pred}:\n"
770 "if it is the character @var{ch}, characters equal to @var{ch}\n"
774 "if it is a procedure @var{pred} characters that satisfy\n"
775 "@var{pred} are trimmed,\n"
778 "if it is a character sets, all characters in that set are\n"
782 "If called without a @var{char_pred} argument, all whitespace is\n"
784 #define FUNC_NAME s_scm_string_trim_right
788 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
791 if (SCM_UNBNDP (char_pred
)
792 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
794 while (cstart
< cend
)
796 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
801 else if (SCM_CHARP (char_pred
))
803 while (cstart
< cend
)
805 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
810 else if (SCM_CHARSETP (char_pred
))
812 while (cstart
< cend
)
814 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
821 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
822 char_pred
, SCM_ARG2
, FUNC_NAME
);
824 while (cstart
< cend
)
828 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
829 if (scm_is_false (res
))
834 return scm_i_substring (s
, cstart
, cend
);
839 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
840 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
841 "Trim @var{s} by skipping over all characters on both sides of\n"
842 "the string that satisfy the parameter @var{char_pred}:\n"
846 "if it is the character @var{ch}, characters equal to @var{ch}\n"
850 "if it is a procedure @var{pred} characters that satisfy\n"
851 "@var{pred} are trimmed,\n"
854 "if it is a character set, the characters in the set are\n"
858 "If called without a @var{char_pred} argument, all whitespace is\n"
860 #define FUNC_NAME s_scm_string_trim_both
864 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
867 if (SCM_UNBNDP (char_pred
)
868 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
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
);
974 str
= scm_i_string_start_writing (str
);
975 for (k
= cstart
; k
< cend
; k
++)
976 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
977 scm_i_string_stop_writing ();
980 return SCM_UNSPECIFIED
;
985 scm_string_fill_x (SCM str
, SCM chr
)
987 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
990 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
991 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
992 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
993 "mismatch index, depending upon whether @var{s1} is less than,\n"
994 "equal to, or greater than @var{s2}. The mismatch index is the\n"
995 "largest index @var{i} such that for every 0 <= @var{j} <\n"
996 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
997 "@var{i} is the first position that does not match.")
998 #define FUNC_NAME s_scm_string_compare
1000 size_t cstart1
, cend1
, cstart2
, cend2
;
1003 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1006 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1009 SCM_VALIDATE_PROC (3, proc_lt
);
1010 SCM_VALIDATE_PROC (4, proc_eq
);
1011 SCM_VALIDATE_PROC (5, proc_gt
);
1013 while (cstart1
< cend1
&& cstart2
< cend2
)
1015 if (scm_i_string_ref (s1
, cstart1
)
1016 < scm_i_string_ref (s2
, cstart2
))
1021 else if (scm_i_string_ref (s1
, cstart1
)
1022 > scm_i_string_ref (s2
, cstart2
))
1030 if (cstart1
< cend1
)
1032 else if (cstart2
< cend2
)
1038 scm_remember_upto_here_2 (s1
, s2
);
1039 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1044 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1045 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1046 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1047 "mismatch index, depending upon whether @var{s1} is less than,\n"
1048 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1049 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1050 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1051 "@var{i} is the first position where the lowercased letters \n"
1053 #define FUNC_NAME s_scm_string_compare_ci
1055 size_t cstart1
, cend1
, cstart2
, cend2
;
1058 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1061 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1064 SCM_VALIDATE_PROC (3, proc_lt
);
1065 SCM_VALIDATE_PROC (4, proc_eq
);
1066 SCM_VALIDATE_PROC (5, proc_gt
);
1068 while (cstart1
< cend1
&& cstart2
< cend2
)
1070 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1071 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1076 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1077 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1086 if (cstart1
< cend1
)
1088 else if (cstart2
< cend2
)
1094 scm_remember_upto_here (s1
, s2
);
1095 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1099 /* This function compares two substrings, S1 from START1 to END1 and
1100 S2 from START2 to END2, possibly case insensitively, and returns
1101 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1102 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1103 longer, or equal. */
1105 compare_strings (const char *fname
, int case_insensitive
,
1106 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1107 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1109 size_t cstart1
, cend1
, cstart2
, cend2
;
1113 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1116 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1120 while (cstart1
< cend1
&& cstart2
< cend2
)
1122 if (case_insensitive
)
1124 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1125 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1129 a
= scm_i_string_ref (s1
, cstart1
);
1130 b
= scm_i_string_ref (s2
, cstart2
);
1145 if (cstart1
< cend1
)
1150 else if (cstart2
< cend2
)
1162 scm_remember_upto_here_2 (s1
, s2
);
1167 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1168 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1169 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1171 #define FUNC_NAME s_scm_string_eq
1173 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1174 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1175 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1176 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1178 /* Fast path for this common case, which avoids the repeated calls to
1179 `scm_i_string_ref'. */
1182 len1
= scm_i_string_length (s1
);
1183 len2
= scm_i_string_length (s2
);
1189 if (!scm_i_is_narrow_string (s1
))
1192 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1193 scm_i_string_data (s2
),
1198 return compare_strings (FUNC_NAME
, 0,
1199 s1
, s2
, start1
, end1
, start2
, end2
,
1200 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1205 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1206 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1207 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1209 #define FUNC_NAME s_scm_string_neq
1211 return compare_strings (FUNC_NAME
, 0,
1212 s1
, s2
, start1
, end1
, start2
, end2
,
1213 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1218 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1219 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1220 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1221 "true value otherwise.")
1222 #define FUNC_NAME s_scm_string_lt
1224 return compare_strings (FUNC_NAME
, 0,
1225 s1
, s2
, start1
, end1
, start2
, end2
,
1226 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1231 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1232 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1233 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1234 "true value otherwise.")
1235 #define FUNC_NAME s_scm_string_gt
1237 return compare_strings (FUNC_NAME
, 0,
1238 s1
, s2
, start1
, end1
, start2
, end2
,
1239 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1244 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1245 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1246 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1248 #define FUNC_NAME s_scm_string_le
1250 return compare_strings (FUNC_NAME
, 0,
1251 s1
, s2
, start1
, end1
, start2
, end2
,
1252 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1257 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1258 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1259 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1261 #define FUNC_NAME s_scm_string_ge
1263 return compare_strings (FUNC_NAME
, 0,
1264 s1
, s2
, start1
, end1
, start2
, end2
,
1265 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1270 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1271 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1272 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1273 "value otherwise. The character comparison is done\n"
1274 "case-insensitively.")
1275 #define FUNC_NAME s_scm_string_ci_eq
1277 return compare_strings (FUNC_NAME
, 1,
1278 s1
, s2
, start1
, end1
, start2
, end2
,
1279 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1284 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1285 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1286 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1287 "value otherwise. The character comparison is done\n"
1288 "case-insensitively.")
1289 #define FUNC_NAME s_scm_string_ci_neq
1291 return compare_strings (FUNC_NAME
, 1,
1292 s1
, s2
, start1
, end1
, start2
, end2
,
1293 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1298 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1299 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1300 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1301 "true value otherwise. The character comparison is done\n"
1302 "case-insensitively.")
1303 #define FUNC_NAME s_scm_string_ci_lt
1305 return compare_strings (FUNC_NAME
, 1,
1306 s1
, s2
, start1
, end1
, start2
, end2
,
1307 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1312 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1313 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1314 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1315 "true value otherwise. The character comparison is done\n"
1316 "case-insensitively.")
1317 #define FUNC_NAME s_scm_string_ci_gt
1319 return compare_strings (FUNC_NAME
, 1,
1320 s1
, s2
, start1
, end1
, start2
, end2
,
1321 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1326 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1327 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1328 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1329 "value otherwise. The character comparison is done\n"
1330 "case-insensitively.")
1331 #define FUNC_NAME s_scm_string_ci_le
1333 return compare_strings (FUNC_NAME
, 1,
1334 s1
, s2
, start1
, end1
, start2
, end2
,
1335 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1340 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1341 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1342 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1343 "otherwise. The character comparison is done\n"
1344 "case-insensitively.")
1345 #define FUNC_NAME s_scm_string_ci_ge
1347 return compare_strings (FUNC_NAME
, 1,
1348 s1
, s2
, start1
, end1
, start2
, end2
,
1349 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1353 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1354 (SCM s
, SCM bound
, SCM start
, SCM end
),
1355 "Compute a hash value for @var{s}. the optional argument "
1356 "@var{bound} is a non-negative exact "
1357 "integer specifying the range of the hash function. "
1358 "A positive value restricts the return value to the "
1360 #define FUNC_NAME s_scm_substring_hash
1362 if (SCM_UNBNDP (bound
))
1363 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1364 if (SCM_UNBNDP (start
))
1366 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1370 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1371 (SCM s
, SCM bound
, SCM start
, SCM end
),
1372 "Compute a hash value for @var{s}. the optional argument "
1373 "@var{bound} is a non-negative exact "
1374 "integer specifying the range of the hash function. "
1375 "A positive value restricts the return value to the "
1377 #define FUNC_NAME s_scm_substring_hash_ci
1379 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1381 SCM_UNDEFINED
, SCM_UNDEFINED
);
1385 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1386 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1387 "Return the length of the longest common prefix of the two\n"
1389 #define FUNC_NAME s_scm_string_prefix_length
1391 size_t cstart1
, cend1
, cstart2
, cend2
;
1394 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1397 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1401 while (cstart1
< cend1
&& cstart2
< cend2
)
1403 if (scm_i_string_ref (s1
, cstart1
)
1404 != scm_i_string_ref (s2
, cstart2
))
1412 scm_remember_upto_here_2 (s1
, s2
);
1413 return scm_from_size_t (len
);
1418 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1419 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1420 "Return the length of the longest common prefix of the two\n"
1421 "strings, ignoring character case.")
1422 #define FUNC_NAME s_scm_string_prefix_length_ci
1424 size_t cstart1
, cend1
, cstart2
, cend2
;
1427 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1430 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1433 while (cstart1
< cend1
&& cstart2
< cend2
)
1435 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1436 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1444 scm_remember_upto_here_2 (s1
, s2
);
1445 return scm_from_size_t (len
);
1450 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1451 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1452 "Return the length of the longest common suffix of the two\n"
1454 #define FUNC_NAME s_scm_string_suffix_length
1456 size_t cstart1
, cend1
, cstart2
, cend2
;
1459 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1462 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1465 while (cstart1
< cend1
&& cstart2
< cend2
)
1469 if (scm_i_string_ref (s1
, cend1
)
1470 != scm_i_string_ref (s2
, cend2
))
1476 scm_remember_upto_here_2 (s1
, s2
);
1477 return scm_from_size_t (len
);
1482 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1483 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1484 "Return the length of the longest common suffix of the two\n"
1485 "strings, ignoring character case.")
1486 #define FUNC_NAME s_scm_string_suffix_length_ci
1488 size_t cstart1
, cend1
, cstart2
, cend2
;
1491 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1494 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1497 while (cstart1
< cend1
&& cstart2
< cend2
)
1501 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1502 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1508 scm_remember_upto_here_2 (s1
, s2
);
1509 return scm_from_size_t (len
);
1514 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1515 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1516 "Is @var{s1} a prefix of @var{s2}?")
1517 #define FUNC_NAME s_scm_string_prefix_p
1519 size_t cstart1
, cend1
, cstart2
, cend2
;
1520 size_t len
= 0, len1
;
1522 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1525 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1528 len1
= cend1
- cstart1
;
1529 while (cstart1
< cend1
&& cstart2
< cend2
)
1531 if (scm_i_string_ref (s1
, cstart1
)
1532 != scm_i_string_ref (s2
, cstart2
))
1540 scm_remember_upto_here_2 (s1
, s2
);
1541 return scm_from_bool (len
== len1
);
1546 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1547 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1548 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1549 #define FUNC_NAME s_scm_string_prefix_ci_p
1551 size_t cstart1
, cend1
, cstart2
, cend2
;
1552 size_t len
= 0, len1
;
1554 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1557 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1560 len1
= cend1
- cstart1
;
1561 while (cstart1
< cend1
&& cstart2
< cend2
)
1563 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1564 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1573 scm_remember_upto_here_2 (s1
, s2
);
1574 return scm_from_bool (len
== len1
);
1579 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1580 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1581 "Is @var{s1} a suffix of @var{s2}?")
1582 #define FUNC_NAME s_scm_string_suffix_p
1584 size_t cstart1
, cend1
, cstart2
, cend2
;
1585 size_t len
= 0, len1
;
1587 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1590 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1593 len1
= cend1
- cstart1
;
1594 while (cstart1
< cend1
&& cstart2
< cend2
)
1598 if (scm_i_string_ref (s1
, cend1
)
1599 != scm_i_string_ref (s2
, cend2
))
1605 scm_remember_upto_here_2 (s1
, s2
);
1606 return scm_from_bool (len
== len1
);
1611 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1612 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1613 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1614 #define FUNC_NAME s_scm_string_suffix_ci_p
1616 size_t cstart1
, cend1
, cstart2
, cend2
;
1617 size_t len
= 0, len1
;
1619 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1622 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1625 len1
= cend1
- cstart1
;
1626 while (cstart1
< cend1
&& cstart2
< cend2
)
1630 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1631 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1637 scm_remember_upto_here_2 (s1
, s2
);
1638 return scm_from_bool (len
== len1
);
1643 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1644 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1645 "Search through the string @var{s} from left to right, returning\n"
1646 "the index of the first occurrence of a character which\n"
1648 "@itemize @bullet\n"
1650 "equals @var{char_pred}, if it is character,\n"
1653 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1656 "is in the set @var{char_pred}, if it is a character set.\n"
1658 "Return @code{#f} if no match is found.")
1659 #define FUNC_NAME s_scm_string_index
1661 size_t cstart
, cend
;
1663 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1666 if (SCM_CHARP (char_pred
))
1668 while (cstart
< cend
)
1670 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1675 else if (SCM_CHARSETP (char_pred
))
1677 while (cstart
< cend
)
1679 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1686 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1687 char_pred
, SCM_ARG2
, FUNC_NAME
);
1689 while (cstart
< cend
)
1692 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1693 if (scm_is_true (res
))
1699 scm_remember_upto_here_1 (s
);
1703 scm_remember_upto_here_1 (s
);
1704 return scm_from_size_t (cstart
);
1708 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1709 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1710 "Search through the string @var{s} from right to left, returning\n"
1711 "the index of the last occurrence of a character which\n"
1713 "@itemize @bullet\n"
1715 "equals @var{char_pred}, if it is character,\n"
1718 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1721 "is in the set if @var{char_pred} is a character set.\n"
1723 "Return @code{#f} if no match is found.")
1724 #define FUNC_NAME s_scm_string_index_right
1726 size_t cstart
, cend
;
1728 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1731 if (SCM_CHARP (char_pred
))
1733 while (cstart
< cend
)
1736 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1740 else if (SCM_CHARSETP (char_pred
))
1742 while (cstart
< cend
)
1745 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1751 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1752 char_pred
, SCM_ARG2
, FUNC_NAME
);
1754 while (cstart
< cend
)
1758 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1759 if (scm_is_true (res
))
1764 scm_remember_upto_here_1 (s
);
1768 scm_remember_upto_here_1 (s
);
1769 return scm_from_size_t (cend
);
1773 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1774 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1775 "Search through the string @var{s} from right to left, returning\n"
1776 "the index of the last occurrence of a character which\n"
1778 "@itemize @bullet\n"
1780 "equals @var{char_pred}, if it is character,\n"
1783 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1786 "is in the set if @var{char_pred} is a character set.\n"
1788 "Return @code{#f} if no match is found.")
1789 #define FUNC_NAME s_scm_string_rindex
1791 return scm_string_index_right (s
, char_pred
, start
, end
);
1795 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1796 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1797 "Search through the string @var{s} from left to right, returning\n"
1798 "the index of the first occurrence of a character which\n"
1800 "@itemize @bullet\n"
1802 "does not equal @var{char_pred}, if it is character,\n"
1805 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1809 "is not in the set if @var{char_pred} is a character set.\n"
1811 #define FUNC_NAME s_scm_string_skip
1813 size_t cstart
, cend
;
1815 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1818 if (SCM_CHARP (char_pred
))
1820 while (cstart
< cend
)
1822 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1827 else if (SCM_CHARSETP (char_pred
))
1829 while (cstart
< cend
)
1831 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1838 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1839 char_pred
, SCM_ARG2
, FUNC_NAME
);
1841 while (cstart
< cend
)
1844 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1845 if (scm_is_false (res
))
1851 scm_remember_upto_here_1 (s
);
1855 scm_remember_upto_here_1 (s
);
1856 return scm_from_size_t (cstart
);
1861 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1862 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1863 "Search through the string @var{s} from right to left, returning\n"
1864 "the index of the last occurrence of a character which\n"
1866 "@itemize @bullet\n"
1868 "does not equal @var{char_pred}, if it is character,\n"
1871 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1875 "is not in the set if @var{char_pred} is a character set.\n"
1877 #define FUNC_NAME s_scm_string_skip_right
1879 size_t cstart
, cend
;
1881 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1884 if (SCM_CHARP (char_pred
))
1886 while (cstart
< cend
)
1889 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1893 else if (SCM_CHARSETP (char_pred
))
1895 while (cstart
< cend
)
1898 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1904 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1905 char_pred
, SCM_ARG2
, FUNC_NAME
);
1907 while (cstart
< cend
)
1911 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1912 if (scm_is_false (res
))
1917 scm_remember_upto_here_1 (s
);
1921 scm_remember_upto_here_1 (s
);
1922 return scm_from_size_t (cend
);
1928 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1929 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1930 "Return the count of the number of characters in the string\n"
1933 "@itemize @bullet\n"
1935 "equals @var{char_pred}, if it is character,\n"
1938 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1941 "is in the set @var{char_pred}, if it is a character set.\n"
1943 #define FUNC_NAME s_scm_string_count
1945 size_t cstart
, cend
;
1948 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1951 if (SCM_CHARP (char_pred
))
1953 while (cstart
< cend
)
1955 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1960 else if (SCM_CHARSETP (char_pred
))
1962 while (cstart
< cend
)
1964 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1971 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1972 char_pred
, SCM_ARG2
, FUNC_NAME
);
1974 while (cstart
< cend
)
1977 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1978 if (scm_is_true (res
))
1984 scm_remember_upto_here_1 (s
);
1985 return scm_from_size_t (count
);
1990 /* FIXME::martin: This should definitely get implemented more
1991 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1993 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1994 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1995 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1996 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1997 "The optional start/end indices restrict the operation to the\n"
1998 "indicated substrings.")
1999 #define FUNC_NAME s_scm_string_contains
2001 size_t cstart1
, cend1
, cstart2
, cend2
;
2004 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2007 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2010 len2
= cend2
- cstart2
;
2011 if (cend1
- cstart1
>= len2
)
2012 while (cstart1
<= cend1
- len2
)
2018 && (scm_i_string_ref (s1
, i
)
2019 == scm_i_string_ref (s2
, j
)))
2026 scm_remember_upto_here_2 (s1
, s2
);
2027 return scm_from_size_t (cstart1
);
2032 scm_remember_upto_here_2 (s1
, s2
);
2038 /* FIXME::martin: This should definitely get implemented more
2039 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2041 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2042 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2043 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2044 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2045 "The optional start/end indices restrict the operation to the\n"
2046 "indicated substrings. Character comparison is done\n"
2047 "case-insensitively.")
2048 #define FUNC_NAME s_scm_string_contains_ci
2050 size_t cstart1
, cend1
, cstart2
, cend2
;
2053 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2056 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2059 len2
= cend2
- cstart2
;
2060 if (cend1
- cstart1
>= len2
)
2061 while (cstart1
<= cend1
- len2
)
2067 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2068 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2075 scm_remember_upto_here_2 (s1
, s2
);
2076 return scm_from_size_t (cstart1
);
2081 scm_remember_upto_here_2 (s1
, s2
);
2087 /* Helper function for the string uppercase conversion functions. */
2089 string_upcase_x (SCM v
, size_t start
, size_t end
)
2095 v
= scm_i_string_start_writing (v
);
2096 for (k
= start
; k
< end
; ++k
)
2097 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2098 scm_i_string_stop_writing ();
2099 scm_remember_upto_here_1 (v
);
2105 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2106 (SCM str
, SCM start
, SCM end
),
2107 "Destructively upcase every character in @code{str}.\n"
2110 "(string-upcase! y)\n"
2111 "@result{} \"ARRDEFG\"\n"
2113 "@result{} \"ARRDEFG\"\n"
2115 #define FUNC_NAME s_scm_substring_upcase_x
2117 size_t cstart
, cend
;
2119 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2122 return string_upcase_x (str
, cstart
, cend
);
2127 scm_string_upcase_x (SCM str
)
2129 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2132 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2133 (SCM str
, SCM start
, SCM end
),
2134 "Upcase every character in @code{str}.")
2135 #define FUNC_NAME s_scm_substring_upcase
2137 size_t cstart
, cend
;
2139 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2142 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2147 scm_string_upcase (SCM str
)
2149 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2152 /* Helper function for the string lowercase conversion functions.
2153 * No argument checking is performed. */
2155 string_downcase_x (SCM v
, size_t start
, size_t end
)
2161 v
= scm_i_string_start_writing (v
);
2162 for (k
= start
; k
< end
; ++k
)
2163 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2164 scm_i_string_stop_writing ();
2165 scm_remember_upto_here_1 (v
);
2171 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2172 (SCM str
, SCM start
, SCM end
),
2173 "Destructively downcase every character in @var{str}.\n"
2177 "@result{} \"ARRDEFG\"\n"
2178 "(string-downcase! y)\n"
2179 "@result{} \"arrdefg\"\n"
2181 "@result{} \"arrdefg\"\n"
2183 #define FUNC_NAME s_scm_substring_downcase_x
2185 size_t cstart
, cend
;
2187 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2190 return string_downcase_x (str
, cstart
, cend
);
2195 scm_string_downcase_x (SCM str
)
2197 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2200 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2201 (SCM str
, SCM start
, SCM end
),
2202 "Downcase every character in @var{str}.")
2203 #define FUNC_NAME s_scm_substring_downcase
2205 size_t cstart
, cend
;
2207 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2210 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2215 scm_string_downcase (SCM str
)
2217 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2220 /* Helper function for the string capitalization functions.
2221 * No argument checking is performed. */
2223 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2231 str
= scm_i_string_start_writing (str
);
2232 for(i
= start
; i
< end
; i
++)
2234 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2235 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2239 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2244 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2250 scm_i_string_stop_writing ();
2251 scm_remember_upto_here_1 (str
);
2258 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2259 (SCM str
, SCM start
, SCM end
),
2260 "Destructively titlecase every first character in a word in\n"
2262 #define FUNC_NAME s_scm_string_titlecase_x
2264 size_t cstart
, cend
;
2266 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2269 return string_titlecase_x (str
, cstart
, cend
);
2274 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2275 (SCM str
, SCM start
, SCM end
),
2276 "Titlecase every first character in a word in @var{str}.")
2277 #define FUNC_NAME s_scm_string_titlecase
2279 size_t cstart
, cend
;
2281 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2284 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2288 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2290 "Upcase the first character of every word in @var{str}\n"
2291 "destructively and return @var{str}.\n"
2294 "y @result{} \"hello world\"\n"
2295 "(string-capitalize! y) @result{} \"Hello World\"\n"
2296 "y @result{} \"Hello World\"\n"
2298 #define FUNC_NAME s_scm_string_capitalize_x
2300 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2305 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2307 "Return a freshly allocated string with the characters in\n"
2308 "@var{str}, where the first character of every word is\n"
2310 #define FUNC_NAME s_scm_string_capitalize
2312 return scm_string_capitalize_x (scm_string_copy (str
));
2317 /* Reverse the portion of @var{str} between str[cstart] (including)
2318 and str[cend] excluding. */
2320 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2324 str
= scm_i_string_start_writing (str
);
2330 while (cstart
< cend
)
2332 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2333 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2334 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2339 scm_i_string_stop_writing ();
2344 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2345 (SCM str
, SCM start
, SCM end
),
2346 "Reverse the string @var{str}. The optional arguments\n"
2347 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2349 #define FUNC_NAME s_scm_string_reverse
2351 size_t cstart
, cend
;
2354 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2357 result
= scm_string_copy (str
);
2358 string_reverse_x (result
, cstart
, cend
);
2359 scm_remember_upto_here_1 (str
);
2365 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2366 (SCM str
, SCM start
, SCM end
),
2367 "Reverse the string @var{str} in-place. The optional arguments\n"
2368 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2369 "operate on. The return value is unspecified.")
2370 #define FUNC_NAME s_scm_string_reverse_x
2372 size_t cstart
, cend
;
2374 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2378 string_reverse_x (str
, cstart
, cend
);
2379 scm_remember_upto_here_1 (str
);
2380 return SCM_UNSPECIFIED
;
2385 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2387 "Like @code{string-append}, but the result may share memory\n"
2388 "with the argument strings.")
2389 #define FUNC_NAME s_scm_string_append_shared
2391 /* If "rest" contains just one non-empty string, return that.
2392 If it's entirely empty strings, then return scm_nullstr.
2393 Otherwise use scm_string_concatenate. */
2395 SCM ret
= scm_nullstr
;
2396 int seen_nonempty
= 0;
2399 SCM_VALIDATE_REST_ARGUMENT (rest
);
2401 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2404 if (!scm_is_string (s
))
2405 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2406 if (scm_i_string_length (s
) != 0)
2409 /* two or more non-empty strings, need full concat */
2410 return scm_string_append (rest
);
2421 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2423 "Append the elements of @var{ls} (which must be strings)\n"
2424 "together into a single string. Guaranteed to return a freshly\n"
2425 "allocated string.")
2426 #define FUNC_NAME s_scm_string_concatenate
2428 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2429 return scm_string_append (ls
);
2434 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2435 (SCM ls
, SCM final_string
, SCM end
),
2436 "Without optional arguments, this procedure is equivalent to\n"
2439 "(string-concatenate (reverse ls))\n"
2442 "If the optional argument @var{final_string} is specified, it is\n"
2443 "consed onto the beginning to @var{ls} before performing the\n"
2444 "list-reverse and string-concatenate operations. If @var{end}\n"
2445 "is given, only the characters of @var{final_string} up to index\n"
2446 "@var{end} are used.\n"
2448 "Guaranteed to return a freshly allocated string.")
2449 #define FUNC_NAME s_scm_string_concatenate_reverse
2451 if (!SCM_UNBNDP (end
))
2452 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2454 if (!SCM_UNBNDP (final_string
))
2455 ls
= scm_cons (final_string
, ls
);
2457 return scm_string_concatenate (scm_reverse (ls
));
2462 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2464 "Like @code{string-concatenate}, but the result may share memory\n"
2465 "with the strings in the list @var{ls}.")
2466 #define FUNC_NAME s_scm_string_concatenate_shared
2468 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2469 return scm_string_append_shared (ls
);
2474 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2475 (SCM ls
, SCM final_string
, SCM end
),
2476 "Like @code{string-concatenate-reverse}, but the result may\n"
2477 "share memory with the strings in the @var{ls} arguments.")
2478 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2480 /* Just call the non-sharing version. */
2481 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2486 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2487 (SCM proc
, SCM s
, SCM start
, SCM end
),
2488 "@var{proc} is a char->char procedure, it is mapped over\n"
2489 "@var{s}. The order in which the procedure is applied to the\n"
2490 "string elements is not specified.")
2491 #define FUNC_NAME s_scm_string_map
2494 size_t cstart
, cend
;
2497 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2498 proc
, SCM_ARG1
, FUNC_NAME
);
2499 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2502 result
= scm_i_make_string (cend
- cstart
, NULL
, 0);
2504 while (cstart
< cend
)
2506 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2507 if (!SCM_CHARP (ch
))
2508 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2510 result
= scm_i_string_start_writing (result
);
2511 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2512 scm_i_string_stop_writing ();
2521 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2522 (SCM proc
, SCM s
, SCM start
, SCM end
),
2523 "@var{proc} is a char->char procedure, it is mapped over\n"
2524 "@var{s}. The order in which the procedure is applied to the\n"
2525 "string elements is not specified. The string @var{s} is\n"
2526 "modified in-place, the return value is not specified.")
2527 #define FUNC_NAME s_scm_string_map_x
2529 size_t cstart
, cend
;
2531 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2532 proc
, SCM_ARG1
, FUNC_NAME
);
2533 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2536 while (cstart
< cend
)
2538 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2539 if (!SCM_CHARP (ch
))
2540 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2541 s
= scm_i_string_start_writing (s
);
2542 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2543 scm_i_string_stop_writing ();
2546 return SCM_UNSPECIFIED
;
2551 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2552 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2553 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2554 "as the terminating element, from left to right. @var{kons}\n"
2555 "must expect two arguments: The actual character and the last\n"
2556 "result of @var{kons}' application.")
2557 #define FUNC_NAME s_scm_string_fold
2559 size_t cstart
, cend
;
2562 SCM_VALIDATE_PROC (1, kons
);
2563 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2567 while (cstart
< cend
)
2569 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2573 scm_remember_upto_here_1 (s
);
2579 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2580 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2581 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2582 "as the terminating element, from right to left. @var{kons}\n"
2583 "must expect two arguments: The actual character and the last\n"
2584 "result of @var{kons}' application.")
2585 #define FUNC_NAME s_scm_string_fold_right
2587 size_t cstart
, cend
;
2590 SCM_VALIDATE_PROC (1, kons
);
2591 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2595 while (cstart
< cend
)
2597 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2601 scm_remember_upto_here_1 (s
);
2607 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2608 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2609 "@itemize @bullet\n"
2610 "@item @var{g} is used to generate a series of @emph{seed}\n"
2611 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2612 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2614 "@item @var{p} tells us when to stop -- when it returns true\n"
2615 "when applied to one of these seed values.\n"
2616 "@item @var{f} maps each seed value to the corresponding\n"
2617 "character in the result string. These chars are assembled\n"
2618 "into the string in a left-to-right order.\n"
2619 "@item @var{base} is the optional initial/leftmost portion\n"
2620 "of the constructed string; it default to the empty\n"
2622 "@item @var{make_final} is applied to the terminal seed\n"
2623 "value (on which @var{p} returns true) to produce\n"
2624 "the final/rightmost portion of the constructed string.\n"
2625 "It defaults to @code{(lambda (x) "")}.\n"
2627 #define FUNC_NAME s_scm_string_unfold
2631 SCM_VALIDATE_PROC (1, p
);
2632 SCM_VALIDATE_PROC (2, f
);
2633 SCM_VALIDATE_PROC (3, g
);
2634 if (!SCM_UNBNDP (base
))
2636 SCM_VALIDATE_STRING (5, base
);
2640 ans
= scm_i_make_string (0, NULL
, 0);
2641 if (!SCM_UNBNDP (make_final
))
2642 SCM_VALIDATE_PROC (6, make_final
);
2644 res
= scm_call_1 (p
, seed
);
2645 while (scm_is_false (res
))
2649 SCM ch
= scm_call_1 (f
, seed
);
2650 if (!SCM_CHARP (ch
))
2651 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2652 str
= scm_i_make_string (1, NULL
, 0);
2653 str
= scm_i_string_start_writing (str
);
2654 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2655 scm_i_string_stop_writing ();
2658 ans
= scm_string_append (scm_list_2 (ans
, str
));
2659 seed
= scm_call_1 (g
, seed
);
2660 res
= scm_call_1 (p
, seed
);
2662 if (!SCM_UNBNDP (make_final
))
2664 res
= scm_call_1 (make_final
, seed
);
2665 return scm_string_append (scm_list_2 (ans
, res
));
2673 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2674 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2675 "@itemize @bullet\n"
2676 "@item @var{g} is used to generate a series of @emph{seed}\n"
2677 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2678 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2680 "@item @var{p} tells us when to stop -- when it returns true\n"
2681 "when applied to one of these seed values.\n"
2682 "@item @var{f} maps each seed value to the corresponding\n"
2683 "character in the result string. These chars are assembled\n"
2684 "into the string in a right-to-left order.\n"
2685 "@item @var{base} is the optional initial/rightmost portion\n"
2686 "of the constructed string; it default to the empty\n"
2688 "@item @var{make_final} is applied to the terminal seed\n"
2689 "value (on which @var{p} returns true) to produce\n"
2690 "the final/leftmost portion of the constructed string.\n"
2691 "It defaults to @code{(lambda (x) "")}.\n"
2693 #define FUNC_NAME s_scm_string_unfold_right
2697 SCM_VALIDATE_PROC (1, p
);
2698 SCM_VALIDATE_PROC (2, f
);
2699 SCM_VALIDATE_PROC (3, g
);
2700 if (!SCM_UNBNDP (base
))
2702 SCM_VALIDATE_STRING (5, base
);
2706 ans
= scm_i_make_string (0, NULL
, 0);
2707 if (!SCM_UNBNDP (make_final
))
2708 SCM_VALIDATE_PROC (6, make_final
);
2710 res
= scm_call_1 (p
, seed
);
2711 while (scm_is_false (res
))
2715 SCM ch
= scm_call_1 (f
, seed
);
2716 if (!SCM_CHARP (ch
))
2717 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2718 str
= scm_i_make_string (1, NULL
, 0);
2719 str
= scm_i_string_start_writing (str
);
2720 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2721 scm_i_string_stop_writing ();
2724 ans
= scm_string_append (scm_list_2 (str
, ans
));
2725 seed
= scm_call_1 (g
, seed
);
2726 res
= scm_call_1 (p
, seed
);
2728 if (!SCM_UNBNDP (make_final
))
2730 res
= scm_call_1 (make_final
, seed
);
2731 return scm_string_append (scm_list_2 (res
, ans
));
2739 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2740 (SCM proc
, SCM s
, SCM start
, SCM end
),
2741 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2742 "return value is not specified.")
2743 #define FUNC_NAME s_scm_string_for_each
2745 size_t cstart
, cend
;
2747 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2748 proc
, SCM_ARG1
, FUNC_NAME
);
2749 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2752 while (cstart
< cend
)
2754 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2758 scm_remember_upto_here_1 (s
);
2759 return SCM_UNSPECIFIED
;
2763 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2764 (SCM proc
, SCM s
, SCM start
, SCM end
),
2765 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2768 "For example, to change characters to alternately upper and\n"
2772 "(define str (string-copy \"studly\"))\n"
2773 "(string-for-each-index\n"
2775 " (string-set! str i\n"
2776 " ((if (even? i) char-upcase char-downcase)\n"
2777 " (string-ref str i))))\n"
2779 "str @result{} \"StUdLy\"\n"
2781 #define FUNC_NAME s_scm_string_for_each_index
2783 size_t cstart
, cend
;
2785 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2786 proc
, SCM_ARG1
, FUNC_NAME
);
2787 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2791 while (cstart
< cend
)
2793 scm_call_1 (proc
, scm_from_size_t (cstart
));
2797 scm_remember_upto_here_1 (s
);
2798 return SCM_UNSPECIFIED
;
2802 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2803 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2804 "This is the @emph{extended substring} procedure that implements\n"
2805 "replicated copying of a substring of some string.\n"
2807 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2808 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2809 "0 and the length of @var{s}. Replicate this substring up and\n"
2810 "down index space, in both the positive and negative directions.\n"
2811 "@code{xsubstring} returns the substring of this string\n"
2812 "beginning at index @var{from}, and ending at @var{to}, which\n"
2813 "defaults to @var{from} + (@var{end} - @var{start}).")
2814 #define FUNC_NAME s_scm_xsubstring
2817 size_t cstart
, cend
;
2821 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2825 cfrom
= scm_to_int (from
);
2826 if (SCM_UNBNDP (to
))
2827 cto
= cfrom
+ (cend
- cstart
);
2829 cto
= scm_to_int (to
);
2830 if (cstart
== cend
&& cfrom
!= cto
)
2831 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2833 result
= scm_i_make_string (cto
- cfrom
, NULL
, 0);
2834 result
= scm_i_string_start_writing (result
);
2839 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2841 scm_i_string_set_x (result
, p
,
2842 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2844 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2848 scm_i_string_stop_writing ();
2850 scm_remember_upto_here_1 (s
);
2856 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2857 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2858 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2859 "is written into the string @var{target} starting at index\n"
2860 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2861 "@var{target} @var{s})} or these arguments share storage -- you\n"
2862 "cannot copy a string on top of itself.")
2863 #define FUNC_NAME s_scm_string_xcopy_x
2866 size_t ctstart
, cstart
, cend
;
2868 SCM dummy
= SCM_UNDEFINED
;
2871 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2874 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2877 csfrom
= scm_to_int (sfrom
);
2878 if (SCM_UNBNDP (sto
))
2879 csto
= csfrom
+ (cend
- cstart
);
2881 csto
= scm_to_int (sto
);
2885 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2886 SCM_ASSERT_RANGE (1, tstart
,
2887 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2890 target
= scm_i_string_start_writing (target
);
2891 while (csfrom
< csto
)
2893 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2895 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2897 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2901 scm_i_string_stop_writing ();
2903 scm_remember_upto_here_2 (target
, s
);
2905 return SCM_UNSPECIFIED
;
2910 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2911 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2912 "Return the string @var{s1}, but with the characters\n"
2913 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2914 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2915 #define FUNC_NAME s_scm_string_replace
2917 size_t cstart1
, cend1
, cstart2
, cend2
;
2920 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2923 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2926 return (scm_string_append
2927 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2928 scm_i_substring (s2
, cstart2
, cend2
),
2929 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2935 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2936 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2937 "Split the string @var{s} into a list of substrings, where each\n"
2938 "substring is a maximal non-empty contiguous sequence of\n"
2939 "characters from the character set @var{token_set}, which\n"
2940 "defaults to @code{char-set:graphic}.\n"
2941 "If @var{start} or @var{end} indices are provided, they restrict\n"
2942 "@code{string-tokenize} to operating on the indicated substring\n"
2944 #define FUNC_NAME s_scm_string_tokenize
2946 size_t cstart
, cend
;
2947 SCM result
= SCM_EOL
;
2949 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2953 if (SCM_UNBNDP (token_set
))
2954 token_set
= scm_char_set_graphic
;
2956 if (SCM_CHARSETP (token_set
))
2960 while (cstart
< cend
)
2962 while (cstart
< cend
)
2964 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2971 while (cstart
< cend
)
2973 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2977 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2981 SCM_WRONG_TYPE_ARG (2, token_set
);
2983 scm_remember_upto_here_1 (s
);
2988 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2989 (SCM str
, SCM char_pred
),
2990 "Split the string @var{str} into a list of the substrings delimited\n"
2991 "by appearances of characters that\n"
2993 "@itemize @bullet\n"
2995 "equal @var{char_pred}, if it is a character,\n"
2998 "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
3001 "are in the set @var{char_pred}, if it is a character set.\n"
3003 "Note that an empty substring between separator characters\n"
3004 "will result in an empty string in the result list.\n"
3007 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3009 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3011 "(string-split \"::\" #\\:)\n"
3013 "(\"\" \"\" \"\")\n"
3015 "(string-split \"\" #\\:)\n"
3019 #define FUNC_NAME s_scm_string_split
3023 SCM_VALIDATE_STRING (1, str
);
3025 if (SCM_CHARP (char_pred
))
3030 /* This is explicit wide/narrow logic (instead of using
3031 scm_i_string_ref) is a speed optimization. */
3032 idx
= scm_i_string_length (str
);
3033 narrow
= scm_i_is_narrow_string (str
);
3036 const char *buf
= scm_i_string_chars (str
);
3040 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(char_pred
))
3044 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3051 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3055 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(char_pred
))
3059 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3067 SCM sidx
, slast_idx
;
3069 if (!SCM_CHARSETP (char_pred
))
3070 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3071 char_pred
, SCM_ARG2
, FUNC_NAME
);
3073 /* Supporting predicates and character sets involves handling SCM
3074 values so there is less chance to optimize. */
3075 slast_idx
= scm_string_length (str
);
3078 sidx
= scm_string_index_right (str
, char_pred
, SCM_INUM0
, slast_idx
);
3079 if (scm_is_false (sidx
))
3081 res
= scm_cons (scm_substring (str
, scm_oneplus (sidx
), slast_idx
), res
);
3085 res
= scm_cons (scm_substring (str
, SCM_INUM0
, slast_idx
), res
);
3088 scm_remember_upto_here_1 (str
);
3094 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3095 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3096 "Filter the string @var{s}, retaining only those characters\n"
3097 "which satisfy @var{char_pred}.\n"
3099 "If @var{char_pred} is a procedure, it is applied to each\n"
3100 "character as a predicate, if it is a character, it is tested\n"
3101 "for equality and if it is a character set, it is tested for\n"
3103 #define FUNC_NAME s_scm_string_filter
3105 size_t cstart
, cend
;
3109 #if SCM_ENABLE_DEPRECATED == 1
3110 if (scm_is_string (char_pred
))
3114 scm_c_issue_deprecation_warning
3115 ("Guile used to use the wrong argument order for string-filter.\n"
3116 "This call to string-filter had the arguments in the wrong order.\n"
3117 "See SRFI-13 for more details. At some point we will remove this hack.");
3125 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3129 /* The explicit loops below stripping leading and trailing non-matches
3130 mean we can return a substring if those are the only deletions, making
3131 string-filter as efficient as string-trim-both in that case. */
3133 if (SCM_CHARP (char_pred
))
3137 /* strip leading non-matches by incrementing cstart */
3138 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3141 /* strip trailing non-matches by decrementing cend */
3142 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3145 /* count chars to keep */
3147 for (idx
= cstart
; idx
< cend
; idx
++)
3148 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3151 if (count
== cend
- cstart
)
3153 /* whole of cstart to cend is to be kept, return a copy-on-write
3156 result
= scm_i_substring (s
, cstart
, cend
);
3159 result
= scm_c_make_string (count
, char_pred
);
3161 else if (SCM_CHARSETP (char_pred
))
3165 /* strip leading non-matches by incrementing cstart */
3166 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3169 /* strip trailing non-matches by decrementing cend */
3170 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3173 /* count chars to be kept */
3175 for (idx
= cstart
; idx
< cend
; idx
++)
3176 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3179 /* if whole of start to end kept then return substring */
3180 if (count
== cend
- cstart
)
3181 goto result_substring
;
3185 result
= scm_i_make_string (count
, NULL
, 0);
3186 result
= scm_i_string_start_writing (result
);
3188 /* decrement "count" in this loop as well as using idx, so that if
3189 another thread is simultaneously changing "s" there's no chance
3190 it'll make us copy more than count characters */
3191 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3193 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3195 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3200 scm_i_string_stop_writing ();
3207 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3208 char_pred
, SCM_ARG1
, FUNC_NAME
);
3213 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3214 res
= scm_call_1 (char_pred
, ch
);
3215 if (scm_is_true (res
))
3216 ls
= scm_cons (ch
, ls
);
3219 result
= scm_reverse_list_to_string (ls
);
3222 scm_remember_upto_here_1 (s
);
3228 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3229 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3230 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3232 "If @var{char_pred} is a procedure, it is applied to each\n"
3233 "character as a predicate, if it is a character, it is tested\n"
3234 "for equality and if it is a character set, it is tested for\n"
3236 #define FUNC_NAME s_scm_string_delete
3238 size_t cstart
, cend
;
3242 #if SCM_ENABLE_DEPRECATED == 1
3243 if (scm_is_string (char_pred
))
3247 scm_c_issue_deprecation_warning
3248 ("Guile used to use the wrong argument order for string-delete.\n"
3249 "This call to string-filter had the arguments in the wrong order.\n"
3250 "See SRFI-13 for more details. At some point we will remove this hack.");
3258 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3262 /* The explicit loops below stripping leading and trailing matches mean we
3263 can return a substring if those are the only deletions, making
3264 string-delete as efficient as string-trim-both in that case. */
3266 if (SCM_CHARP (char_pred
))
3270 /* strip leading matches by incrementing cstart */
3271 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3274 /* strip trailing matches by decrementing cend */
3275 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3278 /* count chars to be kept */
3280 for (idx
= cstart
; idx
< cend
; idx
++)
3281 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3284 if (count
== cend
- cstart
)
3286 /* whole of cstart to cend is to be kept, return a copy-on-write
3289 result
= scm_i_substring (s
, cstart
, cend
);
3294 /* new string for retained portion */
3295 result
= scm_i_make_string (count
, NULL
, 0);
3296 result
= scm_i_string_start_writing (result
);
3297 /* decrement "count" in this loop as well as using idx, so that if
3298 another thread is simultaneously changing "s" there's no chance
3299 it'll make us copy more than count characters */
3300 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3302 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3303 if (c
!= SCM_CHAR (char_pred
))
3305 scm_i_string_set_x (result
, i
, c
);
3310 scm_i_string_stop_writing ();
3313 else if (SCM_CHARSETP (char_pred
))
3317 /* strip leading matches by incrementing cstart */
3318 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3321 /* strip trailing matches by decrementing cend */
3322 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3325 /* count chars to be kept */
3327 for (idx
= cstart
; idx
< cend
; idx
++)
3328 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3331 if (count
== cend
- cstart
)
3332 goto result_substring
;
3336 /* new string for retained portion */
3337 result
= scm_i_make_string (count
, NULL
, 0);
3338 result
= scm_i_string_start_writing (result
);
3340 /* decrement "count" in this loop as well as using idx, so that if
3341 another thread is simultaneously changing "s" there's no chance
3342 it'll make us copy more than count characters */
3343 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3345 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3347 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3352 scm_i_string_stop_writing ();
3358 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3359 char_pred
, SCM_ARG1
, FUNC_NAME
);
3364 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3365 res
= scm_call_1 (char_pred
, ch
);
3366 if (scm_is_false (res
))
3367 ls
= scm_cons (ch
, ls
);
3370 result
= scm_reverse_list_to_string (ls
);
3373 scm_remember_upto_here_1 (s
);
3379 scm_init_srfi_13 (void)
3381 #include "libguile/srfi-13.x"
3384 /* End of srfi-13.c. */