1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008 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
31 #include "libguile/srfi-13.h"
32 #include "libguile/srfi-14.h"
34 /* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
35 messing with the internal representation of strings. We define our
36 own version since we use it so much and are messing with Guile
40 #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
41 pos_start, start, c_start, \
42 pos_end, end, c_end) \
44 SCM_VALIDATE_STRING (pos_str, str); \
45 c_str = scm_i_string_chars (str); \
46 scm_i_get_substring_spec (scm_i_string_length (str), \
47 start, &c_start, end, &c_end); \
50 /* Expecting "unsigned char *c_str" */
51 #define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
52 pos_start, start, c_start, \
53 pos_end, end, c_end) \
55 const char *signed_c_str; \
56 MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
57 pos_start, start, c_start, \
58 pos_end, end, c_end); \
59 c_str = (unsigned char *) signed_c_str; \
62 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
63 pos_start, start, c_start, \
64 pos_end, end, c_end) \
66 SCM_VALIDATE_STRING (pos_str, str); \
67 scm_i_get_substring_spec (scm_i_string_length (str), \
68 start, &c_start, end, &c_end); \
71 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
73 "Return @code{#t} if @var{str}'s length is zero, and\n"
74 "@code{#f} otherwise.\n"
76 "(string-null? \"\") @result{} #t\n"
77 "y @result{} \"foo\"\n"
78 "(string-null? y) @result{} #f\n"
80 #define FUNC_NAME s_scm_string_null_p
82 SCM_VALIDATE_STRING (1, str
);
83 return scm_from_bool (scm_i_string_length (str
) == 0);
91 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
95 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
96 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
97 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
99 "@var{char_pred} can be a character to check for any equal to that, or\n"
100 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
101 "or a predicate procedure to call.\n"
103 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
104 "successively on the characters from @var{start} to @var{end}. If\n"
105 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
106 "stops and that return value is the return from @code{string-any}. The\n"
107 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
108 "point is reached, is a tail call.\n"
110 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
111 "@var{end}) then the return is @code{#f}.\n")
112 #define FUNC_NAME s_scm_string_any
116 SCM res
= SCM_BOOL_F
;
118 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
122 if (SCM_CHARP (char_pred
))
124 res
= (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
126 ? SCM_BOOL_F
: SCM_BOOL_T
);
128 else if (SCM_CHARSETP (char_pred
))
131 for (i
= cstart
; i
< cend
; i
++)
132 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
140 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
141 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
143 while (cstart
< cend
)
145 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
146 if (scm_is_true (res
))
148 cstr
= scm_i_string_chars (s
);
153 scm_remember_upto_here_1 (s
);
159 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
160 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
161 "Check if @var{char_pred} is true for every character in string\n"
164 "@var{char_pred} can be a character to check for every character equal\n"
165 "to that, or a character set (@pxref{Character Sets}) to check for\n"
166 "every character being in that set, or a predicate procedure to call.\n"
168 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
169 "successively on the characters from @var{start} to @var{end}. If\n"
170 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
171 "returns @code{#f}. The call on the last character (ie.@: at\n"
172 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
173 "return from that call is the return from @code{string-every}.\n"
175 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
176 "@var{end}) then the return is @code{#t}.\n")
177 #define FUNC_NAME s_scm_string_every
181 SCM res
= SCM_BOOL_T
;
183 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
186 if (SCM_CHARP (char_pred
))
188 char cchr
= SCM_CHAR (char_pred
);
190 for (i
= cstart
; i
< cend
; i
++)
197 else if (SCM_CHARSETP (char_pred
))
200 for (i
= cstart
; i
< cend
; i
++)
201 if (!SCM_CHARSET_GET (char_pred
, cstr
[i
]))
209 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
210 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
212 while (cstart
< cend
)
214 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
215 if (scm_is_false (res
))
217 cstr
= scm_i_string_chars (s
);
222 scm_remember_upto_here_1 (s
);
228 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
230 "@var{proc} is an integer->char procedure. Construct a string\n"
231 "of size @var{len} by applying @var{proc} to each index to\n"
232 "produce the corresponding string element. The order in which\n"
233 "@var{proc} is applied to the indices is not specified.")
234 #define FUNC_NAME s_scm_string_tabulate
240 scm_t_trampoline_1 proc_tramp
;
242 proc_tramp
= scm_trampoline_1 (proc
);
243 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
245 clen
= scm_to_size_t (len
);
246 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
248 res
= scm_i_make_string (clen
, &p
);
252 /* The RES string remains untouched since nobody knows about it
253 yet. No need to refetch P.
255 ch
= proc_tramp (proc
, scm_from_size_t (i
));
257 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
258 *p
++ = SCM_CHAR (ch
);
266 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
267 (SCM str
, SCM start
, SCM end
),
268 "Convert the string @var{str} into a list of characters.")
269 #define FUNC_NAME s_scm_substring_to_list
273 SCM result
= SCM_EOL
;
275 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
278 while (cstart
< cend
)
281 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
282 cstr
= scm_i_string_chars (str
);
284 scm_remember_upto_here_1 (str
);
289 /* We export scm_substring_to_list as "string->list" since it is
290 compatible and more general. This function remains for the benefit
291 of C code that used it.
295 scm_string_to_list (SCM str
)
297 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
300 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
302 "An efficient implementation of @code{(compose string->list\n"
306 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
308 #define FUNC_NAME s_scm_reverse_list_to_string
311 long i
= scm_ilength (chrs
);
315 SCM_WRONG_TYPE_ARG (1, chrs
);
316 result
= scm_i_make_string (i
, &data
);
321 while (i
> 0 && scm_is_pair (chrs
))
323 SCM elt
= SCM_CAR (chrs
);
325 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
327 *data
= SCM_CHAR (elt
);
328 chrs
= SCM_CDR (chrs
);
338 SCM_SYMBOL (scm_sym_infix
, "infix");
339 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
340 SCM_SYMBOL (scm_sym_suffix
, "suffix");
341 SCM_SYMBOL (scm_sym_prefix
, "prefix");
344 append_string (char **sp
, size_t *lp
, SCM str
)
347 len
= scm_c_string_length (str
);
350 memcpy (*sp
, scm_i_string_chars (str
), len
);
355 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
356 (SCM ls
, SCM delimiter
, SCM grammar
),
357 "Append the string in the string list @var{ls}, using the string\n"
358 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
359 "@var{grammar} is a symbol which specifies how the delimiter is\n"
360 "placed between the strings, and defaults to the symbol\n"
365 "Insert the separator between list elements. An empty string\n"
366 "will produce an empty list.\n"
367 "@item string-infix\n"
368 "Like @code{infix}, but will raise an error if given the empty\n"
371 "Insert the separator after every list element.\n"
373 "Insert the separator before each list element.\n"
375 #define FUNC_NAME s_scm_string_join
378 #define GRAM_STRICT_INFIX 1
379 #define GRAM_SUFFIX 2
380 #define GRAM_PREFIX 3
383 int gram
= GRAM_INFIX
;
387 long strings
= scm_ilength (ls
);
389 /* Validate the string list. */
391 SCM_WRONG_TYPE_ARG (1, ls
);
393 /* Validate the delimiter and record its length. */
394 if (SCM_UNBNDP (delimiter
))
396 delimiter
= scm_from_locale_string (" ");
400 del_len
= scm_c_string_length (delimiter
);
402 /* Validate the grammar symbol and remember the grammar. */
403 if (SCM_UNBNDP (grammar
))
405 else if (scm_is_eq (grammar
, scm_sym_infix
))
407 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
408 gram
= GRAM_STRICT_INFIX
;
409 else if (scm_is_eq (grammar
, scm_sym_suffix
))
411 else if (scm_is_eq (grammar
, scm_sym_prefix
))
414 SCM_WRONG_TYPE_ARG (3, grammar
);
416 /* Check grammar constraints and calculate the space required for
421 if (!scm_is_null (ls
))
422 len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
424 case GRAM_STRICT_INFIX
:
426 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
428 len
= (strings
- 1) * del_len
;
431 len
= strings
* del_len
;
436 while (scm_is_pair (tmp
))
438 len
+= scm_c_string_length (SCM_CAR (tmp
));
442 result
= scm_i_make_string (len
, &p
);
448 case GRAM_STRICT_INFIX
:
449 while (scm_is_pair (tmp
))
451 append_string (&p
, &len
, SCM_CAR (tmp
));
452 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
453 append_string (&p
, &len
, delimiter
);
458 while (scm_is_pair (tmp
))
460 append_string (&p
, &len
, SCM_CAR (tmp
));
462 append_string (&p
, &len
, delimiter
);
467 while (scm_is_pair (tmp
))
470 append_string (&p
, &len
, delimiter
);
471 append_string (&p
, &len
, SCM_CAR (tmp
));
479 #undef GRAM_STRICT_INFIX
486 /* There are a number of functions to consider here for Scheme and C:
488 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
489 substring/copy STR start [end] ;; Guile variant of R5RS substring
491 scm_string_copy (str) ;; Old function from Guile
492 scm_substring_copy (str, [start, [end]])
493 ;; C version of SRFI-13 string-copy
494 ;; and C version of substring/copy
496 The C function underlying string-copy is not exported to C
497 programs. scm_substring_copy is defined in strings.c as the
498 underlying function of substring/copy and allows an optional START
502 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
504 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
505 (SCM str
, SCM start
, SCM end
),
506 "Return a freshly allocated copy of the string @var{str}. If\n"
507 "given, @var{start} and @var{end} delimit the portion of\n"
508 "@var{str} which is copied.")
509 #define FUNC_NAME s_scm_srfi13_substring_copy
514 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
517 return scm_c_substring_copy (str
, cstart
, cend
);
522 scm_string_copy (SCM str
)
524 return scm_c_substring (str
, 0, scm_c_string_length (str
));
527 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
528 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
529 "Copy the sequence of characters from index range [@var{start},\n"
530 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
531 "at index @var{tstart}. The characters are copied left-to-right\n"
532 "or right-to-left as needed -- the copy is guaranteed to work,\n"
533 "even if @var{target} and @var{s} are the same string. It is an\n"
534 "error if the copy operation runs off the end of the target\n"
536 #define FUNC_NAME s_scm_string_copy_x
540 size_t cstart
, cend
, ctstart
, dummy
, len
;
541 SCM sdummy
= SCM_UNDEFINED
;
543 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
546 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
550 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
552 target
= scm_i_string_start_writing (target
);
553 ctarget
= scm_i_string_writable_chars (target
);
554 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
555 scm_i_string_stop_writing ();
556 scm_remember_upto_here_1 (target
);
558 return SCM_UNSPECIFIED
;
562 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
563 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
564 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
565 "into @var{str2} beginning at position @var{start2}.\n"
566 "@var{str1} and @var{str2} can be the same string.")
567 #define FUNC_NAME s_scm_substring_move_x
569 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
573 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
575 "Return the @var{n} first characters of @var{s}.")
576 #define FUNC_NAME s_scm_string_take
578 return scm_substring (s
, SCM_INUM0
, n
);
583 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
585 "Return all but the first @var{n} characters of @var{s}.")
586 #define FUNC_NAME s_scm_string_drop
588 return scm_substring (s
, n
, SCM_UNDEFINED
);
593 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
595 "Return the @var{n} last characters of @var{s}.")
596 #define FUNC_NAME s_scm_string_take_right
598 return scm_substring (s
,
599 scm_difference (scm_string_length (s
), n
),
605 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
607 "Return all but the last @var{n} characters of @var{s}.")
608 #define FUNC_NAME s_scm_string_drop_right
610 return scm_substring (s
,
612 scm_difference (scm_string_length (s
), n
));
617 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
618 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
619 "Take that characters from @var{start} to @var{end} from the\n"
620 "string @var{s} and return a new string, right-padded by the\n"
621 "character @var{chr} to length @var{len}. If the resulting\n"
622 "string is longer than @var{len}, it is truncated on the right.")
623 #define FUNC_NAME s_scm_string_pad
626 size_t cstart
, cend
, clen
;
628 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
631 clen
= scm_to_size_t (len
);
633 if (SCM_UNBNDP (chr
))
637 SCM_VALIDATE_CHAR (3, chr
);
638 cchr
= SCM_CHAR (chr
);
640 if (clen
< (cend
- cstart
))
641 return scm_c_substring (s
, cend
- clen
, cend
);
647 result
= scm_i_make_string (clen
, &dst
);
648 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
649 memmove (dst
+ clen
- (cend
- cstart
),
650 scm_i_string_chars (s
) + cstart
, cend
- cstart
);
657 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
658 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
659 "Take that characters from @var{start} to @var{end} from the\n"
660 "string @var{s} and return a new string, left-padded by the\n"
661 "character @var{chr} to length @var{len}. If the resulting\n"
662 "string is longer than @var{len}, it is truncated on the left.")
663 #define FUNC_NAME s_scm_string_pad_right
666 size_t cstart
, cend
, clen
;
668 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
671 clen
= scm_to_size_t (len
);
673 if (SCM_UNBNDP (chr
))
677 SCM_VALIDATE_CHAR (3, chr
);
678 cchr
= SCM_CHAR (chr
);
680 if (clen
< (cend
- cstart
))
681 return scm_c_substring (s
, cstart
, cstart
+ clen
);
687 result
= scm_i_make_string (clen
, &dst
);
688 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
689 memmove (dst
, scm_i_string_chars (s
) + cstart
, cend
- cstart
);
696 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
697 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
698 "Trim @var{s} by skipping over all characters on the left\n"
699 "that satisfy the parameter @var{char_pred}:\n"
703 "if it is the character @var{ch}, characters equal to\n"
704 "@var{ch} are trimmed,\n"
707 "if it is a procedure @var{pred} characters that\n"
708 "satisfy @var{pred} are trimmed,\n"
711 "if it is a character set, characters in that set are trimmed.\n"
714 "If called without a @var{char_pred} argument, all whitespace is\n"
716 #define FUNC_NAME s_scm_string_trim
721 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
724 if (SCM_UNBNDP (char_pred
))
726 while (cstart
< cend
)
728 if (!isspace((int) (unsigned char) cstr
[cstart
]))
733 else if (SCM_CHARP (char_pred
))
735 char chr
= SCM_CHAR (char_pred
);
736 while (cstart
< cend
)
738 if (chr
!= cstr
[cstart
])
743 else if (SCM_CHARSETP (char_pred
))
745 while (cstart
< cend
)
747 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
754 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
755 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
757 while (cstart
< cend
)
761 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
762 if (scm_is_false (res
))
764 cstr
= scm_i_string_chars (s
);
768 return scm_c_substring (s
, cstart
, cend
);
773 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
774 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
775 "Trim @var{s} by skipping over all characters on the rightt\n"
776 "that satisfy the parameter @var{char_pred}:\n"
780 "if it is the character @var{ch}, characters equal to @var{ch}\n"
784 "if it is a procedure @var{pred} characters that satisfy\n"
785 "@var{pred} are trimmed,\n"
788 "if it is a character sets, all characters in that set are\n"
792 "If called without a @var{char_pred} argument, all whitespace is\n"
794 #define FUNC_NAME s_scm_string_trim_right
799 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
802 if (SCM_UNBNDP (char_pred
))
804 while (cstart
< cend
)
806 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
811 else if (SCM_CHARP (char_pred
))
813 char chr
= SCM_CHAR (char_pred
);
814 while (cstart
< cend
)
816 if (chr
!= cstr
[cend
- 1])
821 else if (SCM_CHARSETP (char_pred
))
823 while (cstart
< cend
)
825 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
832 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
833 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
835 while (cstart
< cend
)
839 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
840 if (scm_is_false (res
))
842 cstr
= scm_i_string_chars (s
);
846 return scm_c_substring (s
, cstart
, cend
);
851 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
852 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
853 "Trim @var{s} by skipping over all characters on both sides of\n"
854 "the string that satisfy the parameter @var{char_pred}:\n"
858 "if it is the character @var{ch}, characters equal to @var{ch}\n"
862 "if it is a procedure @var{pred} characters that satisfy\n"
863 "@var{pred} are trimmed,\n"
866 "if it is a character set, the characters in the set are\n"
870 "If called without a @var{char_pred} argument, all whitespace is\n"
872 #define FUNC_NAME s_scm_string_trim_both
877 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
880 if (SCM_UNBNDP (char_pred
))
882 while (cstart
< cend
)
884 if (!isspace((int) (unsigned char) cstr
[cstart
]))
888 while (cstart
< cend
)
890 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
895 else if (SCM_CHARP (char_pred
))
897 char chr
= SCM_CHAR (char_pred
);
898 while (cstart
< cend
)
900 if (chr
!= cstr
[cstart
])
904 while (cstart
< cend
)
906 if (chr
!= cstr
[cend
- 1])
911 else if (SCM_CHARSETP (char_pred
))
913 while (cstart
< cend
)
915 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
919 while (cstart
< cend
)
921 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
928 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
929 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
931 while (cstart
< cend
)
935 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
936 if (scm_is_false (res
))
938 cstr
= scm_i_string_chars (s
);
941 while (cstart
< cend
)
945 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
946 if (scm_is_false (res
))
948 cstr
= scm_i_string_chars (s
);
952 return scm_c_substring (s
, cstart
, cend
);
957 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
958 (SCM str
, SCM chr
, SCM start
, SCM end
),
959 "Stores @var{chr} in every element of the given @var{str} and\n"
960 "returns an unspecified value.")
961 #define FUNC_NAME s_scm_substring_fill_x
968 /* Older versions of Guile provided the function
969 scm_substring_fill_x with the following order of arguments:
973 We accomodate this here by detecting such a usage and reordering
984 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
987 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
989 str
= scm_i_string_start_writing (str
);
990 cstr
= scm_i_string_writable_chars (str
);
991 for (k
= cstart
; k
< cend
; k
++)
993 scm_i_string_stop_writing ();
994 scm_remember_upto_here_1 (str
);
996 return SCM_UNSPECIFIED
;
1001 scm_string_fill_x (SCM str
, SCM chr
)
1003 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
1006 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
1007 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1008 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1009 "mismatch index, depending upon whether @var{s1} is less than,\n"
1010 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1011 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1012 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1013 "@var{i} is the first position that does not match.")
1014 #define FUNC_NAME s_scm_string_compare
1016 const unsigned char *cstr1
, *cstr2
;
1017 size_t cstart1
, cend1
, cstart2
, cend2
;
1020 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1023 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1026 SCM_VALIDATE_PROC (3, proc_lt
);
1027 SCM_VALIDATE_PROC (4, proc_eq
);
1028 SCM_VALIDATE_PROC (5, proc_gt
);
1030 while (cstart1
< cend1
&& cstart2
< cend2
)
1032 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1037 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1045 if (cstart1
< cend1
)
1047 else if (cstart2
< cend2
)
1053 scm_remember_upto_here_2 (s1
, s2
);
1054 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1059 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1060 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1061 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1062 "mismatch index, depending upon whether @var{s1} is less than,\n"
1063 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1064 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1065 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1066 "@var{i} is the first position that does not match. The\n"
1067 "character comparison is done case-insensitively.")
1068 #define FUNC_NAME s_scm_string_compare_ci
1070 const unsigned char *cstr1
, *cstr2
;
1071 size_t cstart1
, cend1
, cstart2
, cend2
;
1074 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1077 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1080 SCM_VALIDATE_PROC (3, proc_lt
);
1081 SCM_VALIDATE_PROC (4, proc_eq
);
1082 SCM_VALIDATE_PROC (5, proc_gt
);
1084 while (cstart1
< cend1
&& cstart2
< cend2
)
1086 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1091 else if (scm_c_downcase (cstr1
[cstart1
])
1092 > scm_c_downcase (cstr2
[cstart2
]))
1101 if (cstart1
< cend1
)
1103 else if (cstart2
< cend2
)
1109 scm_remember_upto_here (s1
, s2
);
1110 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1115 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1116 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1117 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1119 #define FUNC_NAME s_scm_string_eq
1121 const char *cstr1
, *cstr2
;
1122 size_t cstart1
, cend1
, cstart2
, cend2
;
1124 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1127 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1131 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1134 while (cstart1
< cend1
)
1136 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1138 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1144 scm_remember_upto_here_2 (s1
, s2
);
1145 return scm_from_size_t (cstart1
);
1148 scm_remember_upto_here_2 (s1
, s2
);
1154 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1155 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1156 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1158 #define FUNC_NAME s_scm_string_neq
1160 const char *cstr1
, *cstr2
;
1161 size_t cstart1
, cend1
, cstart2
, cend2
;
1163 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1166 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1170 while (cstart1
< cend1
&& cstart2
< cend2
)
1172 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1174 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1179 if (cstart1
< cend1
)
1181 else if (cstart2
< cend2
)
1187 scm_remember_upto_here_2 (s1
, s2
);
1188 return scm_from_size_t (cstart1
);
1191 scm_remember_upto_here_2 (s1
, s2
);
1197 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1198 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1199 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1200 "true value otherwise.")
1201 #define FUNC_NAME s_scm_string_lt
1203 const unsigned char *cstr1
, *cstr2
;
1204 size_t cstart1
, cend1
, cstart2
, cend2
;
1206 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1209 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1213 while (cstart1
< cend1
&& cstart2
< cend2
)
1215 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1217 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1222 if (cstart1
< cend1
)
1224 else if (cstart2
< cend2
)
1230 scm_remember_upto_here_2 (s1
, s2
);
1231 return scm_from_size_t (cstart1
);
1234 scm_remember_upto_here_2 (s1
, s2
);
1240 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1241 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1242 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1243 "true value otherwise.")
1244 #define FUNC_NAME s_scm_string_gt
1246 const unsigned char *cstr1
, *cstr2
;
1247 size_t cstart1
, cend1
, cstart2
, cend2
;
1249 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1252 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1256 while (cstart1
< cend1
&& cstart2
< cend2
)
1258 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1260 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1265 if (cstart1
< cend1
)
1267 else if (cstart2
< cend2
)
1273 scm_remember_upto_here_2 (s1
, s2
);
1274 return scm_from_size_t (cstart1
);
1277 scm_remember_upto_here_2 (s1
, s2
);
1283 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1284 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1285 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1287 #define FUNC_NAME s_scm_string_le
1289 const unsigned char *cstr1
, *cstr2
;
1290 size_t cstart1
, cend1
, cstart2
, cend2
;
1292 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1295 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1299 while (cstart1
< cend1
&& cstart2
< cend2
)
1301 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1303 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1308 if (cstart1
< cend1
)
1310 else if (cstart2
< cend2
)
1316 scm_remember_upto_here_2 (s1
, s2
);
1317 return scm_from_size_t (cstart1
);
1320 scm_remember_upto_here_2 (s1
, s2
);
1326 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1327 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1328 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1330 #define FUNC_NAME s_scm_string_ge
1332 const unsigned char *cstr1
, *cstr2
;
1333 size_t cstart1
, cend1
, cstart2
, cend2
;
1335 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1338 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1342 while (cstart1
< cend1
&& cstart2
< cend2
)
1344 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1346 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1351 if (cstart1
< cend1
)
1353 else if (cstart2
< cend2
)
1359 scm_remember_upto_here_2 (s1
, s2
);
1360 return scm_from_size_t (cstart1
);
1363 scm_remember_upto_here_2 (s1
, s2
);
1369 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1370 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1371 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1372 "value otherwise. The character comparison is done\n"
1373 "case-insensitively.")
1374 #define FUNC_NAME s_scm_string_ci_eq
1376 const char *cstr1
, *cstr2
;
1377 size_t cstart1
, cend1
, cstart2
, cend2
;
1379 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1382 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1386 while (cstart1
< cend1
&& cstart2
< cend2
)
1388 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1390 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1395 if (cstart1
< cend1
)
1397 else if (cstart2
< cend2
)
1403 scm_remember_upto_here_2 (s1
, s2
);
1404 return scm_from_size_t (cstart1
);
1407 scm_remember_upto_here_2 (s1
, s2
);
1413 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1414 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1415 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1416 "value otherwise. The character comparison is done\n"
1417 "case-insensitively.")
1418 #define FUNC_NAME s_scm_string_ci_neq
1420 const char *cstr1
, *cstr2
;
1421 size_t cstart1
, cend1
, cstart2
, cend2
;
1423 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1426 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1430 while (cstart1
< cend1
&& cstart2
< cend2
)
1432 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1434 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1439 if (cstart1
< cend1
)
1441 else if (cstart2
< cend2
)
1447 scm_remember_upto_here_2 (s1
, s2
);
1448 return scm_from_size_t (cstart1
);
1451 scm_remember_upto_here_2 (s1
, s2
);
1457 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1458 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1459 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1460 "true value otherwise. The character comparison is done\n"
1461 "case-insensitively.")
1462 #define FUNC_NAME s_scm_string_ci_lt
1464 const unsigned char *cstr1
, *cstr2
;
1465 size_t cstart1
, cend1
, cstart2
, cend2
;
1467 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1470 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1474 while (cstart1
< cend1
&& cstart2
< cend2
)
1476 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1478 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1483 if (cstart1
< cend1
)
1485 else if (cstart2
< cend2
)
1491 scm_remember_upto_here_2 (s1
, s2
);
1492 return scm_from_size_t (cstart1
);
1495 scm_remember_upto_here_2 (s1
, s2
);
1501 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1502 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1503 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1504 "true value otherwise. The character comparison is done\n"
1505 "case-insensitively.")
1506 #define FUNC_NAME s_scm_string_ci_gt
1508 const unsigned char *cstr1
, *cstr2
;
1509 size_t cstart1
, cend1
, cstart2
, cend2
;
1511 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1514 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1518 while (cstart1
< cend1
&& cstart2
< cend2
)
1520 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1522 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1527 if (cstart1
< cend1
)
1529 else if (cstart2
< cend2
)
1535 scm_remember_upto_here_2 (s1
, s2
);
1536 return scm_from_size_t (cstart1
);
1539 scm_remember_upto_here_2 (s1
, s2
);
1545 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1546 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1547 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1548 "value otherwise. The character comparison is done\n"
1549 "case-insensitively.")
1550 #define FUNC_NAME s_scm_string_ci_le
1552 const unsigned char *cstr1
, *cstr2
;
1553 size_t cstart1
, cend1
, cstart2
, cend2
;
1555 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1558 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1562 while (cstart1
< cend1
&& cstart2
< cend2
)
1564 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1566 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1571 if (cstart1
< cend1
)
1573 else if (cstart2
< cend2
)
1579 scm_remember_upto_here_2 (s1
, s2
);
1580 return scm_from_size_t (cstart1
);
1583 scm_remember_upto_here_2 (s1
, s2
);
1589 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1590 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1591 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1592 "otherwise. The character comparison is done\n"
1593 "case-insensitively.")
1594 #define FUNC_NAME s_scm_string_ci_ge
1596 const unsigned char *cstr1
, *cstr2
;
1597 size_t cstart1
, cend1
, cstart2
, cend2
;
1599 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1602 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1606 while (cstart1
< cend1
&& cstart2
< cend2
)
1608 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1610 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1615 if (cstart1
< cend1
)
1617 else if (cstart2
< cend2
)
1623 scm_remember_upto_here_2 (s1
, s2
);
1624 return scm_from_size_t (cstart1
);
1627 scm_remember_upto_here_2 (s1
, s2
);
1632 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1633 (SCM s
, SCM bound
, SCM start
, SCM end
),
1634 "Compute a hash value for @var{S}. the optional argument "
1635 "@var{bound} is a non-negative exact "
1636 "integer specifying the range of the hash function. "
1637 "A positive value restricts the return value to the "
1639 #define FUNC_NAME s_scm_substring_hash
1641 if (SCM_UNBNDP (bound
))
1642 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1643 if (SCM_UNBNDP (start
))
1645 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1649 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1650 (SCM s
, SCM bound
, SCM start
, SCM end
),
1651 "Compute a hash value for @var{S}. the optional argument "
1652 "@var{bound} is a non-negative exact "
1653 "integer specifying the range of the hash function. "
1654 "A positive value restricts the return value to the "
1656 #define FUNC_NAME s_scm_substring_hash_ci
1658 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1660 SCM_UNDEFINED
, SCM_UNDEFINED
);
1664 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1665 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1666 "Return the length of the longest common prefix of the two\n"
1668 #define FUNC_NAME s_scm_string_prefix_length
1670 const char *cstr1
, *cstr2
;
1671 size_t cstart1
, cend1
, cstart2
, cend2
;
1674 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1677 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1680 while (cstart1
< cend1
&& cstart2
< cend2
)
1682 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1690 scm_remember_upto_here_2 (s1
, s2
);
1691 return scm_from_size_t (len
);
1696 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1697 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1698 "Return the length of the longest common prefix of the two\n"
1699 "strings, ignoring character case.")
1700 #define FUNC_NAME s_scm_string_prefix_length_ci
1702 const char *cstr1
, *cstr2
;
1703 size_t cstart1
, cend1
, cstart2
, cend2
;
1706 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1709 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1712 while (cstart1
< cend1
&& cstart2
< cend2
)
1714 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1722 scm_remember_upto_here_2 (s1
, s2
);
1723 return scm_from_size_t (len
);
1728 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1729 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1730 "Return the length of the longest common suffix of the two\n"
1732 #define FUNC_NAME s_scm_string_suffix_length
1734 const char *cstr1
, *cstr2
;
1735 size_t cstart1
, cend1
, cstart2
, cend2
;
1738 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1741 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1744 while (cstart1
< cend1
&& cstart2
< cend2
)
1748 if (cstr1
[cend1
] != cstr2
[cend2
])
1754 scm_remember_upto_here_2 (s1
, s2
);
1755 return scm_from_size_t (len
);
1760 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1761 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1762 "Return the length of the longest common suffix of the two\n"
1763 "strings, ignoring character case.")
1764 #define FUNC_NAME s_scm_string_suffix_length_ci
1766 const char *cstr1
, *cstr2
;
1767 size_t cstart1
, cend1
, cstart2
, cend2
;
1770 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1773 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1776 while (cstart1
< cend1
&& cstart2
< cend2
)
1780 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1786 scm_remember_upto_here_2 (s1
, s2
);
1787 return scm_from_size_t (len
);
1792 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1793 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1794 "Is @var{s1} a prefix of @var{s2}?")
1795 #define FUNC_NAME s_scm_string_prefix_p
1797 const char *cstr1
, *cstr2
;
1798 size_t cstart1
, cend1
, cstart2
, cend2
;
1799 size_t len
= 0, len1
;
1801 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1804 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1807 len1
= cend1
- cstart1
;
1808 while (cstart1
< cend1
&& cstart2
< cend2
)
1810 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1818 scm_remember_upto_here_2 (s1
, s2
);
1819 return scm_from_bool (len
== len1
);
1824 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1825 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1826 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1827 #define FUNC_NAME s_scm_string_prefix_ci_p
1829 const char *cstr1
, *cstr2
;
1830 size_t cstart1
, cend1
, cstart2
, cend2
;
1831 size_t len
= 0, len1
;
1833 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1836 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1839 len1
= cend1
- cstart1
;
1840 while (cstart1
< cend1
&& cstart2
< cend2
)
1842 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1850 scm_remember_upto_here_2 (s1
, s2
);
1851 return scm_from_bool (len
== len1
);
1856 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1857 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1858 "Is @var{s1} a suffix of @var{s2}?")
1859 #define FUNC_NAME s_scm_string_suffix_p
1861 const char *cstr1
, *cstr2
;
1862 size_t cstart1
, cend1
, cstart2
, cend2
;
1863 size_t len
= 0, len1
;
1865 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1868 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1871 len1
= cend1
- cstart1
;
1872 while (cstart1
< cend1
&& cstart2
< cend2
)
1876 if (cstr1
[cend1
] != cstr2
[cend2
])
1882 scm_remember_upto_here_2 (s1
, s2
);
1883 return scm_from_bool (len
== len1
);
1888 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1889 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1890 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1891 #define FUNC_NAME s_scm_string_suffix_ci_p
1893 const char *cstr1
, *cstr2
;
1894 size_t cstart1
, cend1
, cstart2
, cend2
;
1895 size_t len
= 0, len1
;
1897 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1900 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1903 len1
= cend1
- cstart1
;
1904 while (cstart1
< cend1
&& cstart2
< cend2
)
1908 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1914 scm_remember_upto_here_2 (s1
, s2
);
1915 return scm_from_bool (len
== len1
);
1920 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1921 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1922 "Search through the string @var{s} from left to right, returning\n"
1923 "the index of the first occurence of a character which\n"
1925 "@itemize @bullet\n"
1927 "equals @var{char_pred}, if it is character,\n"
1930 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1933 "is in the set @var{char_pred}, if it is a character set.\n"
1935 #define FUNC_NAME s_scm_string_index
1938 size_t cstart
, cend
;
1940 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1943 if (SCM_CHARP (char_pred
))
1945 char cchr
= SCM_CHAR (char_pred
);
1946 while (cstart
< cend
)
1948 if (cchr
== cstr
[cstart
])
1953 else if (SCM_CHARSETP (char_pred
))
1955 while (cstart
< cend
)
1957 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1964 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1965 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1967 while (cstart
< cend
)
1970 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1971 if (scm_is_true (res
))
1973 cstr
= scm_i_string_chars (s
);
1978 scm_remember_upto_here_1 (s
);
1982 scm_remember_upto_here_1 (s
);
1983 return scm_from_size_t (cstart
);
1987 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1988 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1989 "Search through the string @var{s} from right to left, returning\n"
1990 "the index of the last occurence of a character which\n"
1992 "@itemize @bullet\n"
1994 "equals @var{char_pred}, if it is character,\n"
1997 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2000 "is in the set if @var{char_pred} is a character set.\n"
2002 #define FUNC_NAME s_scm_string_index_right
2005 size_t cstart
, cend
;
2007 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2010 if (SCM_CHARP (char_pred
))
2012 char cchr
= SCM_CHAR (char_pred
);
2013 while (cstart
< cend
)
2016 if (cchr
== cstr
[cend
])
2020 else if (SCM_CHARSETP (char_pred
))
2022 while (cstart
< cend
)
2025 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2031 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2032 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2034 while (cstart
< cend
)
2038 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2039 if (scm_is_true (res
))
2041 cstr
= scm_i_string_chars (s
);
2045 scm_remember_upto_here_1 (s
);
2049 scm_remember_upto_here_1 (s
);
2050 return scm_from_size_t (cend
);
2054 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
2055 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2056 "Search through the string @var{s} from right to left, returning\n"
2057 "the index of the last occurence of a character which\n"
2059 "@itemize @bullet\n"
2061 "equals @var{char_pred}, if it is character,\n"
2064 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2067 "is in the set if @var{char_pred} is a character set.\n"
2069 #define FUNC_NAME s_scm_string_rindex
2071 return scm_string_index_right (s
, char_pred
, start
, end
);
2075 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
2076 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2077 "Search through the string @var{s} from left to right, returning\n"
2078 "the index of the first occurence of a character which\n"
2080 "@itemize @bullet\n"
2082 "does not equal @var{char_pred}, if it is character,\n"
2085 "does not satisify the predicate @var{char_pred}, if it is a\n"
2089 "is not in the set if @var{char_pred} is a character set.\n"
2091 #define FUNC_NAME s_scm_string_skip
2094 size_t cstart
, cend
;
2096 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2099 if (SCM_CHARP (char_pred
))
2101 char cchr
= SCM_CHAR (char_pred
);
2102 while (cstart
< cend
)
2104 if (cchr
!= cstr
[cstart
])
2109 else if (SCM_CHARSETP (char_pred
))
2111 while (cstart
< cend
)
2113 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2120 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2121 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2123 while (cstart
< cend
)
2126 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2127 if (scm_is_false (res
))
2129 cstr
= scm_i_string_chars (s
);
2134 scm_remember_upto_here_1 (s
);
2138 scm_remember_upto_here_1 (s
);
2139 return scm_from_size_t (cstart
);
2144 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2145 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2146 "Search through the string @var{s} from right to left, returning\n"
2147 "the index of the last occurence of a character which\n"
2149 "@itemize @bullet\n"
2151 "does not equal @var{char_pred}, if it is character,\n"
2154 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2158 "is not in the set if @var{char_pred} is a character set.\n"
2160 #define FUNC_NAME s_scm_string_skip_right
2163 size_t cstart
, cend
;
2165 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2168 if (SCM_CHARP (char_pred
))
2170 char cchr
= SCM_CHAR (char_pred
);
2171 while (cstart
< cend
)
2174 if (cchr
!= cstr
[cend
])
2178 else if (SCM_CHARSETP (char_pred
))
2180 while (cstart
< cend
)
2183 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2189 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2190 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2192 while (cstart
< cend
)
2196 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2197 if (scm_is_false (res
))
2199 cstr
= scm_i_string_chars (s
);
2203 scm_remember_upto_here_1 (s
);
2207 scm_remember_upto_here_1 (s
);
2208 return scm_from_size_t (cend
);
2214 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2215 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2216 "Return the count of the number of characters in the string\n"
2219 "@itemize @bullet\n"
2221 "equals @var{char_pred}, if it is character,\n"
2224 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2227 "is in the set @var{char_pred}, if it is a character set.\n"
2229 #define FUNC_NAME s_scm_string_count
2232 size_t cstart
, cend
;
2235 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2238 if (SCM_CHARP (char_pred
))
2240 char cchr
= SCM_CHAR (char_pred
);
2241 while (cstart
< cend
)
2243 if (cchr
== cstr
[cstart
])
2248 else if (SCM_CHARSETP (char_pred
))
2250 while (cstart
< cend
)
2252 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2259 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2260 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2262 while (cstart
< cend
)
2265 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2266 if (scm_is_true (res
))
2268 cstr
= scm_i_string_chars (s
);
2273 scm_remember_upto_here_1 (s
);
2274 return scm_from_size_t (count
);
2279 /* FIXME::martin: This should definitely get implemented more
2280 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2282 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2283 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2284 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2285 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2286 "The optional start/end indices restrict the operation to the\n"
2287 "indicated substrings.")
2288 #define FUNC_NAME s_scm_string_contains
2290 const char *cs1
, * cs2
;
2291 size_t cstart1
, cend1
, cstart2
, cend2
;
2294 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2297 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2300 len2
= cend2
- cstart2
;
2301 if (cend1
- cstart1
>= len2
)
2302 while (cstart1
<= cend1
- len2
)
2306 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2313 scm_remember_upto_here_2 (s1
, s2
);
2314 return scm_from_size_t (cstart1
);
2319 scm_remember_upto_here_2 (s1
, s2
);
2325 /* FIXME::martin: This should definitely get implemented more
2326 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2328 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2329 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2330 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2331 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2332 "The optional start/end indices restrict the operation to the\n"
2333 "indicated substrings. Character comparison is done\n"
2334 "case-insensitively.")
2335 #define FUNC_NAME s_scm_string_contains_ci
2337 const char *cs1
, * cs2
;
2338 size_t cstart1
, cend1
, cstart2
, cend2
;
2341 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2344 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2347 len2
= cend2
- cstart2
;
2348 if (cend1
- cstart1
>= len2
)
2349 while (cstart1
<= cend1
- len2
)
2353 while (i
< cend1
&& j
< cend2
&&
2354 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2361 scm_remember_upto_here_2 (s1
, s2
);
2362 return scm_from_size_t (cstart1
);
2367 scm_remember_upto_here_2 (s1
, s2
);
2373 /* Helper function for the string uppercase conversion functions.
2374 * No argument checking is performed. */
2376 string_upcase_x (SCM v
, size_t start
, size_t end
)
2381 v
= scm_i_string_start_writing (v
);
2382 dst
= scm_i_string_writable_chars (v
);
2383 for (k
= start
; k
< end
; ++k
)
2384 dst
[k
] = scm_c_upcase (dst
[k
]);
2385 scm_i_string_stop_writing ();
2386 scm_remember_upto_here_1 (v
);
2391 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2392 (SCM str
, SCM start
, SCM end
),
2393 "Destructively upcase every character in @code{str}.\n"
2396 "(string-upcase! y)\n"
2397 "@result{} \"ARRDEFG\"\n"
2399 "@result{} \"ARRDEFG\"\n"
2401 #define FUNC_NAME s_scm_substring_upcase_x
2404 size_t cstart
, cend
;
2406 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2409 return string_upcase_x (str
, cstart
, cend
);
2414 scm_string_upcase_x (SCM str
)
2416 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2419 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2420 (SCM str
, SCM start
, SCM end
),
2421 "Upcase every character in @code{str}.")
2422 #define FUNC_NAME s_scm_substring_upcase
2425 size_t cstart
, cend
;
2427 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2430 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2435 scm_string_upcase (SCM str
)
2437 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2440 /* Helper function for the string lowercase conversion functions.
2441 * No argument checking is performed. */
2443 string_downcase_x (SCM v
, size_t start
, size_t end
)
2448 v
= scm_i_string_start_writing (v
);
2449 dst
= scm_i_string_writable_chars (v
);
2450 for (k
= start
; k
< end
; ++k
)
2451 dst
[k
] = scm_c_downcase (dst
[k
]);
2452 scm_i_string_stop_writing ();
2453 scm_remember_upto_here_1 (v
);
2458 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2459 (SCM str
, SCM start
, SCM end
),
2460 "Destructively downcase every character in @var{str}.\n"
2464 "@result{} \"ARRDEFG\"\n"
2465 "(string-downcase! y)\n"
2466 "@result{} \"arrdefg\"\n"
2468 "@result{} \"arrdefg\"\n"
2470 #define FUNC_NAME s_scm_substring_downcase_x
2473 size_t cstart
, cend
;
2475 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2478 return string_downcase_x (str
, cstart
, cend
);
2483 scm_string_downcase_x (SCM str
)
2485 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2488 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2489 (SCM str
, SCM start
, SCM end
),
2490 "Downcase every character in @var{str}.")
2491 #define FUNC_NAME s_scm_substring_downcase
2494 size_t cstart
, cend
;
2496 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2499 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2504 scm_string_downcase (SCM str
)
2506 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2509 /* Helper function for the string capitalization functions.
2510 * No argument checking is performed. */
2512 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2518 str
= scm_i_string_start_writing (str
);
2519 sz
= (unsigned char *) scm_i_string_writable_chars (str
);
2520 for(i
= start
; i
< end
; i
++)
2522 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2526 sz
[i
] = scm_c_upcase(sz
[i
]);
2531 sz
[i
] = scm_c_downcase(sz
[i
]);
2537 scm_i_string_stop_writing ();
2538 scm_remember_upto_here_1 (str
);
2544 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2545 (SCM str
, SCM start
, SCM end
),
2546 "Destructively titlecase every first character in a word in\n"
2548 #define FUNC_NAME s_scm_string_titlecase_x
2551 size_t cstart
, cend
;
2553 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2556 return string_titlecase_x (str
, cstart
, cend
);
2561 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2562 (SCM str
, SCM start
, SCM end
),
2563 "Titlecase every first character in a word in @var{str}.")
2564 #define FUNC_NAME s_scm_string_titlecase
2567 size_t cstart
, cend
;
2569 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2572 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2576 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2578 "Upcase the first character of every word in @var{str}\n"
2579 "destructively and return @var{str}.\n"
2582 "y @result{} \"hello world\"\n"
2583 "(string-capitalize! y) @result{} \"Hello World\"\n"
2584 "y @result{} \"Hello World\"\n"
2586 #define FUNC_NAME s_scm_string_capitalize_x
2588 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2593 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2595 "Return a freshly allocated string with the characters in\n"
2596 "@var{str}, where the first character of every word is\n"
2598 #define FUNC_NAME s_scm_string_capitalize
2600 return scm_string_capitalize_x (scm_string_copy (str
));
2605 /* Reverse the portion of @var{str} between str[cstart] (including)
2606 and str[cend] excluding. */
2608 string_reverse_x (char * str
, size_t cstart
, size_t cend
)
2615 while (cstart
< cend
)
2618 str
[cstart
] = str
[cend
];
2627 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2628 (SCM str
, SCM start
, SCM end
),
2629 "Reverse the string @var{str}. The optional arguments\n"
2630 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2632 #define FUNC_NAME s_scm_string_reverse
2636 size_t cstart
, cend
;
2639 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2642 result
= scm_string_copy (str
);
2643 result
= scm_i_string_start_writing (result
);
2644 ctarget
= scm_i_string_writable_chars (result
);
2645 string_reverse_x (ctarget
, cstart
, cend
);
2646 scm_i_string_stop_writing ();
2647 scm_remember_upto_here_1 (str
);
2653 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2654 (SCM str
, SCM start
, SCM end
),
2655 "Reverse the string @var{str} in-place. The optional arguments\n"
2656 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2657 "operate on. The return value is unspecified.")
2658 #define FUNC_NAME s_scm_string_reverse_x
2661 size_t cstart
, cend
;
2663 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2667 str
= scm_i_string_start_writing (str
);
2668 cstr
= scm_i_string_writable_chars (str
);
2669 string_reverse_x (cstr
, cstart
, cend
);
2670 scm_i_string_stop_writing ();
2671 scm_remember_upto_here_1 (str
);
2672 return SCM_UNSPECIFIED
;
2677 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2679 "Like @code{string-append}, but the result may share memory\n"
2680 "with the argument strings.")
2681 #define FUNC_NAME s_scm_string_append_shared
2683 /* If "rest" contains just one non-empty string, return that.
2684 If it's entirely empty strings, then return scm_nullstr.
2685 Otherwise use scm_string_concatenate. */
2687 SCM ret
= scm_nullstr
;
2688 int seen_nonempty
= 0;
2691 SCM_VALIDATE_REST_ARGUMENT (rest
);
2693 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2696 if (scm_c_string_length (s
) != 0)
2699 /* two or more non-empty strings, need full concat */
2700 return scm_string_append (rest
);
2711 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2713 "Append the elements of @var{ls} (which must be strings)\n"
2714 "together into a single string. Guaranteed to return a freshly\n"
2715 "allocated string.")
2716 #define FUNC_NAME s_scm_string_concatenate
2718 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2719 return scm_string_append (ls
);
2724 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2725 (SCM ls
, SCM final_string
, SCM end
),
2726 "Without optional arguments, this procedure is equivalent to\n"
2729 "(string-concatenate (reverse ls))\n"
2732 "If the optional argument @var{final_string} is specified, it is\n"
2733 "consed onto the beginning to @var{ls} before performing the\n"
2734 "list-reverse and string-concatenate operations. If @var{end}\n"
2735 "is given, only the characters of @var{final_string} up to index\n"
2736 "@var{end} are used.\n"
2738 "Guaranteed to return a freshly allocated string.")
2739 #define FUNC_NAME s_scm_string_concatenate_reverse
2741 if (!SCM_UNBNDP (end
))
2742 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2744 if (!SCM_UNBNDP (final_string
))
2745 ls
= scm_cons (final_string
, ls
);
2747 return scm_string_concatenate (scm_reverse (ls
));
2752 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2754 "Like @code{string-concatenate}, but the result may share memory\n"
2755 "with the strings in the list @var{ls}.")
2756 #define FUNC_NAME s_scm_string_concatenate_shared
2758 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2759 return scm_string_append_shared (ls
);
2764 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2765 (SCM ls
, SCM final_string
, SCM end
),
2766 "Like @code{string-concatenate-reverse}, but the result may\n"
2767 "share memory with the the strings in the @var{ls} arguments.")
2768 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2770 /* Just call the non-sharing version. */
2771 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2776 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2777 (SCM proc
, SCM s
, SCM start
, SCM end
),
2778 "@var{proc} is a char->char procedure, it is mapped over\n"
2779 "@var{s}. The order in which the procedure is applied to the\n"
2780 "string elements is not specified.")
2781 #define FUNC_NAME s_scm_string_map
2784 size_t cstart
, cend
;
2786 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2788 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2789 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2792 result
= scm_i_make_string (cend
- cstart
, &p
);
2793 while (cstart
< cend
)
2795 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2796 if (!SCM_CHARP (ch
))
2797 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2799 *p
++ = SCM_CHAR (ch
);
2806 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2807 (SCM proc
, SCM s
, SCM start
, SCM end
),
2808 "@var{proc} is a char->char procedure, it is mapped over\n"
2809 "@var{s}. The order in which the procedure is applied to the\n"
2810 "string elements is not specified. The string @var{s} is\n"
2811 "modified in-place, the return value is not specified.")
2812 #define FUNC_NAME s_scm_string_map_x
2814 size_t cstart
, cend
;
2815 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2817 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2818 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2821 while (cstart
< cend
)
2823 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2824 if (!SCM_CHARP (ch
))
2825 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2826 scm_c_string_set_x (s
, cstart
, ch
);
2829 return SCM_UNSPECIFIED
;
2834 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2835 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2836 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2837 "as the terminating element, from left to right. @var{kons}\n"
2838 "must expect two arguments: The actual character and the last\n"
2839 "result of @var{kons}' application.")
2840 #define FUNC_NAME s_scm_string_fold
2843 size_t cstart
, cend
;
2846 SCM_VALIDATE_PROC (1, kons
);
2847 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2851 while (cstart
< cend
)
2853 unsigned int c
= (unsigned char) cstr
[cstart
];
2854 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2855 cstr
= scm_i_string_chars (s
);
2859 scm_remember_upto_here_1 (s
);
2865 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2866 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2867 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2868 "as the terminating element, from right to left. @var{kons}\n"
2869 "must expect two arguments: The actual character and the last\n"
2870 "result of @var{kons}' application.")
2871 #define FUNC_NAME s_scm_string_fold_right
2874 size_t cstart
, cend
;
2877 SCM_VALIDATE_PROC (1, kons
);
2878 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2882 while (cstart
< cend
)
2884 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2885 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2886 cstr
= scm_i_string_chars (s
);
2890 scm_remember_upto_here_1 (s
);
2896 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2897 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2898 "@itemize @bullet\n"
2899 "@item @var{g} is used to generate a series of @emph{seed}\n"
2900 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2901 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2903 "@item @var{p} tells us when to stop -- when it returns true\n"
2904 "when applied to one of these seed values.\n"
2905 "@item @var{f} maps each seed value to the corresponding\n"
2906 "character in the result string. These chars are assembled\n"
2907 "into the string in a left-to-right order.\n"
2908 "@item @var{base} is the optional initial/leftmost portion\n"
2909 "of the constructed string; it default to the empty\n"
2911 "@item @var{make_final} is applied to the terminal seed\n"
2912 "value (on which @var{p} returns true) to produce\n"
2913 "the final/rightmost portion of the constructed string.\n"
2914 "It defaults to @code{(lambda (x) "")}.\n"
2916 #define FUNC_NAME s_scm_string_unfold
2920 SCM_VALIDATE_PROC (1, p
);
2921 SCM_VALIDATE_PROC (2, f
);
2922 SCM_VALIDATE_PROC (3, g
);
2923 if (!SCM_UNBNDP (base
))
2925 SCM_VALIDATE_STRING (5, base
);
2929 ans
= scm_i_make_string (0, NULL
);
2930 if (!SCM_UNBNDP (make_final
))
2931 SCM_VALIDATE_PROC (6, make_final
);
2933 res
= scm_call_1 (p
, seed
);
2934 while (scm_is_false (res
))
2938 SCM ch
= scm_call_1 (f
, seed
);
2939 if (!SCM_CHARP (ch
))
2940 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2941 str
= scm_i_make_string (1, &ptr
);
2942 *ptr
= SCM_CHAR (ch
);
2944 ans
= scm_string_append (scm_list_2 (ans
, str
));
2945 seed
= scm_call_1 (g
, seed
);
2946 res
= scm_call_1 (p
, seed
);
2948 if (!SCM_UNBNDP (make_final
))
2950 res
= scm_call_1 (make_final
, seed
);
2951 return scm_string_append (scm_list_2 (ans
, res
));
2959 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2960 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2961 "@itemize @bullet\n"
2962 "@item @var{g} is used to generate a series of @emph{seed}\n"
2963 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2964 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2966 "@item @var{p} tells us when to stop -- when it returns true\n"
2967 "when applied to one of these seed values.\n"
2968 "@item @var{f} maps each seed value to the corresponding\n"
2969 "character in the result string. These chars are assembled\n"
2970 "into the string in a right-to-left order.\n"
2971 "@item @var{base} is the optional initial/rightmost portion\n"
2972 "of the constructed string; it default to the empty\n"
2974 "@item @var{make_final} is applied to the terminal seed\n"
2975 "value (on which @var{p} returns true) to produce\n"
2976 "the final/leftmost portion of the constructed string.\n"
2977 "It defaults to @code{(lambda (x) "")}.\n"
2979 #define FUNC_NAME s_scm_string_unfold_right
2983 SCM_VALIDATE_PROC (1, p
);
2984 SCM_VALIDATE_PROC (2, f
);
2985 SCM_VALIDATE_PROC (3, g
);
2986 if (!SCM_UNBNDP (base
))
2988 SCM_VALIDATE_STRING (5, base
);
2992 ans
= scm_i_make_string (0, NULL
);
2993 if (!SCM_UNBNDP (make_final
))
2994 SCM_VALIDATE_PROC (6, make_final
);
2996 res
= scm_call_1 (p
, seed
);
2997 while (scm_is_false (res
))
3001 SCM ch
= scm_call_1 (f
, seed
);
3002 if (!SCM_CHARP (ch
))
3003 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
3004 str
= scm_i_make_string (1, &ptr
);
3005 *ptr
= SCM_CHAR (ch
);
3007 ans
= scm_string_append (scm_list_2 (str
, ans
));
3008 seed
= scm_call_1 (g
, seed
);
3009 res
= scm_call_1 (p
, seed
);
3011 if (!SCM_UNBNDP (make_final
))
3013 res
= scm_call_1 (make_final
, seed
);
3014 return scm_string_append (scm_list_2 (res
, ans
));
3022 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
3023 (SCM proc
, SCM s
, SCM start
, SCM end
),
3024 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
3025 "return value is not specified.")
3026 #define FUNC_NAME s_scm_string_for_each
3028 size_t cstart
, cend
;
3029 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
3031 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
3032 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3035 while (cstart
< cend
)
3037 proc_tramp (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
3041 scm_remember_upto_here_1 (s
);
3042 return SCM_UNSPECIFIED
;
3046 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
3047 (SCM proc
, SCM s
, SCM start
, SCM end
),
3048 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
3051 "For example, to change characters to alternately upper and\n"
3055 "(define str (string-copy \"studly\"))\n"
3056 "(string-for-each-index\n"
3058 " (string-set! str i\n"
3059 " ((if (even? i) char-upcase char-downcase)\n"
3060 " (string-ref str i))))\n"
3062 "str @result{} \"StUdLy\"\n"
3064 #define FUNC_NAME s_scm_string_for_each_index
3066 size_t cstart
, cend
;
3067 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
3069 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
3070 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3074 while (cstart
< cend
)
3076 proc_tramp (proc
, scm_from_size_t (cstart
));
3080 scm_remember_upto_here_1 (s
);
3081 return SCM_UNSPECIFIED
;
3085 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
3086 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
3087 "This is the @emph{extended substring} procedure that implements\n"
3088 "replicated copying of a substring of some string.\n"
3090 "@var{s} is a string, @var{start} and @var{end} are optional\n"
3091 "arguments that demarcate a substring of @var{s}, defaulting to\n"
3092 "0 and the length of @var{s}. Replicate this substring up and\n"
3093 "down index space, in both the positive and negative directions.\n"
3094 "@code{xsubstring} returns the substring of this string\n"
3095 "beginning at index @var{from}, and ending at @var{to}, which\n"
3096 "defaults to @var{from} + (@var{end} - @var{start}).")
3097 #define FUNC_NAME s_scm_xsubstring
3101 size_t cstart
, cend
;
3105 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3109 cfrom
= scm_to_int (from
);
3110 if (SCM_UNBNDP (to
))
3111 cto
= cfrom
+ (cend
- cstart
);
3113 cto
= scm_to_int (to
);
3114 if (cstart
== cend
&& cfrom
!= cto
)
3115 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3117 result
= scm_i_make_string (cto
- cfrom
, &p
);
3119 cs
= scm_i_string_chars (s
);
3122 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
3124 *p
= cs
[(cend
- cstart
) - t
];
3131 scm_remember_upto_here_1 (s
);
3137 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3138 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3139 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3140 "is written into the string @var{target} starting at index\n"
3141 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3142 "@var{target} @var{s})} or these arguments share storage -- you\n"
3143 "cannot copy a string on top of itself.")
3144 #define FUNC_NAME s_scm_string_xcopy_x
3148 size_t ctstart
, cstart
, cend
;
3150 SCM dummy
= SCM_UNDEFINED
;
3153 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3156 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
3159 csfrom
= scm_to_int (sfrom
);
3160 if (SCM_UNBNDP (sto
))
3161 csto
= csfrom
+ (cend
- cstart
);
3163 csto
= scm_to_int (sto
);
3164 if (cstart
== cend
&& csfrom
!= csto
)
3165 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3166 SCM_ASSERT_RANGE (1, tstart
,
3167 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3169 target
= scm_i_string_start_writing (target
);
3170 p
= scm_i_string_writable_chars (target
) + ctstart
;
3171 cs
= scm_i_string_chars (s
);
3172 while (csfrom
< csto
)
3174 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3176 *p
= cs
[(cend
- cstart
) - t
];
3182 scm_i_string_stop_writing ();
3184 scm_remember_upto_here_2 (target
, s
);
3185 return SCM_UNSPECIFIED
;
3190 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3191 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3192 "Return the string @var{s1}, but with the characters\n"
3193 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3194 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3195 #define FUNC_NAME s_scm_string_replace
3197 const char *cstr1
, *cstr2
;
3199 size_t cstart1
, cend1
, cstart2
, cend2
;
3202 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
3205 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
3208 result
= scm_i_make_string ((cstart1
+ cend2
- cstart2
3209 + scm_i_string_length (s1
) - cend1
), &p
);
3210 cstr1
= scm_i_string_chars (s1
);
3211 cstr2
= scm_i_string_chars (s2
);
3212 memmove (p
, cstr1
, cstart1
* sizeof (char));
3213 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3214 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3216 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3217 scm_remember_upto_here_2 (s1
, s2
);
3223 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3224 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3225 "Split the string @var{s} into a list of substrings, where each\n"
3226 "substring is a maximal non-empty contiguous sequence of\n"
3227 "characters from the character set @var{token_set}, which\n"
3228 "defaults to @code{char-set:graphic}.\n"
3229 "If @var{start} or @var{end} indices are provided, they restrict\n"
3230 "@code{string-tokenize} to operating on the indicated substring\n"
3232 #define FUNC_NAME s_scm_string_tokenize
3235 size_t cstart
, cend
;
3236 SCM result
= SCM_EOL
;
3238 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3242 if (SCM_UNBNDP (token_set
))
3243 token_set
= scm_char_set_graphic
;
3245 if (SCM_CHARSETP (token_set
))
3249 while (cstart
< cend
)
3251 while (cstart
< cend
)
3253 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3260 while (cstart
< cend
)
3262 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3266 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3267 cstr
= scm_i_string_chars (s
);
3271 SCM_WRONG_TYPE_ARG (2, token_set
);
3273 scm_remember_upto_here_1 (s
);
3278 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3280 "Split the string @var{str} into the a list of the substrings delimited\n"
3281 "by appearances of the character @var{chr}. Note that an empty substring\n"
3282 "between separator characters will result in an empty string in the\n"
3286 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3288 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3290 "(string-split \"::\" #\\:)\n"
3292 "(\"\" \"\" \"\")\n"
3294 "(string-split \"\" #\\:)\n"
3298 #define FUNC_NAME s_scm_string_split
3305 SCM_VALIDATE_STRING (1, str
);
3306 SCM_VALIDATE_CHAR (2, chr
);
3308 idx
= scm_i_string_length (str
);
3309 p
= scm_i_string_chars (str
);
3310 ch
= SCM_CHAR (chr
);
3314 while (idx
> 0 && p
[idx
- 1] != ch
)
3318 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3319 p
= scm_i_string_chars (str
);
3323 scm_remember_upto_here_1 (str
);
3329 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3330 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3331 "Filter the string @var{s}, retaining only those characters\n"
3332 "which satisfy @var{char_pred}.\n"
3334 "If @var{char_pred} is a procedure, it is applied to each\n"
3335 "character as a predicate, if it is a character, it is tested\n"
3336 "for equality and if it is a character set, it is tested for\n"
3338 #define FUNC_NAME s_scm_string_filter
3341 size_t cstart
, cend
;
3345 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3349 /* The explicit loops below stripping leading and trailing non-matches
3350 mean we can return a substring if those are the only deletions, making
3351 string-filter as efficient as string-trim-both in that case. */
3353 if (SCM_CHARP (char_pred
))
3358 chr
= SCM_CHAR (char_pred
);
3360 /* strip leading non-matches by incrementing cstart */
3361 while (cstart
< cend
&& cstr
[cstart
] != chr
)
3364 /* strip trailing non-matches by decrementing cend */
3365 while (cend
> cstart
&& cstr
[cend
-1] != chr
)
3368 /* count chars to keep */
3370 for (idx
= cstart
; idx
< cend
; idx
++)
3371 if (cstr
[idx
] == chr
)
3374 if (count
== cend
- cstart
)
3376 /* whole of cstart to cend is to be kept, return a copy-on-write
3379 result
= scm_i_substring (s
, cstart
, cend
);
3382 result
= scm_c_make_string (count
, char_pred
);
3384 else if (SCM_CHARSETP (char_pred
))
3388 /* strip leading non-matches by incrementing cstart */
3389 while (cstart
< cend
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3392 /* strip trailing non-matches by decrementing cend */
3393 while (cend
> cstart
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3396 /* count chars to be kept */
3398 for (idx
= cstart
; idx
< cend
; idx
++)
3399 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3402 /* if whole of start to end kept then return substring */
3403 if (count
== cend
- cstart
)
3404 goto result_substring
;
3408 result
= scm_i_make_string (count
, &dst
);
3409 cstr
= scm_i_string_chars (s
);
3411 /* decrement "count" in this loop as well as using idx, so that if
3412 another thread is simultaneously changing "s" there's no chance
3413 it'll make us copy more than count characters */
3414 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3416 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3427 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3429 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3434 ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3435 res
= pred_tramp (char_pred
, ch
);
3436 if (scm_is_true (res
))
3437 ls
= scm_cons (ch
, ls
);
3438 cstr
= scm_i_string_chars (s
);
3441 result
= scm_reverse_list_to_string (ls
);
3444 scm_remember_upto_here_1 (s
);
3450 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3451 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3452 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3454 "If @var{char_pred} is a procedure, it is applied to each\n"
3455 "character as a predicate, if it is a character, it is tested\n"
3456 "for equality and if it is a character set, it is tested for\n"
3458 #define FUNC_NAME s_scm_string_delete
3461 size_t cstart
, cend
;
3465 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3469 /* The explicit loops below stripping leading and trailing matches mean we
3470 can return a substring if those are the only deletions, making
3471 string-delete as efficient as string-trim-both in that case. */
3473 if (SCM_CHARP (char_pred
))
3478 chr
= SCM_CHAR (char_pred
);
3480 /* strip leading matches by incrementing cstart */
3481 while (cstart
< cend
&& cstr
[cstart
] == chr
)
3484 /* strip trailing matches by decrementing cend */
3485 while (cend
> cstart
&& cstr
[cend
-1] == chr
)
3488 /* count chars to be kept */
3490 for (idx
= cstart
; idx
< cend
; idx
++)
3491 if (cstr
[idx
] != chr
)
3494 if (count
== cend
- cstart
)
3496 /* whole of cstart to cend is to be kept, return a copy-on-write
3499 result
= scm_i_substring (s
, cstart
, cend
);
3503 /* new string for retained portion */
3505 result
= scm_i_make_string (count
, &dst
);
3506 cstr
= scm_i_string_chars (s
);
3508 /* decrement "count" in this loop as well as using idx, so that if
3509 another thread is simultaneously changing "s" there's no chance
3510 it'll make us copy more than count characters */
3511 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3513 if (cstr
[idx
] != chr
)
3521 else if (SCM_CHARSETP (char_pred
))
3525 /* strip leading matches by incrementing cstart */
3526 while (cstart
< cend
&& SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3529 /* strip trailing matches by decrementing cend */
3530 while (cend
> cstart
&& SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3533 /* count chars to be kept */
3535 for (idx
= cstart
; idx
< cend
; idx
++)
3536 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3539 if (count
== cend
- cstart
)
3540 goto result_substring
;
3543 /* new string for retained portion */
3545 result
= scm_i_make_string (count
, &dst
);
3546 cstr
= scm_i_string_chars (s
);
3548 /* decrement "count" in this loop as well as using idx, so that if
3549 another thread is simultaneously changing "s" there's no chance
3550 it'll make us copy more than count characters */
3551 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3553 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3564 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3565 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3570 SCM res
, ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3571 res
= pred_tramp (char_pred
, ch
);
3572 if (scm_is_false (res
))
3573 ls
= scm_cons (ch
, ls
);
3574 cstr
= scm_i_string_chars (s
);
3577 result
= scm_reverse_list_to_string (ls
);
3580 scm_remember_upto_here_1 (s
);
3586 scm_init_srfi_13 (void)
3588 #include "libguile/srfi-13.x"
3591 /* End of srfi-13.c. */