1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
26 #include "libguile/srfi-13.h"
27 #include "libguile/srfi-14.h"
29 /* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
30 messing with the internal representation of strings. We define our
31 own version since we use it so much and are messing with Guile
35 #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 c_str = scm_i_string_chars (str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_VALIDATE_STRING (pos_str, str); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
56 "Return @code{#t} if @var{str}'s length is zero, and\n"
57 "@code{#f} otherwise.\n"
59 "(string-null? \"\") @result{} #t\n"
60 "y @result{} \"foo\"\n"
61 "(string-null? y) @result{} #f\n"
63 #define FUNC_NAME s_scm_string_null_p
65 SCM_VALIDATE_STRING (1, str
);
66 return scm_from_bool (scm_i_string_length (str
) == 0);
74 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
78 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
79 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
80 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
82 "@var{char_pred} can be a character to check for any equal to that, or\n"
83 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
84 "or a predicate procedure to call.\n"
86 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
87 "successively on the characters from @var{start} to @var{end}. If\n"
88 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
89 "stops and that return value is the return from @code{string-any}. The\n"
90 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
91 "point is reached, is a tail call.\n"
93 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
94 "@var{end}) then the return is @code{#f}.\n")
95 #define FUNC_NAME s_scm_string_any
101 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
105 if (SCM_CHARP (char_pred
))
107 res
= (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
109 ? SCM_BOOL_F
: SCM_BOOL_T
);
111 else if (SCM_CHARSETP (char_pred
))
114 for (i
= cstart
; i
< cend
; i
++)
115 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
123 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
124 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
126 while (cstart
< cend
)
128 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
129 if (scm_is_true (res
))
131 cstr
= scm_i_string_chars (s
);
136 scm_remember_upto_here_1 (s
);
142 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
143 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
144 "Check if @var{char_pred} is true for every character in string\n"
147 "@var{char_pred} can be a character to check for every character equal\n"
148 "to that, or a character set (@pxref{Character Sets}) to check for\n"
149 "every character being in that set, or a predicate procedure to call.\n"
151 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
152 "successively on the characters from @var{start} to @var{end}. If\n"
153 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
154 "returns @code{#f}. The call on the last character (ie.@: at\n"
155 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
156 "return from that call is the return from @code{string-every}.\n"
158 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
159 "@var{end}) then the return is @code{#t}.\n")
160 #define FUNC_NAME s_scm_string_every
164 SCM res
= SCM_BOOL_T
;
166 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
169 if (SCM_CHARP (char_pred
))
171 char cchr
= SCM_CHAR (char_pred
);
173 for (i
= cstart
; i
< cend
; i
++)
180 else if (SCM_CHARSETP (char_pred
))
183 for (i
= cstart
; i
< cend
; i
++)
184 if (!SCM_CHARSET_GET (char_pred
, cstr
[i
]))
192 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
193 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG1
, FUNC_NAME
);
195 while (cstart
< cend
)
197 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
198 if (scm_is_false (res
))
200 cstr
= scm_i_string_chars (s
);
205 scm_remember_upto_here_1 (s
);
211 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
213 "@var{proc} is an integer->char procedure. Construct a string\n"
214 "of size @var{len} by applying @var{proc} to each index to\n"
215 "produce the corresponding string element. The order in which\n"
216 "@var{proc} is applied to the indices is not specified.")
217 #define FUNC_NAME s_scm_string_tabulate
223 scm_t_trampoline_1 proc_tramp
;
225 proc_tramp
= scm_trampoline_1 (proc
);
226 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
228 clen
= scm_to_size_t (len
);
229 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
231 res
= scm_i_make_string (clen
, &p
);
235 /* The RES string remains untouched since nobody knows about it
236 yet. No need to refetch P.
238 ch
= proc_tramp (proc
, scm_from_size_t (i
));
240 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
241 *p
++ = SCM_CHAR (ch
);
249 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
250 (SCM str
, SCM start
, SCM end
),
251 "Convert the string @var{str} into a list of characters.")
252 #define FUNC_NAME s_scm_substring_to_list
256 SCM result
= SCM_EOL
;
258 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
261 while (cstart
< cend
)
264 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
265 cstr
= scm_i_string_chars (str
);
267 scm_remember_upto_here_1 (str
);
272 /* We export scm_substring_to_list as "string->list" since it is
273 compatible and more general. This function remains for the benefit
274 of C code that used it.
278 scm_string_to_list (SCM str
)
280 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
283 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
285 "An efficient implementation of @code{(compose string->list\n"
289 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
291 #define FUNC_NAME s_scm_reverse_list_to_string
294 long i
= scm_ilength (chrs
);
298 SCM_WRONG_TYPE_ARG (1, chrs
);
299 result
= scm_i_make_string (i
, &data
);
304 while (i
> 0 && scm_is_pair (chrs
))
306 SCM elt
= SCM_CAR (chrs
);
308 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
310 *data
= SCM_CHAR (elt
);
311 chrs
= SCM_CDR (chrs
);
321 SCM_SYMBOL (scm_sym_infix
, "infix");
322 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
323 SCM_SYMBOL (scm_sym_suffix
, "suffix");
324 SCM_SYMBOL (scm_sym_prefix
, "prefix");
327 append_string (char **sp
, size_t *lp
, SCM str
)
330 len
= scm_c_string_length (str
);
333 memcpy (*sp
, scm_i_string_chars (str
), len
);
338 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
339 (SCM ls
, SCM delimiter
, SCM grammar
),
340 "Append the string in the string list @var{ls}, using the string\n"
341 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
342 "@var{grammar} is a symbol which specifies how the delimiter is\n"
343 "placed between the strings, and defaults to the symbol\n"
348 "Insert the separator between list elements. An empty string\n"
349 "will produce an empty list.\n"
350 "@item string-infix\n"
351 "Like @code{infix}, but will raise an error if given the empty\n"
354 "Insert the separator after every list element.\n"
356 "Insert the separator before each list element.\n"
358 #define FUNC_NAME s_scm_string_join
361 #define GRAM_STRICT_INFIX 1
362 #define GRAM_SUFFIX 2
363 #define GRAM_PREFIX 3
366 int gram
= GRAM_INFIX
;
370 long strings
= scm_ilength (ls
);
372 /* Validate the string list. */
374 SCM_WRONG_TYPE_ARG (1, ls
);
376 /* Validate the delimiter and record its length. */
377 if (SCM_UNBNDP (delimiter
))
379 delimiter
= scm_from_locale_string (" ");
383 del_len
= scm_c_string_length (delimiter
);
385 /* Validate the grammar symbol and remember the grammar. */
386 if (SCM_UNBNDP (grammar
))
388 else if (scm_is_eq (grammar
, scm_sym_infix
))
390 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
391 gram
= GRAM_STRICT_INFIX
;
392 else if (scm_is_eq (grammar
, scm_sym_suffix
))
394 else if (scm_is_eq (grammar
, scm_sym_prefix
))
397 SCM_WRONG_TYPE_ARG (3, grammar
);
399 /* Check grammar constraints and calculate the space required for
404 if (!scm_is_null (ls
))
405 len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
407 case GRAM_STRICT_INFIX
:
409 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
411 len
= (strings
- 1) * del_len
;
414 len
= strings
* del_len
;
419 while (scm_is_pair (tmp
))
421 len
+= scm_c_string_length (SCM_CAR (tmp
));
425 result
= scm_i_make_string (len
, &p
);
431 case GRAM_STRICT_INFIX
:
432 while (scm_is_pair (tmp
))
434 append_string (&p
, &len
, SCM_CAR (tmp
));
435 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
436 append_string (&p
, &len
, delimiter
);
441 while (scm_is_pair (tmp
))
443 append_string (&p
, &len
, SCM_CAR (tmp
));
445 append_string (&p
, &len
, delimiter
);
450 while (scm_is_pair (tmp
))
453 append_string (&p
, &len
, delimiter
);
454 append_string (&p
, &len
, SCM_CAR (tmp
));
462 #undef GRAM_STRICT_INFIX
469 /* There are a number of functions to consider here for Scheme and C:
471 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
472 substring/copy STR start [end] ;; Guile variant of R5RS substring
474 scm_string_copy (str) ;; Old function from Guile
475 scm_substring_copy (str, [start, [end]])
476 ;; C version of SRFI-13 string-copy
477 ;; and C version of substring/copy
479 The C function underlying string-copy is not exported to C
480 programs. scm_substring_copy is defined in strings.c as the
481 underlying function of substring/copy and allows an optional START
485 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
487 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
488 (SCM str
, SCM start
, SCM end
),
489 "Return a freshly allocated copy of the string @var{str}. If\n"
490 "given, @var{start} and @var{end} delimit the portion of\n"
491 "@var{str} which is copied.")
492 #define FUNC_NAME s_scm_srfi13_substring_copy
497 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
500 return scm_c_substring_copy (str
, cstart
, cend
);
505 scm_string_copy (SCM str
)
507 return scm_c_substring (str
, 0, scm_c_string_length (str
));
510 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
511 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
512 "Copy the sequence of characters from index range [@var{start},\n"
513 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
514 "at index @var{tstart}. The characters are copied left-to-right\n"
515 "or right-to-left as needed -- the copy is guaranteed to work,\n"
516 "even if @var{target} and @var{s} are the same string. It is an\n"
517 "error if the copy operation runs off the end of the target\n"
519 #define FUNC_NAME s_scm_string_copy_x
523 size_t cstart
, cend
, ctstart
, dummy
, len
;
524 SCM sdummy
= SCM_UNDEFINED
;
526 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
529 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
533 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
535 ctarget
= scm_i_string_writable_chars (target
);
536 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
537 scm_i_string_stop_writing ();
538 scm_remember_upto_here_1 (target
);
540 return SCM_UNSPECIFIED
;
544 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
545 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
546 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
547 "into @var{str2} beginning at position @var{start2}.\n"
548 "@var{str1} and @var{str2} can be the same string.")
549 #define FUNC_NAME s_scm_substring_move_x
551 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
555 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
557 "Return the @var{n} first characters of @var{s}.")
558 #define FUNC_NAME s_scm_string_take
560 return scm_substring (s
, SCM_INUM0
, n
);
565 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
567 "Return all but the first @var{n} characters of @var{s}.")
568 #define FUNC_NAME s_scm_string_drop
570 return scm_substring (s
, n
, SCM_UNDEFINED
);
575 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
577 "Return the @var{n} last characters of @var{s}.")
578 #define FUNC_NAME s_scm_string_take_right
580 return scm_substring (s
,
581 scm_difference (scm_string_length (s
), n
),
587 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
589 "Return all but the last @var{n} characters of @var{s}.")
590 #define FUNC_NAME s_scm_string_drop_right
592 return scm_substring (s
,
594 scm_difference (scm_string_length (s
), n
));
599 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
600 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
601 "Take that characters from @var{start} to @var{end} from the\n"
602 "string @var{s} and return a new string, right-padded by the\n"
603 "character @var{chr} to length @var{len}. If the resulting\n"
604 "string is longer than @var{len}, it is truncated on the right.")
605 #define FUNC_NAME s_scm_string_pad
608 size_t cstart
, cend
, clen
;
610 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
613 clen
= scm_to_size_t (len
);
615 if (SCM_UNBNDP (chr
))
619 SCM_VALIDATE_CHAR (3, chr
);
620 cchr
= SCM_CHAR (chr
);
622 if (clen
< (cend
- cstart
))
623 return scm_c_substring (s
, cend
- clen
, cend
);
629 result
= scm_i_make_string (clen
, &dst
);
630 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
631 memmove (dst
+ clen
- (cend
- cstart
),
632 scm_i_string_chars (s
) + cstart
, cend
- cstart
);
639 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
640 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
641 "Take that characters from @var{start} to @var{end} from the\n"
642 "string @var{s} and return a new string, left-padded by the\n"
643 "character @var{chr} to length @var{len}. If the resulting\n"
644 "string is longer than @var{len}, it is truncated on the left.")
645 #define FUNC_NAME s_scm_string_pad_right
648 size_t cstart
, cend
, clen
;
650 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
653 clen
= scm_to_size_t (len
);
655 if (SCM_UNBNDP (chr
))
659 SCM_VALIDATE_CHAR (3, chr
);
660 cchr
= SCM_CHAR (chr
);
662 if (clen
< (cend
- cstart
))
663 return scm_c_substring (s
, cstart
, cstart
+ clen
);
669 result
= scm_i_make_string (clen
, &dst
);
670 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
671 memmove (dst
, scm_i_string_chars (s
) + cstart
, cend
- cstart
);
678 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
679 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
680 "Trim @var{s} by skipping over all characters on the left\n"
681 "that satisfy the parameter @var{char_pred}:\n"
685 "if it is the character @var{ch}, characters equal to\n"
686 "@var{ch} are trimmed,\n"
689 "if it is a procedure @var{pred} characters that\n"
690 "satisfy @var{pred} are trimmed,\n"
693 "if it is a character set, characters in that set are trimmed.\n"
696 "If called without a @var{char_pred} argument, all whitespace is\n"
698 #define FUNC_NAME s_scm_string_trim
703 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
706 if (SCM_UNBNDP (char_pred
))
708 while (cstart
< cend
)
710 if (!isspace((int) (unsigned char) cstr
[cstart
]))
715 else if (SCM_CHARP (char_pred
))
717 char chr
= SCM_CHAR (char_pred
);
718 while (cstart
< cend
)
720 if (chr
!= cstr
[cstart
])
725 else if (SCM_CHARSETP (char_pred
))
727 while (cstart
< cend
)
729 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
736 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
737 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
739 while (cstart
< cend
)
743 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
744 if (scm_is_false (res
))
746 cstr
= scm_i_string_chars (s
);
750 return scm_c_substring (s
, cstart
, cend
);
755 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
756 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
757 "Trim @var{s} by skipping over all characters on the rightt\n"
758 "that satisfy the parameter @var{char_pred}:\n"
762 "if it is the character @var{ch}, characters equal to @var{ch}\n"
766 "if it is a procedure @var{pred} characters that satisfy\n"
767 "@var{pred} are trimmed,\n"
770 "if it is a character sets, all characters in that set are\n"
774 "If called without a @var{char_pred} argument, all whitespace is\n"
776 #define FUNC_NAME s_scm_string_trim_right
781 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
784 if (SCM_UNBNDP (char_pred
))
786 while (cstart
< cend
)
788 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
793 else if (SCM_CHARP (char_pred
))
795 char chr
= SCM_CHAR (char_pred
);
796 while (cstart
< cend
)
798 if (chr
!= cstr
[cend
- 1])
803 else if (SCM_CHARSETP (char_pred
))
805 while (cstart
< cend
)
807 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
814 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
815 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
817 while (cstart
< cend
)
821 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
822 if (scm_is_false (res
))
824 cstr
= scm_i_string_chars (s
);
828 return scm_c_substring (s
, cstart
, cend
);
833 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
834 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
835 "Trim @var{s} by skipping over all characters on both sides of\n"
836 "the string that satisfy the parameter @var{char_pred}:\n"
840 "if it is the character @var{ch}, characters equal to @var{ch}\n"
844 "if it is a procedure @var{pred} characters that satisfy\n"
845 "@var{pred} are trimmed,\n"
848 "if it is a character set, the characters in the set are\n"
852 "If called without a @var{char_pred} argument, all whitespace is\n"
854 #define FUNC_NAME s_scm_string_trim_both
859 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
862 if (SCM_UNBNDP (char_pred
))
864 while (cstart
< cend
)
866 if (!isspace((int) (unsigned char) cstr
[cstart
]))
870 while (cstart
< cend
)
872 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
877 else if (SCM_CHARP (char_pred
))
879 char chr
= SCM_CHAR (char_pred
);
880 while (cstart
< cend
)
882 if (chr
!= cstr
[cstart
])
886 while (cstart
< cend
)
888 if (chr
!= cstr
[cend
- 1])
893 else if (SCM_CHARSETP (char_pred
))
895 while (cstart
< cend
)
897 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
901 while (cstart
< cend
)
903 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
910 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
911 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
913 while (cstart
< cend
)
917 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
918 if (scm_is_false (res
))
920 cstr
= scm_i_string_chars (s
);
923 while (cstart
< cend
)
927 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
928 if (scm_is_false (res
))
930 cstr
= scm_i_string_chars (s
);
934 return scm_c_substring (s
, cstart
, cend
);
939 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
940 (SCM str
, SCM chr
, SCM start
, SCM end
),
941 "Stores @var{chr} in every element of the given @var{str} and\n"
942 "returns an unspecified value.")
943 #define FUNC_NAME s_scm_substring_fill_x
950 /* Older versions of Guile provided the function
951 scm_substring_fill_x with the following order of arguments:
955 We accomodate this here by detecting such a usage and reordering
966 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
969 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
971 cstr
= scm_i_string_writable_chars (str
);
972 for (k
= cstart
; k
< cend
; k
++)
974 scm_i_string_stop_writing ();
975 scm_remember_upto_here_1 (str
);
977 return SCM_UNSPECIFIED
;
982 scm_string_fill_x (SCM str
, SCM chr
)
984 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
987 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
988 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
989 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
990 "mismatch index, depending upon whether @var{s1} is less than,\n"
991 "equal to, or greater than @var{s2}. The mismatch index is the\n"
992 "largest index @var{i} such that for every 0 <= @var{j} <\n"
993 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
994 "@var{i} is the first position that does not match.")
995 #define FUNC_NAME s_scm_string_compare
997 const char *cstr1
, *cstr2
;
998 size_t cstart1
, cend1
, cstart2
, cend2
;
1001 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1004 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1007 SCM_VALIDATE_PROC (3, proc_lt
);
1008 SCM_VALIDATE_PROC (4, proc_eq
);
1009 SCM_VALIDATE_PROC (5, proc_gt
);
1011 while (cstart1
< cend1
&& cstart2
< cend2
)
1013 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1018 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1026 if (cstart1
< cend1
)
1028 else if (cstart2
< cend2
)
1034 scm_remember_upto_here_2 (s1
, s2
);
1035 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1040 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1041 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1042 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1043 "mismatch index, depending upon whether @var{s1} is less than,\n"
1044 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1045 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1046 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1047 "@var{i} is the first position that does not match. The\n"
1048 "character comparison is done case-insensitively.")
1049 #define FUNC_NAME s_scm_string_compare_ci
1051 const char *cstr1
, *cstr2
;
1052 size_t cstart1
, cend1
, cstart2
, cend2
;
1055 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1058 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1061 SCM_VALIDATE_PROC (3, proc_lt
);
1062 SCM_VALIDATE_PROC (4, proc_eq
);
1063 SCM_VALIDATE_PROC (5, proc_gt
);
1065 while (cstart1
< cend1
&& cstart2
< cend2
)
1067 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1072 else if (scm_c_downcase (cstr1
[cstart1
])
1073 > scm_c_downcase (cstr2
[cstart2
]))
1082 if (cstart1
< cend1
)
1084 else if (cstart2
< cend2
)
1090 scm_remember_upto_here (s1
, s2
);
1091 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1096 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1097 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1098 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1100 #define FUNC_NAME s_scm_string_eq
1102 const char *cstr1
, *cstr2
;
1103 size_t cstart1
, cend1
, cstart2
, cend2
;
1105 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1108 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1112 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1115 while (cstart1
< cend1
)
1117 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1119 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1125 scm_remember_upto_here_2 (s1
, s2
);
1126 return scm_from_size_t (cstart1
);
1129 scm_remember_upto_here_2 (s1
, s2
);
1135 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1136 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1137 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1139 #define FUNC_NAME s_scm_string_neq
1141 const char *cstr1
, *cstr2
;
1142 size_t cstart1
, cend1
, cstart2
, cend2
;
1144 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1147 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1151 while (cstart1
< cend1
&& cstart2
< cend2
)
1153 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1155 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1160 if (cstart1
< cend1
)
1162 else if (cstart2
< cend2
)
1168 scm_remember_upto_here_2 (s1
, s2
);
1169 return scm_from_size_t (cstart1
);
1172 scm_remember_upto_here_2 (s1
, s2
);
1178 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1179 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1180 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1181 "true value otherwise.")
1182 #define FUNC_NAME s_scm_string_lt
1184 const char *cstr1
, *cstr2
;
1185 size_t cstart1
, cend1
, cstart2
, cend2
;
1187 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1190 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1194 while (cstart1
< cend1
&& cstart2
< cend2
)
1196 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1198 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1203 if (cstart1
< cend1
)
1205 else if (cstart2
< cend2
)
1211 scm_remember_upto_here_2 (s1
, s2
);
1212 return scm_from_size_t (cstart1
);
1215 scm_remember_upto_here_2 (s1
, s2
);
1221 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1222 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1223 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1224 "true value otherwise.")
1225 #define FUNC_NAME s_scm_string_gt
1227 const char *cstr1
, *cstr2
;
1228 size_t cstart1
, cend1
, cstart2
, cend2
;
1230 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1233 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1237 while (cstart1
< cend1
&& cstart2
< cend2
)
1239 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1241 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1246 if (cstart1
< cend1
)
1248 else if (cstart2
< cend2
)
1254 scm_remember_upto_here_2 (s1
, s2
);
1255 return scm_from_size_t (cstart1
);
1258 scm_remember_upto_here_2 (s1
, s2
);
1264 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1265 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1266 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1268 #define FUNC_NAME s_scm_string_le
1270 const char *cstr1
, *cstr2
;
1271 size_t cstart1
, cend1
, cstart2
, cend2
;
1273 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1276 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1280 while (cstart1
< cend1
&& cstart2
< cend2
)
1282 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1284 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1289 if (cstart1
< cend1
)
1291 else if (cstart2
< cend2
)
1297 scm_remember_upto_here_2 (s1
, s2
);
1298 return scm_from_size_t (cstart1
);
1301 scm_remember_upto_here_2 (s1
, s2
);
1307 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1308 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1309 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1311 #define FUNC_NAME s_scm_string_ge
1313 const char *cstr1
, *cstr2
;
1314 size_t cstart1
, cend1
, cstart2
, cend2
;
1316 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1319 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1323 while (cstart1
< cend1
&& cstart2
< cend2
)
1325 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1327 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1332 if (cstart1
< cend1
)
1334 else if (cstart2
< cend2
)
1340 scm_remember_upto_here_2 (s1
, s2
);
1341 return scm_from_size_t (cstart1
);
1344 scm_remember_upto_here_2 (s1
, s2
);
1350 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1351 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1352 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1353 "value otherwise. The character comparison is done\n"
1354 "case-insensitively.")
1355 #define FUNC_NAME s_scm_string_ci_eq
1357 const char *cstr1
, *cstr2
;
1358 size_t cstart1
, cend1
, cstart2
, cend2
;
1360 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1363 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1367 while (cstart1
< cend1
&& cstart2
< cend2
)
1369 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1371 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1376 if (cstart1
< cend1
)
1378 else if (cstart2
< cend2
)
1384 scm_remember_upto_here_2 (s1
, s2
);
1385 return scm_from_size_t (cstart1
);
1388 scm_remember_upto_here_2 (s1
, s2
);
1394 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1395 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1396 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1397 "value otherwise. The character comparison is done\n"
1398 "case-insensitively.")
1399 #define FUNC_NAME s_scm_string_ci_neq
1401 const char *cstr1
, *cstr2
;
1402 size_t cstart1
, cend1
, cstart2
, cend2
;
1404 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1407 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1411 while (cstart1
< cend1
&& cstart2
< cend2
)
1413 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1415 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1420 if (cstart1
< cend1
)
1422 else if (cstart2
< cend2
)
1428 scm_remember_upto_here_2 (s1
, s2
);
1429 return scm_from_size_t (cstart1
);
1432 scm_remember_upto_here_2 (s1
, s2
);
1438 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1439 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1440 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1441 "true value otherwise. The character comparison is done\n"
1442 "case-insensitively.")
1443 #define FUNC_NAME s_scm_string_ci_lt
1445 const char *cstr1
, *cstr2
;
1446 size_t cstart1
, cend1
, cstart2
, cend2
;
1448 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1451 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1455 while (cstart1
< cend1
&& cstart2
< cend2
)
1457 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1459 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1464 if (cstart1
< cend1
)
1466 else if (cstart2
< cend2
)
1472 scm_remember_upto_here_2 (s1
, s2
);
1473 return scm_from_size_t (cstart1
);
1476 scm_remember_upto_here_2 (s1
, s2
);
1482 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1483 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1484 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1485 "true value otherwise. The character comparison is done\n"
1486 "case-insensitively.")
1487 #define FUNC_NAME s_scm_string_ci_gt
1489 const char *cstr1
, *cstr2
;
1490 size_t cstart1
, cend1
, cstart2
, cend2
;
1492 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1495 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1499 while (cstart1
< cend1
&& cstart2
< cend2
)
1501 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1503 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1508 if (cstart1
< cend1
)
1510 else if (cstart2
< cend2
)
1516 scm_remember_upto_here_2 (s1
, s2
);
1517 return scm_from_size_t (cstart1
);
1520 scm_remember_upto_here_2 (s1
, s2
);
1526 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1527 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1528 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1529 "value otherwise. The character comparison is done\n"
1530 "case-insensitively.")
1531 #define FUNC_NAME s_scm_string_ci_le
1533 const char *cstr1
, *cstr2
;
1534 size_t cstart1
, cend1
, cstart2
, cend2
;
1536 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1539 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1543 while (cstart1
< cend1
&& cstart2
< cend2
)
1545 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1547 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1552 if (cstart1
< cend1
)
1554 else if (cstart2
< cend2
)
1560 scm_remember_upto_here_2 (s1
, s2
);
1561 return scm_from_size_t (cstart1
);
1564 scm_remember_upto_here_2 (s1
, s2
);
1570 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1571 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1572 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1573 "otherwise. The character comparison is done\n"
1574 "case-insensitively.")
1575 #define FUNC_NAME s_scm_string_ci_ge
1577 const char *cstr1
, *cstr2
;
1578 size_t cstart1
, cend1
, cstart2
, cend2
;
1580 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1583 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1587 while (cstart1
< cend1
&& cstart2
< cend2
)
1589 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1591 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1596 if (cstart1
< cend1
)
1598 else if (cstart2
< cend2
)
1604 scm_remember_upto_here_2 (s1
, s2
);
1605 return scm_from_size_t (cstart1
);
1608 scm_remember_upto_here_2 (s1
, s2
);
1613 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1614 (SCM s
, SCM bound
, SCM start
, SCM end
),
1615 "Compute a hash value for @var{S}. the optional argument "
1616 "@var{bound} is a non-negative exact "
1617 "integer specifying the range of the hash function. "
1618 "A positive value restricts the return value to the "
1620 #define FUNC_NAME s_scm_substring_hash
1622 if (SCM_UNBNDP (bound
))
1623 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1624 if (SCM_UNBNDP (start
))
1626 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1630 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1631 (SCM s
, SCM bound
, SCM start
, SCM end
),
1632 "Compute a hash value for @var{S}. the optional argument "
1633 "@var{bound} is a non-negative exact "
1634 "integer specifying the range of the hash function. "
1635 "A positive value restricts the return value to the "
1637 #define FUNC_NAME s_scm_substring_hash_ci
1639 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1641 SCM_UNDEFINED
, SCM_UNDEFINED
);
1645 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1646 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1647 "Return the length of the longest common prefix of the two\n"
1649 #define FUNC_NAME s_scm_string_prefix_length
1651 const char *cstr1
, *cstr2
;
1652 size_t cstart1
, cend1
, cstart2
, cend2
;
1655 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1658 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1661 while (cstart1
< cend1
&& cstart2
< cend2
)
1663 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1671 scm_remember_upto_here_2 (s1
, s2
);
1672 return scm_from_size_t (len
);
1677 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1678 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1679 "Return the length of the longest common prefix of the two\n"
1680 "strings, ignoring character case.")
1681 #define FUNC_NAME s_scm_string_prefix_length_ci
1683 const char *cstr1
, *cstr2
;
1684 size_t cstart1
, cend1
, cstart2
, cend2
;
1687 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1690 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1693 while (cstart1
< cend1
&& cstart2
< cend2
)
1695 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1703 scm_remember_upto_here_2 (s1
, s2
);
1704 return scm_from_size_t (len
);
1709 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1710 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1711 "Return the length of the longest common suffix of the two\n"
1713 #define FUNC_NAME s_scm_string_suffix_length
1715 const char *cstr1
, *cstr2
;
1716 size_t cstart1
, cend1
, cstart2
, cend2
;
1719 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1722 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1725 while (cstart1
< cend1
&& cstart2
< cend2
)
1729 if (cstr1
[cend1
] != cstr2
[cend2
])
1735 scm_remember_upto_here_2 (s1
, s2
);
1736 return scm_from_size_t (len
);
1741 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1742 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1743 "Return the length of the longest common suffix of the two\n"
1744 "strings, ignoring character case.")
1745 #define FUNC_NAME s_scm_string_suffix_length_ci
1747 const char *cstr1
, *cstr2
;
1748 size_t cstart1
, cend1
, cstart2
, cend2
;
1751 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1754 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1757 while (cstart1
< cend1
&& cstart2
< cend2
)
1761 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1767 scm_remember_upto_here_2 (s1
, s2
);
1768 return scm_from_size_t (len
);
1773 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1774 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1775 "Is @var{s1} a prefix of @var{s2}?")
1776 #define FUNC_NAME s_scm_string_prefix_p
1778 const char *cstr1
, *cstr2
;
1779 size_t cstart1
, cend1
, cstart2
, cend2
;
1780 size_t len
= 0, len1
;
1782 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1785 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1788 len1
= cend1
- cstart1
;
1789 while (cstart1
< cend1
&& cstart2
< cend2
)
1791 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1799 scm_remember_upto_here_2 (s1
, s2
);
1800 return scm_from_bool (len
== len1
);
1805 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1806 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1807 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1808 #define FUNC_NAME s_scm_string_prefix_ci_p
1810 const char *cstr1
, *cstr2
;
1811 size_t cstart1
, cend1
, cstart2
, cend2
;
1812 size_t len
= 0, len1
;
1814 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1817 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1820 len1
= cend1
- cstart1
;
1821 while (cstart1
< cend1
&& cstart2
< cend2
)
1823 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1831 scm_remember_upto_here_2 (s1
, s2
);
1832 return scm_from_bool (len
== len1
);
1837 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1838 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1839 "Is @var{s1} a suffix of @var{s2}?")
1840 #define FUNC_NAME s_scm_string_suffix_p
1842 const char *cstr1
, *cstr2
;
1843 size_t cstart1
, cend1
, cstart2
, cend2
;
1844 size_t len
= 0, len1
;
1846 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1849 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1852 len1
= cend1
- cstart1
;
1853 while (cstart1
< cend1
&& cstart2
< cend2
)
1857 if (cstr1
[cend1
] != cstr2
[cend2
])
1863 scm_remember_upto_here_2 (s1
, s2
);
1864 return scm_from_bool (len
== len1
);
1869 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1870 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1871 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1872 #define FUNC_NAME s_scm_string_suffix_ci_p
1874 const char *cstr1
, *cstr2
;
1875 size_t cstart1
, cend1
, cstart2
, cend2
;
1876 size_t len
= 0, len1
;
1878 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1881 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1884 len1
= cend1
- cstart1
;
1885 while (cstart1
< cend1
&& cstart2
< cend2
)
1889 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1895 scm_remember_upto_here_2 (s1
, s2
);
1896 return scm_from_bool (len
== len1
);
1901 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1902 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1903 "Search through the string @var{s} from left to right, returning\n"
1904 "the index of the first occurence of a character which\n"
1906 "@itemize @bullet\n"
1908 "equals @var{char_pred}, if it is character,\n"
1911 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1914 "is in the set @var{char_pred}, if it is a character set.\n"
1916 #define FUNC_NAME s_scm_string_index
1919 size_t cstart
, cend
;
1921 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1924 if (SCM_CHARP (char_pred
))
1926 char cchr
= SCM_CHAR (char_pred
);
1927 while (cstart
< cend
)
1929 if (cchr
== cstr
[cstart
])
1934 else if (SCM_CHARSETP (char_pred
))
1936 while (cstart
< cend
)
1938 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1945 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
1946 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
1948 while (cstart
< cend
)
1951 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1952 if (scm_is_true (res
))
1954 cstr
= scm_i_string_chars (s
);
1959 scm_remember_upto_here_1 (s
);
1963 scm_remember_upto_here_1 (s
);
1964 return scm_from_size_t (cstart
);
1968 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1969 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1970 "Search through the string @var{s} from right to left, returning\n"
1971 "the index of the last occurence of a character which\n"
1973 "@itemize @bullet\n"
1975 "equals @var{char_pred}, if it is character,\n"
1978 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1981 "is in the set if @var{char_pred} is a character set.\n"
1983 #define FUNC_NAME s_scm_string_index_right
1986 size_t cstart
, cend
;
1988 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1991 if (SCM_CHARP (char_pred
))
1993 char cchr
= SCM_CHAR (char_pred
);
1994 while (cstart
< cend
)
1997 if (cchr
== cstr
[cend
])
2001 else if (SCM_CHARSETP (char_pred
))
2003 while (cstart
< cend
)
2006 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2012 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2013 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2015 while (cstart
< cend
)
2019 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2020 if (scm_is_true (res
))
2022 cstr
= scm_i_string_chars (s
);
2026 scm_remember_upto_here_1 (s
);
2030 scm_remember_upto_here_1 (s
);
2031 return scm_from_size_t (cend
);
2035 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
2036 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2037 "Search through the string @var{s} from right to left, returning\n"
2038 "the index of the last occurence of a character which\n"
2040 "@itemize @bullet\n"
2042 "equals @var{char_pred}, if it is character,\n"
2045 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2048 "is in the set if @var{char_pred} is a character set.\n"
2050 #define FUNC_NAME s_scm_string_rindex
2052 return scm_string_index_right (s
, char_pred
, start
, end
);
2056 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
2057 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2058 "Search through the string @var{s} from left to right, returning\n"
2059 "the index of the first occurence of a character which\n"
2061 "@itemize @bullet\n"
2063 "does not equal @var{char_pred}, if it is character,\n"
2066 "does not satisify the predicate @var{char_pred}, if it is a\n"
2070 "is not in the set if @var{char_pred} is a character set.\n"
2072 #define FUNC_NAME s_scm_string_skip
2075 size_t cstart
, cend
;
2077 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2080 if (SCM_CHARP (char_pred
))
2082 char cchr
= SCM_CHAR (char_pred
);
2083 while (cstart
< cend
)
2085 if (cchr
!= cstr
[cstart
])
2090 else if (SCM_CHARSETP (char_pred
))
2092 while (cstart
< cend
)
2094 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2101 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2102 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2104 while (cstart
< cend
)
2107 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2108 if (scm_is_false (res
))
2110 cstr
= scm_i_string_chars (s
);
2115 scm_remember_upto_here_1 (s
);
2119 scm_remember_upto_here_1 (s
);
2120 return scm_from_size_t (cstart
);
2125 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2126 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2127 "Search through the string @var{s} from right to left, returning\n"
2128 "the index of the last occurence of a character which\n"
2130 "@itemize @bullet\n"
2132 "does not equal @var{char_pred}, if it is character,\n"
2135 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2139 "is not in the set if @var{char_pred} is a character set.\n"
2141 #define FUNC_NAME s_scm_string_skip_right
2144 size_t cstart
, cend
;
2146 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2149 if (SCM_CHARP (char_pred
))
2151 char cchr
= SCM_CHAR (char_pred
);
2152 while (cstart
< cend
)
2155 if (cchr
!= cstr
[cend
])
2159 else if (SCM_CHARSETP (char_pred
))
2161 while (cstart
< cend
)
2164 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2170 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2171 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2173 while (cstart
< cend
)
2177 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2178 if (scm_is_false (res
))
2180 cstr
= scm_i_string_chars (s
);
2184 scm_remember_upto_here_1 (s
);
2188 scm_remember_upto_here_1 (s
);
2189 return scm_from_size_t (cend
);
2195 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2196 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2197 "Return the count of the number of characters in the string\n"
2200 "@itemize @bullet\n"
2202 "equals @var{char_pred}, if it is character,\n"
2205 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2208 "is in the set @var{char_pred}, if it is a character set.\n"
2210 #define FUNC_NAME s_scm_string_count
2213 size_t cstart
, cend
;
2216 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2219 if (SCM_CHARP (char_pred
))
2221 char cchr
= SCM_CHAR (char_pred
);
2222 while (cstart
< cend
)
2224 if (cchr
== cstr
[cstart
])
2229 else if (SCM_CHARSETP (char_pred
))
2231 while (cstart
< cend
)
2233 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2240 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
2241 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
2243 while (cstart
< cend
)
2246 res
= pred_tramp (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2247 if (scm_is_true (res
))
2249 cstr
= scm_i_string_chars (s
);
2254 scm_remember_upto_here_1 (s
);
2255 return scm_from_size_t (count
);
2260 /* FIXME::martin: This should definitely get implemented more
2261 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2263 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2264 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2265 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2266 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2267 "The optional start/end indices restrict the operation to the\n"
2268 "indicated substrings.")
2269 #define FUNC_NAME s_scm_string_contains
2271 const char *cs1
, * cs2
;
2272 size_t cstart1
, cend1
, cstart2
, cend2
;
2275 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2278 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2281 len2
= cend2
- cstart2
;
2282 if (cend1
- cstart1
>= len2
)
2283 while (cstart1
<= cend1
- len2
)
2287 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2294 scm_remember_upto_here_2 (s1
, s2
);
2295 return scm_from_size_t (cstart1
);
2300 scm_remember_upto_here_2 (s1
, s2
);
2306 /* FIXME::martin: This should definitely get implemented more
2307 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2309 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2310 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2311 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2312 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2313 "The optional start/end indices restrict the operation to the\n"
2314 "indicated substrings. Character comparison is done\n"
2315 "case-insensitively.")
2316 #define FUNC_NAME s_scm_string_contains_ci
2318 const char *cs1
, * cs2
;
2319 size_t cstart1
, cend1
, cstart2
, cend2
;
2322 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2325 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2328 len2
= cend2
- cstart2
;
2329 if (cend1
- cstart1
>= len2
)
2330 while (cstart1
<= cend1
- len2
)
2334 while (i
< cend1
&& j
< cend2
&&
2335 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2342 scm_remember_upto_here_2 (s1
, s2
);
2343 return scm_from_size_t (cstart1
);
2348 scm_remember_upto_here_2 (s1
, s2
);
2354 /* Helper function for the string uppercase conversion functions.
2355 * No argument checking is performed. */
2357 string_upcase_x (SCM v
, size_t start
, size_t end
)
2362 dst
= scm_i_string_writable_chars (v
);
2363 for (k
= start
; k
< end
; ++k
)
2364 dst
[k
] = scm_c_upcase (dst
[k
]);
2365 scm_i_string_stop_writing ();
2366 scm_remember_upto_here_1 (v
);
2371 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2372 (SCM str
, SCM start
, SCM end
),
2373 "Destructively upcase every character in @code{str}.\n"
2376 "(string-upcase! y)\n"
2377 "@result{} \"ARRDEFG\"\n"
2379 "@result{} \"ARRDEFG\"\n"
2381 #define FUNC_NAME s_scm_substring_upcase_x
2384 size_t cstart
, cend
;
2386 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2389 return string_upcase_x (str
, cstart
, cend
);
2394 scm_string_upcase_x (SCM str
)
2396 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2399 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2400 (SCM str
, SCM start
, SCM end
),
2401 "Upcase every character in @code{str}.")
2402 #define FUNC_NAME s_scm_substring_upcase
2405 size_t cstart
, cend
;
2407 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2410 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2415 scm_string_upcase (SCM str
)
2417 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2420 /* Helper function for the string lowercase conversion functions.
2421 * No argument checking is performed. */
2423 string_downcase_x (SCM v
, size_t start
, size_t end
)
2428 dst
= scm_i_string_writable_chars (v
);
2429 for (k
= start
; k
< end
; ++k
)
2430 dst
[k
] = scm_c_downcase (dst
[k
]);
2431 scm_i_string_stop_writing ();
2432 scm_remember_upto_here_1 (v
);
2437 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2438 (SCM str
, SCM start
, SCM end
),
2439 "Destructively downcase every character in @var{str}.\n"
2443 "@result{} \"ARRDEFG\"\n"
2444 "(string-downcase! y)\n"
2445 "@result{} \"arrdefg\"\n"
2447 "@result{} \"arrdefg\"\n"
2449 #define FUNC_NAME s_scm_substring_downcase_x
2452 size_t cstart
, cend
;
2454 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2457 return string_downcase_x (str
, cstart
, cend
);
2462 scm_string_downcase_x (SCM str
)
2464 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2467 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2468 (SCM str
, SCM start
, SCM end
),
2469 "Downcase every character in @var{str}.")
2470 #define FUNC_NAME s_scm_substring_downcase
2473 size_t cstart
, cend
;
2475 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2478 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2483 scm_string_downcase (SCM str
)
2485 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2488 /* Helper function for the string capitalization functions.
2489 * No argument checking is performed. */
2491 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2497 sz
= (unsigned char *) scm_i_string_writable_chars (str
);
2498 for(i
= start
; i
< end
; i
++)
2500 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2504 sz
[i
] = scm_c_upcase(sz
[i
]);
2509 sz
[i
] = scm_c_downcase(sz
[i
]);
2515 scm_i_string_stop_writing ();
2516 scm_remember_upto_here_1 (str
);
2522 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2523 (SCM str
, SCM start
, SCM end
),
2524 "Destructively titlecase every first character in a word in\n"
2526 #define FUNC_NAME s_scm_string_titlecase_x
2529 size_t cstart
, cend
;
2531 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2534 return string_titlecase_x (str
, cstart
, cend
);
2539 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2540 (SCM str
, SCM start
, SCM end
),
2541 "Titlecase every first character in a word in @var{str}.")
2542 #define FUNC_NAME s_scm_string_titlecase
2545 size_t cstart
, cend
;
2547 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2550 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2554 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2556 "Upcase the first character of every word in @var{str}\n"
2557 "destructively and return @var{str}.\n"
2560 "y @result{} \"hello world\"\n"
2561 "(string-capitalize! y) @result{} \"Hello World\"\n"
2562 "y @result{} \"Hello World\"\n"
2564 #define FUNC_NAME s_scm_string_capitalize_x
2566 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2571 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2573 "Return a freshly allocated string with the characters in\n"
2574 "@var{str}, where the first character of every word is\n"
2576 #define FUNC_NAME s_scm_string_capitalize
2578 return scm_string_capitalize_x (scm_string_copy (str
));
2583 /* Reverse the portion of @var{str} between str[cstart] (including)
2584 and str[cend] excluding. */
2586 string_reverse_x (char * str
, size_t cstart
, size_t cend
)
2593 while (cstart
< cend
)
2596 str
[cstart
] = str
[cend
];
2605 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2606 (SCM str
, SCM start
, SCM end
),
2607 "Reverse the string @var{str}. The optional arguments\n"
2608 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2610 #define FUNC_NAME s_scm_string_reverse
2614 size_t cstart
, cend
;
2617 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2620 result
= scm_string_copy (str
);
2621 ctarget
= scm_i_string_writable_chars (result
);
2622 string_reverse_x (ctarget
, cstart
, cend
);
2623 scm_i_string_stop_writing ();
2624 scm_remember_upto_here_1 (str
);
2630 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2631 (SCM str
, SCM start
, SCM end
),
2632 "Reverse the string @var{str} in-place. The optional arguments\n"
2633 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2634 "operate on. The return value is unspecified.")
2635 #define FUNC_NAME s_scm_string_reverse_x
2638 size_t cstart
, cend
;
2640 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2644 cstr
= scm_i_string_writable_chars (str
);
2645 string_reverse_x (cstr
, cstart
, cend
);
2646 scm_i_string_stop_writing ();
2647 scm_remember_upto_here_1 (str
);
2648 return SCM_UNSPECIFIED
;
2653 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2655 "Like @code{string-append}, but the result may share memory\n"
2656 "with the argument strings.")
2657 #define FUNC_NAME s_scm_string_append_shared
2661 SCM_VALIDATE_REST_ARGUMENT (ls
);
2663 /* Optimize the one-argument case. */
2664 i
= scm_ilength (ls
);
2666 return SCM_CAR (ls
);
2668 return scm_string_append (ls
);
2673 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2675 "Append the elements of @var{ls} (which must be strings)\n"
2676 "together into a single string. Guaranteed to return a freshly\n"
2677 "allocated string.")
2678 #define FUNC_NAME s_scm_string_concatenate
2680 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2681 return scm_string_append (ls
);
2686 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2687 (SCM ls
, SCM final_string
, SCM end
),
2688 "Without optional arguments, this procedure is equivalent to\n"
2691 "(string-concatenate (reverse ls))\n"
2694 "If the optional argument @var{final_string} is specified, it is\n"
2695 "consed onto the beginning to @var{ls} before performing the\n"
2696 "list-reverse and string-concatenate operations. If @var{end}\n"
2697 "is given, only the characters of @var{final_string} up to index\n"
2698 "@var{end} are used.\n"
2700 "Guaranteed to return a freshly allocated string.")
2701 #define FUNC_NAME s_scm_string_concatenate_reverse
2703 if (!SCM_UNBNDP (end
))
2704 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2706 if (!SCM_UNBNDP (final_string
))
2707 ls
= scm_cons (final_string
, ls
);
2709 return scm_string_concatenate (scm_reverse (ls
));
2714 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2716 "Like @code{string-concatenate}, but the result may share memory\n"
2717 "with the strings in the list @var{ls}.")
2718 #define FUNC_NAME s_scm_string_concatenate_shared
2720 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2721 return scm_string_append_shared (ls
);
2726 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2727 (SCM ls
, SCM final_string
, SCM end
),
2728 "Like @code{string-concatenate-reverse}, but the result may\n"
2729 "share memory with the the strings in the @var{ls} arguments.")
2730 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2732 /* Just call the non-sharing version. */
2733 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2738 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2739 (SCM proc
, SCM s
, SCM start
, SCM end
),
2740 "@var{proc} is a char->char procedure, it is mapped over\n"
2741 "@var{s}. The order in which the procedure is applied to the\n"
2742 "string elements is not specified.")
2743 #define FUNC_NAME s_scm_string_map
2746 size_t cstart
, cend
;
2748 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2750 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2751 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2754 result
= scm_i_make_string (cend
- cstart
, &p
);
2755 while (cstart
< cend
)
2757 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2758 if (!SCM_CHARP (ch
))
2759 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2761 *p
++ = SCM_CHAR (ch
);
2768 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2769 (SCM proc
, SCM s
, SCM start
, SCM end
),
2770 "@var{proc} is a char->char procedure, it is mapped over\n"
2771 "@var{s}. The order in which the procedure is applied to the\n"
2772 "string elements is not specified. The string @var{s} is\n"
2773 "modified in-place, the return value is not specified.")
2774 #define FUNC_NAME s_scm_string_map_x
2776 size_t cstart
, cend
;
2777 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2779 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2780 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2783 while (cstart
< cend
)
2785 SCM ch
= proc_tramp (proc
, scm_c_string_ref (s
, cstart
));
2786 if (!SCM_CHARP (ch
))
2787 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2788 scm_c_string_set_x (s
, cstart
, ch
);
2791 return SCM_UNSPECIFIED
;
2796 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2797 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2798 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2799 "as the terminating element, from left to right. @var{kons}\n"
2800 "must expect two arguments: The actual character and the last\n"
2801 "result of @var{kons}' application.")
2802 #define FUNC_NAME s_scm_string_fold
2805 size_t cstart
, cend
;
2808 SCM_VALIDATE_PROC (1, kons
);
2809 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2813 while (cstart
< cend
)
2815 unsigned int c
= (unsigned char) cstr
[cstart
];
2816 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2817 cstr
= scm_i_string_chars (s
);
2821 scm_remember_upto_here_1 (s
);
2827 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2828 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2829 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2830 "as the terminating element, from right to left. @var{kons}\n"
2831 "must expect two arguments: The actual character and the last\n"
2832 "result of @var{kons}' application.")
2833 #define FUNC_NAME s_scm_string_fold_right
2836 size_t cstart
, cend
;
2839 SCM_VALIDATE_PROC (1, kons
);
2840 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2844 while (cstart
< cend
)
2846 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2847 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2848 cstr
= scm_i_string_chars (s
);
2852 scm_remember_upto_here_1 (s
);
2858 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2859 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2860 "@itemize @bullet\n"
2861 "@item @var{g} is used to generate a series of @emph{seed}\n"
2862 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2863 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2865 "@item @var{p} tells us when to stop -- when it returns true\n"
2866 "when applied to one of these seed values.\n"
2867 "@item @var{f} maps each seed value to the corresponding\n"
2868 "character in the result string. These chars are assembled\n"
2869 "into the string in a left-to-right order.\n"
2870 "@item @var{base} is the optional initial/leftmost portion\n"
2871 "of the constructed string; it default to the empty\n"
2873 "@item @var{make_final} is applied to the terminal seed\n"
2874 "value (on which @var{p} returns true) to produce\n"
2875 "the final/rightmost portion of the constructed string.\n"
2876 "It defaults to @code{(lambda (x) "")}.\n"
2878 #define FUNC_NAME s_scm_string_unfold
2882 SCM_VALIDATE_PROC (1, p
);
2883 SCM_VALIDATE_PROC (2, f
);
2884 SCM_VALIDATE_PROC (3, g
);
2885 if (!SCM_UNBNDP (base
))
2887 SCM_VALIDATE_STRING (5, base
);
2891 ans
= scm_i_make_string (0, NULL
);
2892 if (!SCM_UNBNDP (make_final
))
2893 SCM_VALIDATE_PROC (6, make_final
);
2895 res
= scm_call_1 (p
, seed
);
2896 while (scm_is_false (res
))
2900 SCM ch
= scm_call_1 (f
, seed
);
2901 if (!SCM_CHARP (ch
))
2902 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2903 str
= scm_i_make_string (1, &ptr
);
2904 *ptr
= SCM_CHAR (ch
);
2906 ans
= scm_string_append (scm_list_2 (ans
, str
));
2907 seed
= scm_call_1 (g
, seed
);
2908 res
= scm_call_1 (p
, seed
);
2910 if (!SCM_UNBNDP (make_final
))
2912 res
= scm_call_1 (make_final
, seed
);
2913 return scm_string_append (scm_list_2 (ans
, res
));
2921 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2922 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2923 "@itemize @bullet\n"
2924 "@item @var{g} is used to generate a series of @emph{seed}\n"
2925 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2926 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2928 "@item @var{p} tells us when to stop -- when it returns true\n"
2929 "when applied to one of these seed values.\n"
2930 "@item @var{f} maps each seed value to the corresponding\n"
2931 "character in the result string. These chars are assembled\n"
2932 "into the string in a right-to-left order.\n"
2933 "@item @var{base} is the optional initial/rightmost portion\n"
2934 "of the constructed string; it default to the empty\n"
2936 "@item @var{make_final} is applied to the terminal seed\n"
2937 "value (on which @var{p} returns true) to produce\n"
2938 "the final/leftmost portion of the constructed string.\n"
2939 "It defaults to @code{(lambda (x) "")}.\n"
2941 #define FUNC_NAME s_scm_string_unfold_right
2945 SCM_VALIDATE_PROC (1, p
);
2946 SCM_VALIDATE_PROC (2, f
);
2947 SCM_VALIDATE_PROC (3, g
);
2948 if (!SCM_UNBNDP (base
))
2950 SCM_VALIDATE_STRING (5, base
);
2954 ans
= scm_i_make_string (0, NULL
);
2955 if (!SCM_UNBNDP (make_final
))
2956 SCM_VALIDATE_PROC (6, make_final
);
2958 res
= scm_call_1 (p
, seed
);
2959 while (scm_is_false (res
))
2963 SCM ch
= scm_call_1 (f
, seed
);
2964 if (!SCM_CHARP (ch
))
2965 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2966 str
= scm_i_make_string (1, &ptr
);
2967 *ptr
= SCM_CHAR (ch
);
2969 ans
= scm_string_append (scm_list_2 (str
, ans
));
2970 seed
= scm_call_1 (g
, seed
);
2971 res
= scm_call_1 (p
, seed
);
2973 if (!SCM_UNBNDP (make_final
))
2975 res
= scm_call_1 (make_final
, seed
);
2976 return scm_string_append (scm_list_2 (res
, ans
));
2984 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2985 (SCM proc
, SCM s
, SCM start
, SCM end
),
2986 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2987 "return value is not specified.")
2988 #define FUNC_NAME s_scm_string_for_each
2991 size_t cstart
, cend
;
2992 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
2994 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
2995 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2998 while (cstart
< cend
)
3000 unsigned int c
= (unsigned char) cstr
[cstart
];
3001 proc_tramp (proc
, SCM_MAKE_CHAR (c
));
3002 cstr
= scm_i_string_chars (s
);
3006 scm_remember_upto_here_1 (s
);
3007 return SCM_UNSPECIFIED
;
3011 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
3012 (SCM proc
, SCM s
, SCM start
, SCM end
),
3013 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
3016 "For example, to change characters to alternately upper and\n"
3020 "(define str (string-copy \"studly\"))\n"
3021 "(string-for-each-index\n"
3023 " (string-set! str i\n"
3024 " ((if (even? i) char-upcase char-downcase)\n"
3025 " (string-ref str i))))\n"
3027 "str @result{} \"StUdLy\"\n"
3029 #define FUNC_NAME s_scm_string_for_each_index
3031 size_t cstart
, cend
;
3032 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
3034 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
3035 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3039 while (cstart
< cend
)
3041 proc_tramp (proc
, scm_from_size_t (cstart
));
3045 scm_remember_upto_here_1 (s
);
3046 return SCM_UNSPECIFIED
;
3050 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
3051 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
3052 "This is the @emph{extended substring} procedure that implements\n"
3053 "replicated copying of a substring of some string.\n"
3055 "@var{s} is a string, @var{start} and @var{end} are optional\n"
3056 "arguments that demarcate a substring of @var{s}, defaulting to\n"
3057 "0 and the length of @var{s}. Replicate this substring up and\n"
3058 "down index space, in both the positive and negative directions.\n"
3059 "@code{xsubstring} returns the substring of this string\n"
3060 "beginning at index @var{from}, and ending at @var{to}, which\n"
3061 "defaults to @var{from} + (@var{end} - @var{start}).")
3062 #define FUNC_NAME s_scm_xsubstring
3066 size_t cstart
, cend
;
3070 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3074 cfrom
= scm_to_int (from
);
3075 if (SCM_UNBNDP (to
))
3076 cto
= cfrom
+ (cend
- cstart
);
3078 cto
= scm_to_int (to
);
3079 if (cstart
== cend
&& cfrom
!= cto
)
3080 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3082 result
= scm_i_make_string (cto
- cfrom
, &p
);
3084 cs
= scm_i_string_chars (s
);
3087 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
3089 *p
= cs
[(cend
- cstart
) - t
];
3096 scm_remember_upto_here_1 (s
);
3102 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3103 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3104 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3105 "is written into the string @var{target} starting at index\n"
3106 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3107 "@var{target} @var{s})} or these arguments share storage -- you\n"
3108 "cannot copy a string on top of itself.")
3109 #define FUNC_NAME s_scm_string_xcopy_x
3113 size_t ctstart
, cstart
, cend
;
3115 SCM dummy
= SCM_UNDEFINED
;
3118 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3121 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
3124 csfrom
= scm_to_int (sfrom
);
3125 if (SCM_UNBNDP (sto
))
3126 csto
= csfrom
+ (cend
- cstart
);
3128 csto
= scm_to_int (sto
);
3129 if (cstart
== cend
&& csfrom
!= csto
)
3130 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3131 SCM_ASSERT_RANGE (1, tstart
,
3132 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3134 p
= scm_i_string_writable_chars (target
) + ctstart
;
3135 cs
= scm_i_string_chars (s
);
3136 while (csfrom
< csto
)
3138 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3140 *p
= cs
[(cend
- cstart
) - t
];
3146 scm_i_string_stop_writing ();
3148 scm_remember_upto_here_2 (target
, s
);
3149 return SCM_UNSPECIFIED
;
3154 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3155 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3156 "Return the string @var{s1}, but with the characters\n"
3157 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3158 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3159 #define FUNC_NAME s_scm_string_replace
3161 const char *cstr1
, *cstr2
;
3163 size_t cstart1
, cend1
, cstart2
, cend2
;
3166 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
3169 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
3172 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3173 scm_i_string_length (s1
) - cend1
, &p
);
3174 cstr1
= scm_i_string_chars (s1
);
3175 cstr2
= scm_i_string_chars (s2
);
3176 memmove (p
, cstr1
, cstart1
* sizeof (char));
3177 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3178 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3180 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3181 scm_remember_upto_here_2 (s1
, s2
);
3187 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3188 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3189 "Split the string @var{s} into a list of substrings, where each\n"
3190 "substring is a maximal non-empty contiguous sequence of\n"
3191 "characters from the character set @var{token_set}, which\n"
3192 "defaults to @code{char-set:graphic}.\n"
3193 "If @var{start} or @var{end} indices are provided, they restrict\n"
3194 "@code{string-tokenize} to operating on the indicated substring\n"
3196 #define FUNC_NAME s_scm_string_tokenize
3199 size_t cstart
, cend
;
3200 SCM result
= SCM_EOL
;
3202 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3206 if (SCM_UNBNDP (token_set
))
3207 token_set
= scm_char_set_graphic
;
3209 if (SCM_CHARSETP (token_set
))
3213 while (cstart
< cend
)
3215 while (cstart
< cend
)
3217 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3224 while (cstart
< cend
)
3226 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3230 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3231 cstr
= scm_i_string_chars (s
);
3235 SCM_WRONG_TYPE_ARG (2, token_set
);
3237 scm_remember_upto_here_1 (s
);
3242 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3244 "Split the string @var{str} into the a list of the substrings delimited\n"
3245 "by appearances of the character @var{chr}. Note that an empty substring\n"
3246 "between separator characters will result in an empty string in the\n"
3250 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3252 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3254 "(string-split \"::\" #\\:)\n"
3256 "(\"\" \"\" \"\")\n"
3258 "(string-split \"\" #\\:)\n"
3262 #define FUNC_NAME s_scm_string_split
3269 SCM_VALIDATE_STRING (1, str
);
3270 SCM_VALIDATE_CHAR (2, chr
);
3272 idx
= scm_i_string_length (str
);
3273 p
= scm_i_string_chars (str
);
3274 ch
= SCM_CHAR (chr
);
3278 while (idx
> 0 && p
[idx
- 1] != ch
)
3282 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3283 p
= scm_i_string_chars (str
);
3287 scm_remember_upto_here_1 (str
);
3293 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3294 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3295 "Filter the string @var{s}, retaining only those characters\n"
3296 "which satisfy @var{char_pred}.\n"
3298 "If @var{char_pred} is a procedure, it is applied to each\n"
3299 "character as a predicate, if it is a character, it is tested\n"
3300 "for equality and if it is a character set, it is tested for\n"
3302 #define FUNC_NAME s_scm_string_filter
3305 size_t cstart
, cend
;
3309 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3313 /* The explicit loops below stripping leading and trailing non-matches
3314 mean we can return a substring if those are the only deletions, making
3315 string-filter as efficient as string-trim-both in that case. */
3317 if (SCM_CHARP (char_pred
))
3322 chr
= SCM_CHAR (char_pred
);
3324 /* strip leading non-matches by incrementing cstart */
3325 while (cstart
< cend
&& cstr
[cstart
] != chr
)
3328 /* strip trailing non-matches by decrementing cend */
3329 while (cend
> cstart
&& cstr
[cend
-1] != chr
)
3332 /* count chars to keep */
3334 for (idx
= cstart
; idx
< cend
; idx
++)
3335 if (cstr
[idx
] == chr
)
3338 if (count
== cend
- cstart
)
3340 /* whole of cstart to cend is to be kept, return a copy-on-write
3343 result
= scm_i_substring (s
, cstart
, cend
);
3346 result
= scm_c_make_string (count
, char_pred
);
3348 else if (SCM_CHARSETP (char_pred
))
3352 /* strip leading non-matches by incrementing cstart */
3353 while (cstart
< cend
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3356 /* strip trailing non-matches by decrementing cend */
3357 while (cend
> cstart
&& ! SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3360 /* count chars to be kept */
3362 for (idx
= cstart
; idx
< cend
; idx
++)
3363 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3366 /* if whole of start to end kept then return substring */
3367 if (count
== cend
- cstart
)
3368 goto result_substring
;
3372 result
= scm_i_make_string (count
, &dst
);
3373 cstr
= scm_i_string_chars (s
);
3375 /* decrement "count" in this loop as well as using idx, so that if
3376 another thread is simultaneously changing "s" there's no chance
3377 it'll make us copy more than count characters */
3378 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3380 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3391 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3393 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3398 ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3399 res
= pred_tramp (char_pred
, ch
);
3400 if (scm_is_true (res
))
3401 ls
= scm_cons (ch
, ls
);
3402 cstr
= scm_i_string_chars (s
);
3405 result
= scm_reverse_list_to_string (ls
);
3408 scm_remember_upto_here_1 (s
);
3414 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3415 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3416 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3418 "If @var{char_pred} is a procedure, it is applied to each\n"
3419 "character as a predicate, if it is a character, it is tested\n"
3420 "for equality and if it is a character set, it is tested for\n"
3422 #define FUNC_NAME s_scm_string_delete
3425 size_t cstart
, cend
;
3429 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3433 /* The explicit loops below stripping leading and trailing matches mean we
3434 can return a substring if those are the only deletions, making
3435 string-delete as efficient as string-trim-both in that case. */
3437 if (SCM_CHARP (char_pred
))
3442 chr
= SCM_CHAR (char_pred
);
3444 /* strip leading matches by incrementing cstart */
3445 while (cstart
< cend
&& cstr
[cstart
] == chr
)
3448 /* strip trailing matches by decrementing cend */
3449 while (cend
> cstart
&& cstr
[cend
-1] == chr
)
3452 /* count chars to be kept */
3454 for (idx
= cstart
; idx
< cend
; idx
++)
3455 if (cstr
[idx
] != chr
)
3458 if (count
== cend
- cstart
)
3460 /* whole of cstart to cend is to be kept, return a copy-on-write
3463 result
= scm_i_substring (s
, cstart
, cend
);
3467 /* new string for retained portion */
3469 result
= scm_i_make_string (count
, &dst
);
3470 cstr
= scm_i_string_chars (s
);
3472 /* decrement "count" in this loop as well as using idx, so that if
3473 another thread is simultaneously changing "s" there's no chance
3474 it'll make us copy more than count characters */
3475 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3477 if (cstr
[idx
] != chr
)
3485 else if (SCM_CHARSETP (char_pred
))
3489 /* strip leading matches by incrementing cstart */
3490 while (cstart
< cend
&& SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
3493 /* strip trailing matches by decrementing cend */
3494 while (cend
> cstart
&& SCM_CHARSET_GET (char_pred
, cstr
[cend
-1]))
3497 /* count chars to be kept */
3499 for (idx
= cstart
; idx
< cend
; idx
++)
3500 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3503 if (count
== cend
- cstart
)
3504 goto result_substring
;
3507 /* new string for retained portion */
3509 result
= scm_i_make_string (count
, &dst
);
3510 cstr
= scm_i_string_chars (s
);
3512 /* decrement "count" in this loop as well as using idx, so that if
3513 another thread is simultaneously changing "s" there's no chance
3514 it'll make us copy more than count characters */
3515 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3517 if (! SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3528 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (char_pred
);
3529 SCM_ASSERT (pred_tramp
, char_pred
, SCM_ARG2
, FUNC_NAME
);
3534 SCM res
, ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3535 res
= pred_tramp (char_pred
, ch
);
3536 if (scm_is_false (res
))
3537 ls
= scm_cons (ch
, ls
);
3538 cstr
= scm_i_string_chars (s
);
3541 result
= scm_reverse_list_to_string (ls
);
3544 scm_remember_upto_here_1 (s
);
3550 scm_init_srfi_13 (void)
3552 #include "libguile/srfi-13.x"
3555 /* End of srfi-13.c. */