1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
26 #include "libguile/srfi-13.h"
27 #include "libguile/srfi-14.h"
29 /* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
30 messing with the internal representation of strings. We define our
31 own version since we use it so much and are messing with Guile
35 #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 c_str = scm_i_string_chars (str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 /* Expecting "unsigned char *c_str" */
46 #define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
47 pos_start, start, c_start, \
48 pos_end, end, c_end) \
50 const char *signed_c_str; \
51 MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
52 pos_start, start, c_start, \
53 pos_end, end, c_end); \
54 c_str = (unsigned char *) signed_c_str; \
57 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
58 pos_start, start, c_start, \
59 pos_end, end, c_end) \
61 SCM_VALIDATE_STRING (pos_str, str); \
62 scm_i_get_substring_spec (scm_i_string_length (str), \
63 start, &c_start, end, &c_end); \
66 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
68 "Return @code{#t} if @var{str}'s length is zero, and\n"
69 "@code{#f} otherwise.\n"
71 "(string-null? \"\") @result{} #t\n"
72 "y @result{} \"foo\"\n"
73 "(string-null? y) @result{} #f\n"
75 #define FUNC_NAME s_scm_string_null_p
77 SCM_VALIDATE_STRING (1, str
);
78 return scm_from_bool (scm_i_string_length (str
) == 0);
86 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
90 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
91 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
92 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
94 "@var{char_pred} can be a character to check for any equal to that, or\n"
95 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
96 "or a predicate procedure to call.\n"
98 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
99 "successively on the characters from @var{start} to @var{end}. If\n"
100 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
101 "stops and that return value is the return from @code{string-any}. The\n"
102 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
103 "point is reached, is a tail call.\n"
105 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
106 "@var{end}) then the return is @code{#f}.\n")
107 #define FUNC_NAME s_scm_string_any
111 SCM res
= SCM_BOOL_F
;
113 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
117 if (SCM_CHARP (char_pred
))
119 res
= (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
121 ? SCM_BOOL_F
: SCM_BOOL_T
);
123 else if (SCM_CHARSETP (char_pred
))
126 for (i
= cstart
; i
< cend
; i
++)
127 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
135 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
136 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
138 while (cstart
< cend
)
140 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
141 if (scm_is_true (res
))
143 cstr
= scm_i_string_chars (s
);
148 scm_remember_upto_here_1 (s
);
154 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
155 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
156 "Check if @var{char_pred} is true for every character in string\n"
159 "@var{char_pred} can be a character to check for every character equal\n"
160 "to that, or a character set (@pxref{Character Sets}) to check for\n"
161 "every character being in that set, or a predicate procedure to call.\n"
163 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
164 "successively on the characters from @var{start} to @var{end}. If\n"
165 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
166 "returns @code{#f}. The call on the last character (ie.@: at\n"
167 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
168 "return from that call is the return from @code{string-every}.\n"
170 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
171 "@var{end}) then the return is @code{#t}.\n")
172 #define FUNC_NAME s_scm_string_every
176 SCM res
= SCM_BOOL_T
;
178 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
181 if (SCM_CHARP (char_pred
))
183 char cchr
= SCM_CHAR (char_pred
);
185 for (i
= cstart
; i
< cend
; i
++)
192 else if (SCM_CHARSETP (char_pred
))
195 for (i
= cstart
; i
< cend
; i
++)
196 if (!SCM_CHARSET_GET (char_pred
, cstr
[i
]))
204 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
205 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
207 while (cstart
< cend
)
209 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
210 if (scm_is_false (res
))
212 cstr
= scm_i_string_chars (s
);
217 scm_remember_upto_here_1 (s
);
223 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
225 "@var{proc} is an integer->char procedure. Construct a string\n"
226 "of size @var{len} by applying @var{proc} to each index to\n"
227 "produce the corresponding string element. The order in which\n"
228 "@var{proc} is applied to the indices is not specified.")
229 #define FUNC_NAME s_scm_string_tabulate
235 scm_t_trampoline_1 proc_tramp
;
237 proc_tramp
= scm_trampoline_1 (proc
);
238 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
240 clen
= scm_to_size_t (len
);
241 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
243 res
= scm_i_make_string (clen
, &p
);
247 /* The RES string remains untouched since nobody knows about it
248 yet. No need to refetch P.
250 ch
= proc_tramp (proc
, scm_from_size_t (i
));
252 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
253 *p
++ = SCM_CHAR (ch
);
261 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
262 (SCM str
, SCM start
, SCM end
),
263 "Convert the string @var{str} into a list of characters.")
264 #define FUNC_NAME s_scm_substring_to_list
268 SCM result
= SCM_EOL
;
270 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
273 while (cstart
< cend
)
276 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
277 cstr
= scm_i_string_chars (str
);
279 scm_remember_upto_here_1 (str
);
284 /* We export scm_substring_to_list as "string->list" since it is
285 compatible and more general. This function remains for the benefit
286 of C code that used it.
290 scm_string_to_list (SCM str
)
292 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
295 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
297 "An efficient implementation of @code{(compose string->list\n"
301 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
303 #define FUNC_NAME s_scm_reverse_list_to_string
306 long i
= scm_ilength (chrs
);
310 SCM_WRONG_TYPE_ARG (1, chrs
);
311 result
= scm_i_make_string (i
, &data
);
316 while (i
> 0 && scm_is_pair (chrs
))
318 SCM elt
= SCM_CAR (chrs
);
320 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
322 *data
= SCM_CHAR (elt
);
323 chrs
= SCM_CDR (chrs
);
333 SCM_SYMBOL (scm_sym_infix
, "infix");
334 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
335 SCM_SYMBOL (scm_sym_suffix
, "suffix");
336 SCM_SYMBOL (scm_sym_prefix
, "prefix");
339 append_string (char **sp
, size_t *lp
, SCM str
)
342 len
= scm_c_string_length (str
);
345 memcpy (*sp
, scm_i_string_chars (str
), len
);
350 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
351 (SCM ls
, SCM delimiter
, SCM grammar
),
352 "Append the string in the string list @var{ls}, using the string\n"
353 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
354 "@var{grammar} is a symbol which specifies how the delimiter is\n"
355 "placed between the strings, and defaults to the symbol\n"
360 "Insert the separator between list elements. An empty string\n"
361 "will produce an empty list.\n"
362 "@item string-infix\n"
363 "Like @code{infix}, but will raise an error if given the empty\n"
366 "Insert the separator after every list element.\n"
368 "Insert the separator before each list element.\n"
370 #define FUNC_NAME s_scm_string_join
373 #define GRAM_STRICT_INFIX 1
374 #define GRAM_SUFFIX 2
375 #define GRAM_PREFIX 3
378 int gram
= GRAM_INFIX
;
382 long strings
= scm_ilength (ls
);
384 /* Validate the string list. */
386 SCM_WRONG_TYPE_ARG (1, ls
);
388 /* Validate the delimiter and record its length. */
389 if (SCM_UNBNDP (delimiter
))
391 delimiter
= scm_from_locale_string (" ");
395 del_len
= scm_c_string_length (delimiter
);
397 /* Validate the grammar symbol and remember the grammar. */
398 if (SCM_UNBNDP (grammar
))
400 else if (scm_is_eq (grammar
, scm_sym_infix
))
402 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
403 gram
= GRAM_STRICT_INFIX
;
404 else if (scm_is_eq (grammar
, scm_sym_suffix
))
406 else if (scm_is_eq (grammar
, scm_sym_prefix
))
409 SCM_WRONG_TYPE_ARG (3, grammar
);
411 /* Check grammar constraints and calculate the space required for
416 if (!scm_is_null (ls
))
417 len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
419 case GRAM_STRICT_INFIX
:
421 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
423 len
= (strings
- 1) * del_len
;
426 len
= strings
* del_len
;
431 while (scm_is_pair (tmp
))
433 len
+= scm_c_string_length (SCM_CAR (tmp
));
437 result
= scm_i_make_string (len
, &p
);
443 case GRAM_STRICT_INFIX
:
444 while (scm_is_pair (tmp
))
446 append_string (&p
, &len
, SCM_CAR (tmp
));
447 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
448 append_string (&p
, &len
, delimiter
);
453 while (scm_is_pair (tmp
))
455 append_string (&p
, &len
, SCM_CAR (tmp
));
457 append_string (&p
, &len
, delimiter
);
462 while (scm_is_pair (tmp
))
465 append_string (&p
, &len
, delimiter
);
466 append_string (&p
, &len
, SCM_CAR (tmp
));
474 #undef GRAM_STRICT_INFIX
481 /* There are a number of functions to consider here for Scheme and C:
483 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
484 substring/copy STR start [end] ;; Guile variant of R5RS substring
486 scm_string_copy (str) ;; Old function from Guile
487 scm_substring_copy (str, [start, [end]])
488 ;; C version of SRFI-13 string-copy
489 ;; and C version of substring/copy
491 The C function underlying string-copy is not exported to C
492 programs. scm_substring_copy is defined in strings.c as the
493 underlying function of substring/copy and allows an optional START
497 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
499 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
500 (SCM str
, SCM start
, SCM end
),
501 "Return a freshly allocated copy of the string @var{str}. If\n"
502 "given, @var{start} and @var{end} delimit the portion of\n"
503 "@var{str} which is copied.")
504 #define FUNC_NAME s_scm_srfi13_substring_copy
509 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
512 return scm_c_substring_copy (str
, cstart
, cend
);
517 scm_string_copy (SCM str
)
519 return scm_c_substring (str
, 0, scm_c_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
535 size_t cstart
, cend
, ctstart
, dummy
, len
;
536 SCM sdummy
= SCM_UNDEFINED
;
538 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
541 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
545 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
547 ctarget
= scm_i_string_writable_chars (target
);
548 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
549 scm_i_string_stop_writing ();
550 scm_remember_upto_here_1 (target
);
552 return SCM_UNSPECIFIED
;
556 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
557 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
558 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
559 "into @var{str2} beginning at position @var{start2}.\n"
560 "@var{str1} and @var{str2} can be the same string.")
561 #define FUNC_NAME s_scm_substring_move_x
563 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
567 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
569 "Return the @var{n} first characters of @var{s}.")
570 #define FUNC_NAME s_scm_string_take
572 return scm_substring (s
, SCM_INUM0
, n
);
577 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
579 "Return all but the first @var{n} characters of @var{s}.")
580 #define FUNC_NAME s_scm_string_drop
582 return scm_substring (s
, n
, SCM_UNDEFINED
);
587 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
589 "Return the @var{n} last characters of @var{s}.")
590 #define FUNC_NAME s_scm_string_take_right
592 return scm_substring (s
,
593 scm_difference (scm_string_length (s
), n
),
599 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
601 "Return all but the last @var{n} characters of @var{s}.")
602 #define FUNC_NAME s_scm_string_drop_right
604 return scm_substring (s
,
606 scm_difference (scm_string_length (s
), n
));
611 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
612 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
613 "Take that characters from @var{start} to @var{end} from the\n"
614 "string @var{s} and return a new string, right-padded by the\n"
615 "character @var{chr} to length @var{len}. If the resulting\n"
616 "string is longer than @var{len}, it is truncated on the right.")
617 #define FUNC_NAME s_scm_string_pad
620 size_t cstart
, cend
, clen
;
622 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
625 clen
= scm_to_size_t (len
);
627 if (SCM_UNBNDP (chr
))
631 SCM_VALIDATE_CHAR (3, chr
);
632 cchr
= SCM_CHAR (chr
);
634 if (clen
< (cend
- cstart
))
635 return scm_c_substring (s
, cend
- clen
, cend
);
641 result
= scm_i_make_string (clen
, &dst
);
642 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
643 memmove (dst
+ clen
- (cend
- cstart
),
644 scm_i_string_chars (s
) + cstart
, cend
- cstart
);
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
660 size_t cstart
, cend
, clen
;
662 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
665 clen
= scm_to_size_t (len
);
667 if (SCM_UNBNDP (chr
))
671 SCM_VALIDATE_CHAR (3, chr
);
672 cchr
= SCM_CHAR (chr
);
674 if (clen
< (cend
- cstart
))
675 return scm_c_substring (s
, cstart
, cstart
+ clen
);
681 result
= scm_i_make_string (clen
, &dst
);
682 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
683 memmove (dst
, scm_i_string_chars (s
) + cstart
, cend
- cstart
);
690 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
691 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
692 "Trim @var{s} by skipping over all characters on the left\n"
693 "that satisfy the parameter @var{char_pred}:\n"
697 "if it is the character @var{ch}, characters equal to\n"
698 "@var{ch} are trimmed,\n"
701 "if it is a procedure @var{pred} characters that\n"
702 "satisfy @var{pred} are trimmed,\n"
705 "if it is a character set, characters in that set are trimmed.\n"
708 "If called without a @var{char_pred} argument, all whitespace is\n"
710 #define FUNC_NAME s_scm_string_trim
715 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
718 if (SCM_UNBNDP (char_pred
))
720 while (cstart
< cend
)
722 if (!isspace((int) (unsigned char) cstr
[cstart
]))
727 else if (SCM_CHARP (char_pred
))
729 char chr
= SCM_CHAR (char_pred
);
730 while (cstart
< cend
)
732 if (chr
!= cstr
[cstart
])
737 else if (SCM_CHARSETP (char_pred
))
739 while (cstart
< cend
)
741 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
748 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
749 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
751 while (cstart
< cend
)
755 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
756 if (scm_is_false (res
))
758 cstr
= scm_i_string_chars (s
);
762 return scm_c_substring (s
, cstart
, cend
);
767 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
768 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
769 "Trim @var{s} by skipping over all characters on the rightt\n"
770 "that satisfy the parameter @var{char_pred}:\n"
774 "if it is the character @var{ch}, characters equal to @var{ch}\n"
778 "if it is a procedure @var{pred} characters that satisfy\n"
779 "@var{pred} are trimmed,\n"
782 "if it is a character sets, all characters in that set are\n"
786 "If called without a @var{char_pred} argument, all whitespace is\n"
788 #define FUNC_NAME s_scm_string_trim_right
793 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
796 if (SCM_UNBNDP (char_pred
))
798 while (cstart
< cend
)
800 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
805 else if (SCM_CHARP (char_pred
))
807 char chr
= SCM_CHAR (char_pred
);
808 while (cstart
< cend
)
810 if (chr
!= cstr
[cend
- 1])
815 else if (SCM_CHARSETP (char_pred
))
817 while (cstart
< cend
)
819 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
826 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
827 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
829 while (cstart
< cend
)
833 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
834 if (scm_is_false (res
))
836 cstr
= scm_i_string_chars (s
);
840 return scm_c_substring (s
, cstart
, cend
);
845 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
846 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
847 "Trim @var{s} by skipping over all characters on both sides of\n"
848 "the string that satisfy the parameter @var{char_pred}:\n"
852 "if it is the character @var{ch}, characters equal to @var{ch}\n"
856 "if it is a procedure @var{pred} characters that satisfy\n"
857 "@var{pred} are trimmed,\n"
860 "if it is a character set, the characters in the set are\n"
864 "If called without a @var{char_pred} argument, all whitespace is\n"
866 #define FUNC_NAME s_scm_string_trim_both
871 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
874 if (SCM_UNBNDP (char_pred
))
876 while (cstart
< cend
)
878 if (!isspace((int) (unsigned char) cstr
[cstart
]))
882 while (cstart
< cend
)
884 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
889 else if (SCM_CHARP (char_pred
))
891 char chr
= SCM_CHAR (char_pred
);
892 while (cstart
< cend
)
894 if (chr
!= cstr
[cstart
])
898 while (cstart
< cend
)
900 if (chr
!= cstr
[cend
- 1])
905 else if (SCM_CHARSETP (char_pred
))
907 while (cstart
< cend
)
909 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
913 while (cstart
< cend
)
915 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
922 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
923 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
925 while (cstart
< cend
)
929 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
930 if (scm_is_false (res
))
932 cstr
= scm_i_string_chars (s
);
935 while (cstart
< cend
)
939 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
940 if (scm_is_false (res
))
942 cstr
= scm_i_string_chars (s
);
946 return scm_c_substring (s
, cstart
, cend
);
951 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
952 (SCM str
, SCM chr
, SCM start
, SCM end
),
953 "Stores @var{chr} in every element of the given @var{str} and\n"
954 "returns an unspecified value.")
955 #define FUNC_NAME s_scm_substring_fill_x
962 /* Older versions of Guile provided the function
963 scm_substring_fill_x with the following order of arguments:
967 We accomodate this here by detecting such a usage and reordering
978 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
981 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
983 cstr
= scm_i_string_writable_chars (str
);
984 for (k
= cstart
; k
< cend
; k
++)
986 scm_i_string_stop_writing ();
987 scm_remember_upto_here_1 (str
);
989 return SCM_UNSPECIFIED
;
994 scm_string_fill_x (SCM str
, SCM chr
)
996 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
999 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
1000 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1001 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1002 "mismatch index, depending upon whether @var{s1} is less than,\n"
1003 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1004 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1005 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1006 "@var{i} is the first position that does not match.")
1007 #define FUNC_NAME s_scm_string_compare
1009 const unsigned char *cstr1
, *cstr2
;
1010 size_t cstart1
, cend1
, cstart2
, cend2
;
1013 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1016 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1019 SCM_VALIDATE_PROC (3, proc_lt
);
1020 SCM_VALIDATE_PROC (4, proc_eq
);
1021 SCM_VALIDATE_PROC (5, proc_gt
);
1023 while (cstart1
< cend1
&& cstart2
< cend2
)
1025 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1030 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1038 if (cstart1
< cend1
)
1040 else if (cstart2
< cend2
)
1046 scm_remember_upto_here_2 (s1
, s2
);
1047 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1052 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1053 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1054 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1055 "mismatch index, depending upon whether @var{s1} is less than,\n"
1056 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1057 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1058 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1059 "@var{i} is the first position that does not match. The\n"
1060 "character comparison is done case-insensitively.")
1061 #define FUNC_NAME s_scm_string_compare_ci
1063 const unsigned char *cstr1
, *cstr2
;
1064 size_t cstart1
, cend1
, cstart2
, cend2
;
1067 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1070 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1073 SCM_VALIDATE_PROC (3, proc_lt
);
1074 SCM_VALIDATE_PROC (4, proc_eq
);
1075 SCM_VALIDATE_PROC (5, proc_gt
);
1077 while (cstart1
< cend1
&& cstart2
< cend2
)
1079 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1084 else if (scm_c_downcase (cstr1
[cstart1
])
1085 > scm_c_downcase (cstr2
[cstart2
]))
1094 if (cstart1
< cend1
)
1096 else if (cstart2
< cend2
)
1102 scm_remember_upto_here (s1
, s2
);
1103 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1108 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1109 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1110 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1112 #define FUNC_NAME s_scm_string_eq
1114 const char *cstr1
, *cstr2
;
1115 size_t cstart1
, cend1
, cstart2
, cend2
;
1117 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1120 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1124 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1127 while (cstart1
< cend1
)
1129 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1131 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1137 scm_remember_upto_here_2 (s1
, s2
);
1138 return scm_from_size_t (cstart1
);
1141 scm_remember_upto_here_2 (s1
, s2
);
1147 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1148 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1149 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1151 #define FUNC_NAME s_scm_string_neq
1153 const char *cstr1
, *cstr2
;
1154 size_t cstart1
, cend1
, cstart2
, cend2
;
1156 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1159 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1163 while (cstart1
< cend1
&& cstart2
< cend2
)
1165 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1167 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1172 if (cstart1
< cend1
)
1174 else if (cstart2
< cend2
)
1180 scm_remember_upto_here_2 (s1
, s2
);
1181 return scm_from_size_t (cstart1
);
1184 scm_remember_upto_here_2 (s1
, s2
);
1190 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1191 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1192 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1193 "true value otherwise.")
1194 #define FUNC_NAME s_scm_string_lt
1196 const unsigned char *cstr1
, *cstr2
;
1197 size_t cstart1
, cend1
, cstart2
, cend2
;
1199 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1202 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1206 while (cstart1
< cend1
&& cstart2
< cend2
)
1208 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1210 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1215 if (cstart1
< cend1
)
1217 else if (cstart2
< cend2
)
1223 scm_remember_upto_here_2 (s1
, s2
);
1224 return scm_from_size_t (cstart1
);
1227 scm_remember_upto_here_2 (s1
, s2
);
1233 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1234 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1235 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1236 "true value otherwise.")
1237 #define FUNC_NAME s_scm_string_gt
1239 const unsigned char *cstr1
, *cstr2
;
1240 size_t cstart1
, cend1
, cstart2
, cend2
;
1242 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1245 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1249 while (cstart1
< cend1
&& cstart2
< cend2
)
1251 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1253 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1258 if (cstart1
< cend1
)
1260 else if (cstart2
< cend2
)
1266 scm_remember_upto_here_2 (s1
, s2
);
1267 return scm_from_size_t (cstart1
);
1270 scm_remember_upto_here_2 (s1
, s2
);
1276 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1277 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1278 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1280 #define FUNC_NAME s_scm_string_le
1282 const unsigned char *cstr1
, *cstr2
;
1283 size_t cstart1
, cend1
, cstart2
, cend2
;
1285 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1288 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1292 while (cstart1
< cend1
&& cstart2
< cend2
)
1294 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1296 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1301 if (cstart1
< cend1
)
1303 else if (cstart2
< cend2
)
1309 scm_remember_upto_here_2 (s1
, s2
);
1310 return scm_from_size_t (cstart1
);
1313 scm_remember_upto_here_2 (s1
, s2
);
1319 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1320 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1321 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1323 #define FUNC_NAME s_scm_string_ge
1325 const unsigned char *cstr1
, *cstr2
;
1326 size_t cstart1
, cend1
, cstart2
, cend2
;
1328 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1331 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1335 while (cstart1
< cend1
&& cstart2
< cend2
)
1337 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1339 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1344 if (cstart1
< cend1
)
1346 else if (cstart2
< cend2
)
1352 scm_remember_upto_here_2 (s1
, s2
);
1353 return scm_from_size_t (cstart1
);
1356 scm_remember_upto_here_2 (s1
, s2
);
1362 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1363 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1364 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1365 "value otherwise. The character comparison is done\n"
1366 "case-insensitively.")
1367 #define FUNC_NAME s_scm_string_ci_eq
1369 const char *cstr1
, *cstr2
;
1370 size_t cstart1
, cend1
, cstart2
, cend2
;
1372 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1375 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1379 while (cstart1
< cend1
&& cstart2
< cend2
)
1381 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1383 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1388 if (cstart1
< cend1
)
1390 else if (cstart2
< cend2
)
1396 scm_remember_upto_here_2 (s1
, s2
);
1397 return scm_from_size_t (cstart1
);
1400 scm_remember_upto_here_2 (s1
, s2
);
1406 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1407 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1408 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1409 "value otherwise. The character comparison is done\n"
1410 "case-insensitively.")
1411 #define FUNC_NAME s_scm_string_ci_neq
1413 const char *cstr1
, *cstr2
;
1414 size_t cstart1
, cend1
, cstart2
, cend2
;
1416 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1419 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1423 while (cstart1
< cend1
&& cstart2
< cend2
)
1425 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1427 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1432 if (cstart1
< cend1
)
1434 else if (cstart2
< cend2
)
1440 scm_remember_upto_here_2 (s1
, s2
);
1441 return scm_from_size_t (cstart1
);
1444 scm_remember_upto_here_2 (s1
, s2
);
1450 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1451 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1452 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1453 "true value otherwise. The character comparison is done\n"
1454 "case-insensitively.")
1455 #define FUNC_NAME s_scm_string_ci_lt
1457 const unsigned char *cstr1
, *cstr2
;
1458 size_t cstart1
, cend1
, cstart2
, cend2
;
1460 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1463 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1467 while (cstart1
< cend1
&& cstart2
< cend2
)
1469 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1471 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1476 if (cstart1
< cend1
)
1478 else if (cstart2
< cend2
)
1484 scm_remember_upto_here_2 (s1
, s2
);
1485 return scm_from_size_t (cstart1
);
1488 scm_remember_upto_here_2 (s1
, s2
);
1494 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1495 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1496 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1497 "true value otherwise. The character comparison is done\n"
1498 "case-insensitively.")
1499 #define FUNC_NAME s_scm_string_ci_gt
1501 const unsigned char *cstr1
, *cstr2
;
1502 size_t cstart1
, cend1
, cstart2
, cend2
;
1504 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1507 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1511 while (cstart1
< cend1
&& cstart2
< cend2
)
1513 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1515 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1520 if (cstart1
< cend1
)
1522 else if (cstart2
< cend2
)
1528 scm_remember_upto_here_2 (s1
, s2
);
1529 return scm_from_size_t (cstart1
);
1532 scm_remember_upto_here_2 (s1
, s2
);
1538 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1539 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1540 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1541 "value otherwise. The character comparison is done\n"
1542 "case-insensitively.")
1543 #define FUNC_NAME s_scm_string_ci_le
1545 const unsigned char *cstr1
, *cstr2
;
1546 size_t cstart1
, cend1
, cstart2
, cend2
;
1548 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1551 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1555 while (cstart1
< cend1
&& cstart2
< cend2
)
1557 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1559 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1564 if (cstart1
< cend1
)
1566 else if (cstart2
< cend2
)
1572 scm_remember_upto_here_2 (s1
, s2
);
1573 return scm_from_size_t (cstart1
);
1576 scm_remember_upto_here_2 (s1
, s2
);
1582 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1583 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1584 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1585 "otherwise. The character comparison is done\n"
1586 "case-insensitively.")
1587 #define FUNC_NAME s_scm_string_ci_ge
1589 const unsigned char *cstr1
, *cstr2
;
1590 size_t cstart1
, cend1
, cstart2
, cend2
;
1592 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1
, cstr1
,
1595 MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2
, cstr2
,
1599 while (cstart1
< cend1
&& cstart2
< cend2
)
1601 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1603 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1608 if (cstart1
< cend1
)
1610 else if (cstart2
< cend2
)
1616 scm_remember_upto_here_2 (s1
, s2
);
1617 return scm_from_size_t (cstart1
);
1620 scm_remember_upto_here_2 (s1
, s2
);
1625 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1626 (SCM s
, SCM bound
, SCM start
, SCM end
),
1627 "Compute a hash value for @var{S}. the optional argument "
1628 "@var{bound} is a non-negative exact "
1629 "integer specifying the range of the hash function. "
1630 "A positive value restricts the return value to the "
1632 #define FUNC_NAME s_scm_substring_hash
1634 if (SCM_UNBNDP (bound
))
1635 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1636 if (SCM_UNBNDP (start
))
1638 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1642 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1643 (SCM s
, SCM bound
, SCM start
, SCM end
),
1644 "Compute a hash value for @var{S}. the optional argument "
1645 "@var{bound} is a non-negative exact "
1646 "integer specifying the range of the hash function. "
1647 "A positive value restricts the return value to the "
1649 #define FUNC_NAME s_scm_substring_hash_ci
1651 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1653 SCM_UNDEFINED
, SCM_UNDEFINED
);
1657 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1658 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1659 "Return the length of the longest common prefix of the two\n"
1661 #define FUNC_NAME s_scm_string_prefix_length
1663 const char *cstr1
, *cstr2
;
1664 size_t cstart1
, cend1
, cstart2
, cend2
;
1667 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1670 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1673 while (cstart1
< cend1
&& cstart2
< cend2
)
1675 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1683 scm_remember_upto_here_2 (s1
, s2
);
1684 return scm_from_size_t (len
);
1689 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1690 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1691 "Return the length of the longest common prefix of the two\n"
1692 "strings, ignoring character case.")
1693 #define FUNC_NAME s_scm_string_prefix_length_ci
1695 const char *cstr1
, *cstr2
;
1696 size_t cstart1
, cend1
, cstart2
, cend2
;
1699 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1702 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1705 while (cstart1
< cend1
&& cstart2
< cend2
)
1707 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1715 scm_remember_upto_here_2 (s1
, s2
);
1716 return scm_from_size_t (len
);
1721 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1722 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1723 "Return the length of the longest common suffix of the two\n"
1725 #define FUNC_NAME s_scm_string_suffix_length
1727 const char *cstr1
, *cstr2
;
1728 size_t cstart1
, cend1
, cstart2
, cend2
;
1731 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1734 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1737 while (cstart1
< cend1
&& cstart2
< cend2
)
1741 if (cstr1
[cend1
] != cstr2
[cend2
])
1747 scm_remember_upto_here_2 (s1
, s2
);
1748 return scm_from_size_t (len
);
1753 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1754 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1755 "Return the length of the longest common suffix of the two\n"
1756 "strings, ignoring character case.")
1757 #define FUNC_NAME s_scm_string_suffix_length_ci
1759 const char *cstr1
, *cstr2
;
1760 size_t cstart1
, cend1
, cstart2
, cend2
;
1763 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1766 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1769 while (cstart1
< cend1
&& cstart2
< cend2
)
1773 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1779 scm_remember_upto_here_2 (s1
, s2
);
1780 return scm_from_size_t (len
);
1785 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1786 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1787 "Is @var{s1} a prefix of @var{s2}?")
1788 #define FUNC_NAME s_scm_string_prefix_p
1790 const char *cstr1
, *cstr2
;
1791 size_t cstart1
, cend1
, cstart2
, cend2
;
1792 size_t len
= 0, len1
;
1794 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1797 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1800 len1
= cend1
- cstart1
;
1801 while (cstart1
< cend1
&& cstart2
< cend2
)
1803 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1811 scm_remember_upto_here_2 (s1
, s2
);
1812 return scm_from_bool (len
== len1
);
1817 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1818 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1819 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1820 #define FUNC_NAME s_scm_string_prefix_ci_p
1822 const char *cstr1
, *cstr2
;
1823 size_t cstart1
, cend1
, cstart2
, cend2
;
1824 size_t len
= 0, len1
;
1826 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1829 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1832 len1
= cend1
- cstart1
;
1833 while (cstart1
< cend1
&& cstart2
< cend2
)
1835 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1843 scm_remember_upto_here_2 (s1
, s2
);
1844 return scm_from_bool (len
== len1
);
1849 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1850 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1851 "Is @var{s1} a suffix of @var{s2}?")
1852 #define FUNC_NAME s_scm_string_suffix_p
1854 const char *cstr1
, *cstr2
;
1855 size_t cstart1
, cend1
, cstart2
, cend2
;
1856 size_t len
= 0, len1
;
1858 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1861 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1864 len1
= cend1
- cstart1
;
1865 while (cstart1
< cend1
&& cstart2
< cend2
)
1869 if (cstr1
[cend1
] != cstr2
[cend2
])
1875 scm_remember_upto_here_2 (s1
, s2
);
1876 return scm_from_bool (len
== len1
);
1881 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1882 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1883 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1884 #define FUNC_NAME s_scm_string_suffix_ci_p
1886 const char *cstr1
, *cstr2
;
1887 size_t cstart1
, cend1
, cstart2
, cend2
;
1888 size_t len
= 0, len1
;
1890 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1893 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1896 len1
= cend1
- cstart1
;
1897 while (cstart1
< cend1
&& cstart2
< cend2
)
1901 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1907 scm_remember_upto_here_2 (s1
, s2
);
1908 return scm_from_bool (len
== len1
);
1913 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1914 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1915 "Search through the string @var{s} from left to right, returning\n"
1916 "the index of the first occurence of a character which\n"
1918 "@itemize @bullet\n"
1920 "equals @var{char_pred}, if it is character,\n"
1923 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1926 "is in the set @var{char_pred}, if it is a character set.\n"
1928 #define FUNC_NAME s_scm_string_index
1931 size_t cstart
, cend
;
1933 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1936 if (SCM_CHARP (char_pred
))
1938 char cchr
= SCM_CHAR (char_pred
);
1939 while (cstart
< cend
)
1941 if (cchr
== cstr
[cstart
])
1946 else if (SCM_CHARSETP (char_pred
))
1948 while (cstart
< cend
)
1950 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1957 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1958 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1960 while (cstart
< cend
)
1963 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1964 if (scm_is_true (res
))
1966 cstr
= scm_i_string_chars (s
);
1971 scm_remember_upto_here_1 (s
);
1975 scm_remember_upto_here_1 (s
);
1976 return scm_from_size_t (cstart
);
1980 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1981 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1982 "Search through the string @var{s} from right to left, returning\n"
1983 "the index of the last occurence of a character which\n"
1985 "@itemize @bullet\n"
1987 "equals @var{char_pred}, if it is character,\n"
1990 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1993 "is in the set if @var{char_pred} is a character set.\n"
1995 #define FUNC_NAME s_scm_string_index_right
1998 size_t cstart
, cend
;
2000 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2003 if (SCM_CHARP (char_pred
))
2005 char cchr
= SCM_CHAR (char_pred
);
2006 while (cstart
< cend
)
2009 if (cchr
== cstr
[cend
])
2013 else if (SCM_CHARSETP (char_pred
))
2015 while (cstart
< cend
)
2018 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2024 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2025 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2027 while (cstart
< cend
)
2031 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2032 if (scm_is_true (res
))
2034 cstr
= scm_i_string_chars (s
);
2038 scm_remember_upto_here_1 (s
);
2042 scm_remember_upto_here_1 (s
);
2043 return scm_from_size_t (cend
);
2047 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
2048 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2049 "Search through the string @var{s} from right to left, returning\n"
2050 "the index of the last occurence of a character which\n"
2052 "@itemize @bullet\n"
2054 "equals @var{char_pred}, if it is character,\n"
2057 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2060 "is in the set if @var{char_pred} is a character set.\n"
2062 #define FUNC_NAME s_scm_string_rindex
2064 return scm_string_index_right (s
, char_pred
, start
, end
);
2068 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
2069 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2070 "Search through the string @var{s} from left to right, returning\n"
2071 "the index of the first occurence of a character which\n"
2073 "@itemize @bullet\n"
2075 "does not equal @var{char_pred}, if it is character,\n"
2078 "does not satisify the predicate @var{char_pred}, if it is a\n"
2082 "is not in the set if @var{char_pred} is a character set.\n"
2084 #define FUNC_NAME s_scm_string_skip
2087 size_t cstart
, cend
;
2089 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2092 if (SCM_CHARP (char_pred
))
2094 char cchr
= SCM_CHAR (char_pred
);
2095 while (cstart
< cend
)
2097 if (cchr
!= cstr
[cstart
])
2102 else if (SCM_CHARSETP (char_pred
))
2104 while (cstart
< cend
)
2106 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2113 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2114 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2116 while (cstart
< cend
)
2119 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2120 if (scm_is_false (res
))
2122 cstr
= scm_i_string_chars (s
);
2127 scm_remember_upto_here_1 (s
);
2131 scm_remember_upto_here_1 (s
);
2132 return scm_from_size_t (cstart
);
2137 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2138 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2139 "Search through the string @var{s} from right to left, returning\n"
2140 "the index of the last occurence of a character which\n"
2142 "@itemize @bullet\n"
2144 "does not equal @var{char_pred}, if it is character,\n"
2147 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2151 "is not in the set if @var{char_pred} is a character set.\n"
2153 #define FUNC_NAME s_scm_string_skip_right
2156 size_t cstart
, cend
;
2158 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2161 if (SCM_CHARP (char_pred
))
2163 char cchr
= SCM_CHAR (char_pred
);
2164 while (cstart
< cend
)
2167 if (cchr
!= cstr
[cend
])
2171 else if (SCM_CHARSETP (char_pred
))
2173 while (cstart
< cend
)
2176 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2182 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2183 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2185 while (cstart
< cend
)
2189 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2190 if (scm_is_false (res
))
2192 cstr
= scm_i_string_chars (s
);
2196 scm_remember_upto_here_1 (s
);
2200 scm_remember_upto_here_1 (s
);
2201 return scm_from_size_t (cend
);
2207 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2208 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2209 "Return the count of the number of characters in the string\n"
2212 "@itemize @bullet\n"
2214 "equals @var{char_pred}, if it is character,\n"
2217 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2220 "is in the set @var{char_pred}, if it is a character set.\n"
2222 #define FUNC_NAME s_scm_string_count
2225 size_t cstart
, cend
;
2228 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2231 if (SCM_CHARP (char_pred
))
2233 char cchr
= SCM_CHAR (char_pred
);
2234 while (cstart
< cend
)
2236 if (cchr
== cstr
[cstart
])
2241 else if (SCM_CHARSETP (char_pred
))
2243 while (cstart
< cend
)
2245 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2252 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2253 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2255 while (cstart
< cend
)
2258 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2259 if (scm_is_true (res
))
2261 cstr
= scm_i_string_chars (s
);
2266 scm_remember_upto_here_1 (s
);
2267 return scm_from_size_t (count
);
2272 /* FIXME::martin: This should definitely get implemented more
2273 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2275 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2276 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2277 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2278 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2279 "The optional start/end indices restrict the operation to the\n"
2280 "indicated substrings.")
2281 #define FUNC_NAME s_scm_string_contains
2283 const char *cs1
, * cs2
;
2284 size_t cstart1
, cend1
, cstart2
, cend2
;
2287 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2290 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2293 len2
= cend2
- cstart2
;
2294 if (cend1
- cstart1
>= len2
)
2295 while (cstart1
<= cend1
- len2
)
2299 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2306 scm_remember_upto_here_2 (s1
, s2
);
2307 return scm_from_size_t (cstart1
);
2312 scm_remember_upto_here_2 (s1
, s2
);
2318 /* FIXME::martin: This should definitely get implemented more
2319 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2321 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2322 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2323 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2324 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2325 "The optional start/end indices restrict the operation to the\n"
2326 "indicated substrings. Character comparison is done\n"
2327 "case-insensitively.")
2328 #define FUNC_NAME s_scm_string_contains_ci
2330 const char *cs1
, * cs2
;
2331 size_t cstart1
, cend1
, cstart2
, cend2
;
2334 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2337 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2340 len2
= cend2
- cstart2
;
2341 if (cend1
- cstart1
>= len2
)
2342 while (cstart1
<= cend1
- len2
)
2346 while (i
< cend1
&& j
< cend2
&&
2347 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2354 scm_remember_upto_here_2 (s1
, s2
);
2355 return scm_from_size_t (cstart1
);
2360 scm_remember_upto_here_2 (s1
, s2
);
2366 /* Helper function for the string uppercase conversion functions.
2367 * No argument checking is performed. */
2369 string_upcase_x (SCM v
, size_t start
, size_t end
)
2374 dst
= scm_i_string_writable_chars (v
);
2375 for (k
= start
; k
< end
; ++k
)
2376 dst
[k
] = scm_c_upcase (dst
[k
]);
2377 scm_i_string_stop_writing ();
2378 scm_remember_upto_here_1 (v
);
2383 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2384 (SCM str
, SCM start
, SCM end
),
2385 "Destructively upcase every character in @code{str}.\n"
2388 "(string-upcase! y)\n"
2389 "@result{} \"ARRDEFG\"\n"
2391 "@result{} \"ARRDEFG\"\n"
2393 #define FUNC_NAME s_scm_substring_upcase_x
2396 size_t cstart
, cend
;
2398 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2401 return string_upcase_x (str
, cstart
, cend
);
2406 scm_string_upcase_x (SCM str
)
2408 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2411 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2412 (SCM str
, SCM start
, SCM end
),
2413 "Upcase every character in @code{str}.")
2414 #define FUNC_NAME s_scm_substring_upcase
2417 size_t cstart
, cend
;
2419 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2422 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2427 scm_string_upcase (SCM str
)
2429 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2432 /* Helper function for the string lowercase conversion functions.
2433 * No argument checking is performed. */
2435 string_downcase_x (SCM v
, size_t start
, size_t end
)
2440 dst
= scm_i_string_writable_chars (v
);
2441 for (k
= start
; k
< end
; ++k
)
2442 dst
[k
] = scm_c_downcase (dst
[k
]);
2443 scm_i_string_stop_writing ();
2444 scm_remember_upto_here_1 (v
);
2449 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2450 (SCM str
, SCM start
, SCM end
),
2451 "Destructively downcase every character in @var{str}.\n"
2455 "@result{} \"ARRDEFG\"\n"
2456 "(string-downcase! y)\n"
2457 "@result{} \"arrdefg\"\n"
2459 "@result{} \"arrdefg\"\n"
2461 #define FUNC_NAME s_scm_substring_downcase_x
2464 size_t cstart
, cend
;
2466 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2469 return string_downcase_x (str
, cstart
, cend
);
2474 scm_string_downcase_x (SCM str
)
2476 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2479 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2480 (SCM str
, SCM start
, SCM end
),
2481 "Downcase every character in @var{str}.")
2482 #define FUNC_NAME s_scm_substring_downcase
2485 size_t cstart
, cend
;
2487 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2490 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2495 scm_string_downcase (SCM str
)
2497 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2500 /* Helper function for the string capitalization functions.
2501 * No argument checking is performed. */
2503 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2509 sz
= (unsigned char *) scm_i_string_writable_chars (str
);
2510 for(i
= start
; i
< end
; i
++)
2512 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2516 sz
[i
] = scm_c_upcase(sz
[i
]);
2521 sz
[i
] = scm_c_downcase(sz
[i
]);
2527 scm_i_string_stop_writing ();
2528 scm_remember_upto_here_1 (str
);
2534 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2535 (SCM str
, SCM start
, SCM end
),
2536 "Destructively titlecase every first character in a word in\n"
2538 #define FUNC_NAME s_scm_string_titlecase_x
2541 size_t cstart
, cend
;
2543 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2546 return string_titlecase_x (str
, cstart
, cend
);
2551 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2552 (SCM str
, SCM start
, SCM end
),
2553 "Titlecase every first character in a word in @var{str}.")
2554 #define FUNC_NAME s_scm_string_titlecase
2557 size_t cstart
, cend
;
2559 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2562 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2566 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2568 "Upcase the first character of every word in @var{str}\n"
2569 "destructively and return @var{str}.\n"
2572 "y @result{} \"hello world\"\n"
2573 "(string-capitalize! y) @result{} \"Hello World\"\n"
2574 "y @result{} \"Hello World\"\n"
2576 #define FUNC_NAME s_scm_string_capitalize_x
2578 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2583 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2585 "Return a freshly allocated string with the characters in\n"
2586 "@var{str}, where the first character of every word is\n"
2588 #define FUNC_NAME s_scm_string_capitalize
2590 return scm_string_capitalize_x (scm_string_copy (str
));
2595 /* Reverse the portion of @var{str} between str[cstart] (including)
2596 and str[cend] excluding. */
2598 string_reverse_x (char * str
, size_t cstart
, size_t cend
)
2605 while (cstart
< cend
)
2608 str
[cstart
] = str
[cend
];
2617 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2618 (SCM str
, SCM start
, SCM end
),
2619 "Reverse the string @var{str}. The optional arguments\n"
2620 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2622 #define FUNC_NAME s_scm_string_reverse
2626 size_t cstart
, cend
;
2629 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2632 result
= scm_string_copy (str
);
2633 ctarget
= scm_i_string_writable_chars (result
);
2634 string_reverse_x (ctarget
, cstart
, cend
);
2635 scm_i_string_stop_writing ();
2636 scm_remember_upto_here_1 (str
);
2642 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2643 (SCM str
, SCM start
, SCM end
),
2644 "Reverse the string @var{str} in-place. The optional arguments\n"
2645 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2646 "operate on. The return value is unspecified.")
2647 #define FUNC_NAME s_scm_string_reverse_x
2650 size_t cstart
, cend
;
2652 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2656 cstr
= scm_i_string_writable_chars (str
);
2657 string_reverse_x (cstr
, cstart
, cend
);
2658 scm_i_string_stop_writing ();
2659 scm_remember_upto_here_1 (str
);
2660 return SCM_UNSPECIFIED
;
2665 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2667 "Like @code{string-append}, but the result may share memory\n"
2668 "with the argument strings.")
2669 #define FUNC_NAME s_scm_string_append_shared
2671 /* If "rest" contains just one non-empty string, return that.
2672 If it's entirely empty strings, then return scm_nullstr.
2673 Otherwise use scm_string_concatenate. */
2675 SCM ret
= scm_nullstr
;
2676 int seen_nonempty
= 0;
2679 SCM_VALIDATE_REST_ARGUMENT (rest
);
2681 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2684 if (scm_c_string_length (s
) != 0)
2687 /* two or more non-empty strings, need full concat */
2688 return scm_string_append (rest
);
2699 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2701 "Append the elements of @var{ls} (which must be strings)\n"
2702 "together into a single string. Guaranteed to return a freshly\n"
2703 "allocated string.")
2704 #define FUNC_NAME s_scm_string_concatenate
2706 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2707 return scm_string_append (ls
);
2712 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2713 (SCM ls
, SCM final_string
, SCM end
),
2714 "Without optional arguments, this procedure is equivalent to\n"
2717 "(string-concatenate (reverse ls))\n"
2720 "If the optional argument @var{final_string} is specified, it is\n"
2721 "consed onto the beginning to @var{ls} before performing the\n"
2722 "list-reverse and string-concatenate operations. If @var{end}\n"
2723 "is given, only the characters of @var{final_string} up to index\n"
2724 "@var{end} are used.\n"
2726 "Guaranteed to return a freshly allocated string.")
2727 #define FUNC_NAME s_scm_string_concatenate_reverse
2729 if (!SCM_UNBNDP (end
))
2730 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2732 if (!SCM_UNBNDP (final_string
))
2733 ls
= scm_cons (final_string
, ls
);
2735 return scm_string_concatenate (scm_reverse (ls
));
2740 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2742 "Like @code{string-concatenate}, but the result may share memory\n"
2743 "with the strings in the list @var{ls}.")
2744 #define FUNC_NAME s_scm_string_concatenate_shared
2746 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2747 return scm_string_append_shared (ls
);
2752 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2753 (SCM ls
, SCM final_string
, SCM end
),
2754 "Like @code{string-concatenate-reverse}, but the result may\n"
2755 "share memory with the the strings in the @var{ls} arguments.")
2756 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2758 /* Just call the non-sharing version. */
2759 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2764 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2765 (SCM proc
, SCM s
, SCM start
, SCM end
),
2766 "@var{proc} is a char->char procedure, it is mapped over\n"
2767 "@var{s}. The order in which the procedure is applied to the\n"
2768 "string elements is not specified.")
2769 #define FUNC_NAME s_scm_string_map
2772 size_t cstart
, cend
;
2774 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2776 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2777 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2780 result
= scm_i_make_string (cend
- cstart
, &p
);
2781 while (cstart
< cend
)
2783 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2784 if (!SCM_CHARP (ch
))
2785 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2787 *p
++ = SCM_CHAR (ch
);
2794 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2795 (SCM proc
, SCM s
, SCM start
, SCM end
),
2796 "@var{proc} is a char->char procedure, it is mapped over\n"
2797 "@var{s}. The order in which the procedure is applied to the\n"
2798 "string elements is not specified. The string @var{s} is\n"
2799 "modified in-place, the return value is not specified.")
2800 #define FUNC_NAME s_scm_string_map_x
2802 size_t cstart
, cend
;
2803 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2805 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2806 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2809 while (cstart
< cend
)
2811 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2812 if (!SCM_CHARP (ch
))
2813 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2814 scm_c_string_set_x (s
, cstart
, ch
);
2817 return SCM_UNSPECIFIED
;
2822 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2823 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2824 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2825 "as the terminating element, from left to right. @var{kons}\n"
2826 "must expect two arguments: The actual character and the last\n"
2827 "result of @var{kons}' application.")
2828 #define FUNC_NAME s_scm_string_fold
2831 size_t cstart
, cend
;
2834 SCM_VALIDATE_PROC (1, kons
);
2835 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2839 while (cstart
< cend
)
2841 unsigned int c
= (unsigned char) cstr
[cstart
];
2842 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2843 cstr
= scm_i_string_chars (s
);
2847 scm_remember_upto_here_1 (s
);
2853 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2854 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2855 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2856 "as the terminating element, from right to left. @var{kons}\n"
2857 "must expect two arguments: The actual character and the last\n"
2858 "result of @var{kons}' application.")
2859 #define FUNC_NAME s_scm_string_fold_right
2862 size_t cstart
, cend
;
2865 SCM_VALIDATE_PROC (1, kons
);
2866 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2870 while (cstart
< cend
)
2872 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2873 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2874 cstr
= scm_i_string_chars (s
);
2878 scm_remember_upto_here_1 (s
);
2884 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2885 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2886 "@itemize @bullet\n"
2887 "@item @var{g} is used to generate a series of @emph{seed}\n"
2888 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2889 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2891 "@item @var{p} tells us when to stop -- when it returns true\n"
2892 "when applied to one of these seed values.\n"
2893 "@item @var{f} maps each seed value to the corresponding\n"
2894 "character in the result string. These chars are assembled\n"
2895 "into the string in a left-to-right order.\n"
2896 "@item @var{base} is the optional initial/leftmost portion\n"
2897 "of the constructed string; it default to the empty\n"
2899 "@item @var{make_final} is applied to the terminal seed\n"
2900 "value (on which @var{p} returns true) to produce\n"
2901 "the final/rightmost portion of the constructed string.\n"
2902 "It defaults to @code{(lambda (x) "")}.\n"
2904 #define FUNC_NAME s_scm_string_unfold
2908 SCM_VALIDATE_PROC (1, p
);
2909 SCM_VALIDATE_PROC (2, f
);
2910 SCM_VALIDATE_PROC (3, g
);
2911 if (!SCM_UNBNDP (base
))
2913 SCM_VALIDATE_STRING (5, base
);
2917 ans
= scm_i_make_string (0, NULL
);
2918 if (!SCM_UNBNDP (make_final
))
2919 SCM_VALIDATE_PROC (6, make_final
);
2921 res
= scm_call_1 (p
, seed
);
2922 while (scm_is_false (res
))
2926 SCM ch
= scm_call_1 (f
, seed
);
2927 if (!SCM_CHARP (ch
))
2928 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2929 str
= scm_i_make_string (1, &ptr
);
2930 *ptr
= SCM_CHAR (ch
);
2932 ans
= scm_string_append (scm_list_2 (ans
, str
));
2933 seed
= scm_call_1 (g
, seed
);
2934 res
= scm_call_1 (p
, seed
);
2936 if (!SCM_UNBNDP (make_final
))
2938 res
= scm_call_1 (make_final
, seed
);
2939 return scm_string_append (scm_list_2 (ans
, res
));
2947 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2948 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2949 "@itemize @bullet\n"
2950 "@item @var{g} is used to generate a series of @emph{seed}\n"
2951 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2952 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2954 "@item @var{p} tells us when to stop -- when it returns true\n"
2955 "when applied to one of these seed values.\n"
2956 "@item @var{f} maps each seed value to the corresponding\n"
2957 "character in the result string. These chars are assembled\n"
2958 "into the string in a right-to-left order.\n"
2959 "@item @var{base} is the optional initial/rightmost portion\n"
2960 "of the constructed string; it default to the empty\n"
2962 "@item @var{make_final} is applied to the terminal seed\n"
2963 "value (on which @var{p} returns true) to produce\n"
2964 "the final/leftmost portion of the constructed string.\n"
2965 "It defaults to @code{(lambda (x) "")}.\n"
2967 #define FUNC_NAME s_scm_string_unfold_right
2971 SCM_VALIDATE_PROC (1, p
);
2972 SCM_VALIDATE_PROC (2, f
);
2973 SCM_VALIDATE_PROC (3, g
);
2974 if (!SCM_UNBNDP (base
))
2976 SCM_VALIDATE_STRING (5, base
);
2980 ans
= scm_i_make_string (0, NULL
);
2981 if (!SCM_UNBNDP (make_final
))
2982 SCM_VALIDATE_PROC (6, make_final
);
2984 res
= scm_call_1 (p
, seed
);
2985 while (scm_is_false (res
))
2989 SCM ch
= scm_call_1 (f
, seed
);
2990 if (!SCM_CHARP (ch
))
2991 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2992 str
= scm_i_make_string (1, &ptr
);
2993 *ptr
= SCM_CHAR (ch
);
2995 ans
= scm_string_append (scm_list_2 (str
, ans
));
2996 seed
= scm_call_1 (g
, seed
);
2997 res
= scm_call_1 (p
, seed
);
2999 if (!SCM_UNBNDP (make_final
))
3001 res
= scm_call_1 (make_final
, seed
);
3002 return scm_string_append (scm_list_2 (res
, ans
));
3010 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
3011 (SCM proc
, SCM s
, SCM start
, SCM end
),
3012 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
3013 "return value is not specified.")
3014 #define FUNC_NAME s_scm_string_for_each
3017 size_t cstart
, cend
;
3018 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
3020 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
3021 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
3024 while (cstart
< cend
)
3026 unsigned int c
= (unsigned char) cstr
[cstart
];
3027 proc_tramp (proc
, SCM_MAKE_CHAR (c
));
3028 cstr
= scm_i_string_chars (s
);
3032 scm_remember_upto_here_1 (s
);
3033 return SCM_UNSPECIFIED
;
3037 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
3038 (SCM proc
, SCM s
, SCM start
, SCM end
),
3039 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
3042 "For example, to change characters to alternately upper and\n"
3046 "(define str (string-copy \"studly\"))\n"
3047 "(string-for-each-index\n"
3049 " (string-set! str i\n"
3050 " ((if (even? i) char-upcase char-downcase)\n"
3051 " (string-ref str i))))\n"
3053 "str @result{} \"StUdLy\"\n"
3055 #define FUNC_NAME s_scm_string_for_each_index
3057 size_t cstart
, cend
;
3058 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
3060 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
3061 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3065 while (cstart
< cend
)
3067 proc_tramp (proc
, scm_from_size_t (cstart
));
3071 scm_remember_upto_here_1 (s
);
3072 return SCM_UNSPECIFIED
;
3076 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
3077 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
3078 "This is the @emph{extended substring} procedure that implements\n"
3079 "replicated copying of a substring of some string.\n"
3081 "@var{s} is a string, @var{start} and @var{end} are optional\n"
3082 "arguments that demarcate a substring of @var{s}, defaulting to\n"
3083 "0 and the length of @var{s}. Replicate this substring up and\n"
3084 "down index space, in both the positive and negative directions.\n"
3085 "@code{xsubstring} returns the substring of this string\n"
3086 "beginning at index @var{from}, and ending at @var{to}, which\n"
3087 "defaults to @var{from} + (@var{end} - @var{start}).")
3088 #define FUNC_NAME s_scm_xsubstring
3092 size_t cstart
, cend
;
3096 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3100 cfrom
= scm_to_int (from
);
3101 if (SCM_UNBNDP (to
))
3102 cto
= cfrom
+ (cend
- cstart
);
3104 cto
= scm_to_int (to
);
3105 if (cstart
== cend
&& cfrom
!= cto
)
3106 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3108 result
= scm_i_make_string (cto
- cfrom
, &p
);
3110 cs
= scm_i_string_chars (s
);
3113 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
3115 *p
= cs
[(cend
- cstart
) - t
];
3122 scm_remember_upto_here_1 (s
);
3128 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3129 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3130 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3131 "is written into the string @var{target} starting at index\n"
3132 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3133 "@var{target} @var{s})} or these arguments share storage -- you\n"
3134 "cannot copy a string on top of itself.")
3135 #define FUNC_NAME s_scm_string_xcopy_x
3139 size_t ctstart
, cstart
, cend
;
3141 SCM dummy
= SCM_UNDEFINED
;
3144 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3147 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
3150 csfrom
= scm_to_int (sfrom
);
3151 if (SCM_UNBNDP (sto
))
3152 csto
= csfrom
+ (cend
- cstart
);
3154 csto
= scm_to_int (sto
);
3155 if (cstart
== cend
&& csfrom
!= csto
)
3156 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3157 SCM_ASSERT_RANGE (1, tstart
,
3158 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3160 p
= scm_i_string_writable_chars (target
) + ctstart
;
3161 cs
= scm_i_string_chars (s
);
3162 while (csfrom
< csto
)
3164 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3166 *p
= cs
[(cend
- cstart
) - t
];
3172 scm_i_string_stop_writing ();
3174 scm_remember_upto_here_2 (target
, s
);
3175 return SCM_UNSPECIFIED
;
3180 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3181 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3182 "Return the string @var{s1}, but with the characters\n"
3183 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3184 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3185 #define FUNC_NAME s_scm_string_replace
3187 const char *cstr1
, *cstr2
;
3189 size_t cstart1
, cend1
, cstart2
, cend2
;
3192 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
3195 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
3198 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3199 scm_i_string_length (s1
) - cend1
, &p
);
3200 cstr1
= scm_i_string_chars (s1
);
3201 cstr2
= scm_i_string_chars (s2
);
3202 memmove (p
, cstr1
, cstart1
* sizeof (char));
3203 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3204 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3206 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3207 scm_remember_upto_here_2 (s1
, s2
);
3213 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3214 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3215 "Split the string @var{s} into a list of substrings, where each\n"
3216 "substring is a maximal non-empty contiguous sequence of\n"
3217 "characters from the character set @var{token_set}, which\n"
3218 "defaults to @code{char-set:graphic}.\n"
3219 "If @var{start} or @var{end} indices are provided, they restrict\n"
3220 "@code{string-tokenize} to operating on the indicated substring\n"
3222 #define FUNC_NAME s_scm_string_tokenize
3225 size_t cstart
, cend
;
3226 SCM result
= SCM_EOL
;
3228 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3232 if (SCM_UNBNDP (token_set
))
3233 token_set
= scm_char_set_graphic
;
3235 if (SCM_CHARSETP (token_set
))
3239 while (cstart
< cend
)
3241 while (cstart
< cend
)
3243 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3250 while (cstart
< cend
)
3252 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3256 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3257 cstr
= scm_i_string_chars (s
);
3261 SCM_WRONG_TYPE_ARG (2, token_set
);
3263 scm_remember_upto_here_1 (s
);
3268 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3270 "Split the string @var{str} into the a list of the substrings delimited\n"
3271 "by appearances of the character @var{chr}. Note that an empty substring\n"
3272 "between separator characters will result in an empty string in the\n"
3276 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3278 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3280 "(string-split \"::\" #\\:)\n"
3282 "(\"\" \"\" \"\")\n"
3284 "(string-split \"\" #\\:)\n"
3288 #define FUNC_NAME s_scm_string_split
3295 SCM_VALIDATE_STRING (1, str
);
3296 SCM_VALIDATE_CHAR (2, chr
);
3298 idx
= scm_i_string_length (str
);
3299 p
= scm_i_string_chars (str
);
3300 ch
= SCM_CHAR (chr
);
3304 while (idx
> 0 && p
[idx
- 1] != ch
)
3308 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3309 p
= scm_i_string_chars (str
);
3313 scm_remember_upto_here_1 (str
);
3319 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3320 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3321 "Filter the string @var{s}, retaining only those characters\n"
3322 "which satisfy @var{char_pred}.\n"
3324 "If @var{char_pred} is a procedure, it is applied to each\n"
3325 "character as a predicate, if it is a character, it is tested\n"
3326 "for equality and if it is a character set, it is tested for\n"
3328 #define FUNC_NAME s_scm_string_filter
3331 size_t cstart
, cend
;
3335 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3339 /* The explicit loops below stripping leading and trailing non-matches
3340 mean we can return a substring if those are the only deletions, making
3341 string-filter as efficient as string-trim-both in that case. */
3343 if (SCM_CHARP (char_pred
))
3348 chr
= SCM_CHAR (char_pred
);
3350 /* strip leading non-matches by incrementing cstart */
3351 while (cstart
< cend
&& cstr
[cstart
] != chr
)
3354 /* strip trailing non-matches by decrementing cend */
3355 while (cend
> cstart
&& cstr
[cend
-1] != chr
)
3358 /* count chars to keep */
3360 for (idx
= cstart
; idx
< cend
; idx
++)
3361 if (cstr
[idx
] == chr
)
3364 if (count
== cend
- cstart
)
3366 /* whole of cstart to cend is to be kept, return a copy-on-write
3369 result
= scm_i_substring (s
, cstart
, cend
);
3372 result
= scm_c_make_string (count
, char_pred
);
3374 else if (SCM_CHARSETP (char_pred
))
3378 /* strip leading non-matches by incrementing cstart */
3379 while (cstart
< cend
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3382 /* strip trailing non-matches by decrementing cend */
3383 while (cend
> cstart
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3386 /* count chars to be kept */
3388 for (idx
= cstart
; idx
< cend
; idx
++)
3389 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3392 /* if whole of start to end kept then return substring */
3393 if (count
== cend
- cstart
)
3394 goto result_substring
;
3398 result
= scm_i_make_string (count
, &dst
);
3399 cstr
= scm_i_string_chars (s
);
3401 /* decrement "count" in this loop as well as using idx, so that if
3402 another thread is simultaneously changing "s" there's no chance
3403 it'll make us copy more than count characters */
3404 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3406 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3417 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3419 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3424 ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3425 res
= pred_tramp (char_pred
, ch
);
3426 if (scm_is_true (res
))
3427 ls
= scm_cons (ch
, ls
);
3428 cstr
= scm_i_string_chars (s
);
3431 result
= scm_reverse_list_to_string (ls
);
3434 scm_remember_upto_here_1 (s
);
3440 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3441 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3442 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3444 "If @var{char_pred} is a procedure, it is applied to each\n"
3445 "character as a predicate, if it is a character, it is tested\n"
3446 "for equality and if it is a character set, it is tested for\n"
3448 #define FUNC_NAME s_scm_string_delete
3451 size_t cstart
, cend
;
3455 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3459 /* The explicit loops below stripping leading and trailing matches mean we
3460 can return a substring if those are the only deletions, making
3461 string-delete as efficient as string-trim-both in that case. */
3463 if (SCM_CHARP (char_pred
))
3468 chr
= SCM_CHAR (char_pred
);
3470 /* strip leading matches by incrementing cstart */
3471 while (cstart
< cend
&& cstr
[cstart
] == chr
)
3474 /* strip trailing matches by decrementing cend */
3475 while (cend
> cstart
&& cstr
[cend
-1] == chr
)
3478 /* count chars to be kept */
3480 for (idx
= cstart
; idx
< cend
; idx
++)
3481 if (cstr
[idx
] != chr
)
3484 if (count
== cend
- cstart
)
3486 /* whole of cstart to cend is to be kept, return a copy-on-write
3489 result
= scm_i_substring (s
, cstart
, cend
);
3493 /* new string for retained portion */
3495 result
= scm_i_make_string (count
, &dst
);
3496 cstr
= scm_i_string_chars (s
);
3498 /* decrement "count" in this loop as well as using idx, so that if
3499 another thread is simultaneously changing "s" there's no chance
3500 it'll make us copy more than count characters */
3501 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3503 if (cstr
[idx
] != chr
)
3511 else if (SCM_CHARSETP (char_pred
))
3515 /* strip leading matches by incrementing cstart */
3516 while (cstart
< cend
&& SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3519 /* strip trailing matches by decrementing cend */
3520 while (cend
> cstart
&& SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3523 /* count chars to be kept */
3525 for (idx
= cstart
; idx
< cend
; idx
++)
3526 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3529 if (count
== cend
- cstart
)
3530 goto result_substring
;
3533 /* new string for retained portion */
3535 result
= scm_i_make_string (count
, &dst
);
3536 cstr
= scm_i_string_chars (s
);
3538 /* decrement "count" in this loop as well as using idx, so that if
3539 another thread is simultaneously changing "s" there's no chance
3540 it'll make us copy more than count characters */
3541 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3543 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3554 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3555 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3560 SCM res
, ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3561 res
= pred_tramp (char_pred
, ch
);
3562 if (scm_is_false (res
))
3563 ls
= scm_cons (ch
, ls
);
3564 cstr
= scm_i_string_chars (s
);
3567 result
= scm_reverse_list_to_string (ls
);
3570 scm_remember_upto_here_1 (s
);
3576 scm_init_srfi_13 (void)
3578 #include "libguile/srfi-13.x"
3581 /* End of srfi-13.c. */