1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
32 #include <libguile/deprecation.h>
33 #include "libguile/srfi-13.h"
34 #include "libguile/srfi-14.h"
36 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
37 pos_start, start, c_start, \
38 pos_end, end, c_end) \
40 SCM_VALIDATE_STRING (pos_str, str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 #define REF_IN_CHARSET(s, i, cs) \
55 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
57 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
59 "Return @code{#t} if @var{str}'s length is zero, and\n"
60 "@code{#f} otherwise.\n"
62 "(string-null? \"\") @result{} #t\n"
63 "y @result{} \"foo\"\n"
64 "(string-null? y) @result{} #f\n"
66 #define FUNC_NAME s_scm_string_null_p
68 SCM_VALIDATE_STRING (1, str
);
69 return scm_from_bool (scm_i_string_length (str
) == 0);
77 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
81 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
82 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
83 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
85 "@var{char_pred} can be a character to check for any equal to that, or\n"
86 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
87 "or a predicate procedure to call.\n"
89 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
90 "successively on the characters from @var{start} to @var{end}. If\n"
91 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
92 "stops and that return value is the return from @code{string-any}. The\n"
93 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
94 "point is reached, is a tail call.\n"
96 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
97 "@var{end}) then the return is @code{#f}.\n")
98 #define FUNC_NAME s_scm_string_any
101 SCM res
= SCM_BOOL_F
;
103 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
107 if (SCM_CHARP (char_pred
))
110 for (i
= cstart
; i
< cend
; i
++)
111 if (scm_i_string_ref (s
, i
) == SCM_CHAR (char_pred
))
117 else if (SCM_CHARSETP (char_pred
))
120 for (i
= cstart
; i
< cend
; i
++)
121 if (REF_IN_CHARSET (s
, i
, char_pred
))
129 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
130 char_pred
, SCM_ARG1
, FUNC_NAME
);
132 while (cstart
< cend
)
134 res
= scm_call_1 (char_pred
,
135 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
136 if (scm_is_true (res
))
142 scm_remember_upto_here_1 (s
);
148 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
149 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
150 "Check if @var{char_pred} is true for every character in string\n"
153 "@var{char_pred} can be a character to check for every character equal\n"
154 "to that, or a character set (@pxref{Character Sets}) to check for\n"
155 "every character being in that set, or a predicate procedure to call.\n"
157 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
158 "successively on the characters from @var{start} to @var{end}. If\n"
159 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
160 "returns @code{#f}. The call on the last character (ie.@: at\n"
161 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
162 "return from that call is the return from @code{string-every}.\n"
164 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
165 "@var{end}) then the return is @code{#t}.\n")
166 #define FUNC_NAME s_scm_string_every
169 SCM res
= SCM_BOOL_T
;
171 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
174 if (SCM_CHARP (char_pred
))
177 for (i
= cstart
; i
< cend
; i
++)
178 if (scm_i_string_ref (s
, i
) != SCM_CHAR (char_pred
))
184 else if (SCM_CHARSETP (char_pred
))
187 for (i
= cstart
; i
< cend
; i
++)
188 if (!REF_IN_CHARSET (s
, i
, char_pred
))
196 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
197 char_pred
, SCM_ARG1
, FUNC_NAME
);
199 while (cstart
< cend
)
201 res
= scm_call_1 (char_pred
,
202 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
203 if (scm_is_false (res
))
209 scm_remember_upto_here_1 (s
);
215 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
217 "@var{proc} is an integer->char procedure. Construct a string\n"
218 "of size @var{len} by applying @var{proc} to each index to\n"
219 "produce the corresponding string element. The order in which\n"
220 "@var{proc} is applied to the indices is not specified.")
221 #define FUNC_NAME s_scm_string_tabulate
227 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
228 proc
, SCM_ARG1
, FUNC_NAME
);
230 SCM_ASSERT_RANGE (2, len
, scm_to_int (len
) >= 0);
231 clen
= scm_to_size_t (len
);
234 /* This function is more complicated than necessary for the sake
236 scm_t_wchar
*buf
= scm_malloc (clen
* sizeof (scm_t_wchar
));
241 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
244 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
246 if (SCM_CHAR (ch
) > 255)
248 buf
[i
] = SCM_CHAR (ch
);
253 scm_t_wchar
*wbuf
= NULL
;
254 res
= scm_i_make_wide_string (clen
, &wbuf
, 0);
255 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
261 res
= scm_i_make_string (clen
, &nbuf
, 0);
262 for (i
= 0; i
< clen
; i
++)
263 nbuf
[i
] = (unsigned char) buf
[i
];
273 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
274 (SCM str
, SCM start
, SCM end
),
275 "Convert the string @var{str} into a list of characters.")
276 #define FUNC_NAME s_scm_substring_to_list
280 SCM result
= SCM_EOL
;
282 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
286 /* This explicit narrow/wide logic (instead of just using
287 scm_i_string_ref) is for speed optimizaion. */
288 narrow
= scm_i_is_narrow_string (str
);
291 const char *buf
= scm_i_string_chars (str
);
292 while (cstart
< cend
)
295 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
300 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
301 while (cstart
< cend
)
304 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
307 scm_remember_upto_here_1 (str
);
312 /* We export scm_substring_to_list as "string->list" since it is
313 compatible and more general. This function remains for the benefit
314 of C code that used it.
318 scm_string_to_list (SCM str
)
320 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
323 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
325 "An efficient implementation of @code{(compose string->list\n"
329 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
331 #define FUNC_NAME s_scm_reverse_list_to_string
334 long i
= scm_ilength (chrs
), j
;
338 SCM_WRONG_TYPE_ARG (1, chrs
);
339 result
= scm_i_make_string (i
, &data
, 0);
345 while (j
< i
&& scm_is_pair (rest
))
347 SCM elt
= SCM_CAR (rest
);
348 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
350 rest
= SCM_CDR (rest
);
354 result
= scm_i_string_start_writing (result
);
355 while (j
> 0 && scm_is_pair (rest
))
357 SCM elt
= SCM_CAR (rest
);
358 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
359 rest
= SCM_CDR (rest
);
362 scm_i_string_stop_writing ();
370 SCM_SYMBOL (scm_sym_infix
, "infix");
371 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
372 SCM_SYMBOL (scm_sym_suffix
, "suffix");
373 SCM_SYMBOL (scm_sym_prefix
, "prefix");
375 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
376 (SCM ls
, SCM delimiter
, SCM grammar
),
377 "Append the string in the string list @var{ls}, using the string\n"
378 "@var{delimiter} as a delimiter between the elements of @var{ls}.\n"
379 "@var{grammar} is a symbol which specifies how the delimiter is\n"
380 "placed between the strings, and defaults to the symbol\n"
385 "Insert the separator between list elements. An empty string\n"
386 "will produce an empty list.\n"
387 "@item strict-infix\n"
388 "Like @code{infix}, but will raise an error if given the empty\n"
391 "Insert the separator after every list element.\n"
393 "Insert the separator before each list element.\n"
395 #define FUNC_NAME s_scm_string_join
397 SCM append_list
= SCM_EOL
;
398 long list_len
= scm_ilength (ls
);
399 size_t delimiter_len
= 0;
401 /* Validate the string list. */
403 SCM_WRONG_TYPE_ARG (1, ls
);
405 /* Validate the delimiter and record its length. */
406 if (SCM_UNBNDP (delimiter
))
408 delimiter
= scm_from_locale_string (" ");
413 SCM_VALIDATE_STRING (2, delimiter
);
414 delimiter_len
= scm_i_string_length (delimiter
);
417 /* Validate the grammar symbol. */
418 if (SCM_UNBNDP (grammar
))
419 grammar
= scm_sym_infix
;
420 else if (!(scm_is_eq (grammar
, scm_sym_infix
)
421 || scm_is_eq (grammar
, scm_sym_strict_infix
)
422 || scm_is_eq (grammar
, scm_sym_suffix
)
423 || scm_is_eq (grammar
, scm_sym_prefix
)))
424 SCM_WRONG_TYPE_ARG (3, grammar
);
428 if (scm_is_eq (grammar
, scm_sym_strict_infix
))
429 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
432 /* Handle empty lists specially */
433 append_list
= SCM_EOL
;
435 else if (delimiter_len
== 0)
436 /* Handle empty delimiters specially */
440 SCM
*last_cdr_p
= &append_list
;
442 #define ADD_TO_APPEND_LIST(x) \
443 ((*last_cdr_p = scm_list_1 (x)), \
444 (last_cdr_p = SCM_CDRLOC (*last_cdr_p)))
446 /* Build a list of strings to pass to 'string-append'.
447 Here we assume that 'ls' has at least one element. */
449 /* If using the 'prefix' grammar, start with the delimiter. */
450 if (scm_is_eq (grammar
, scm_sym_prefix
))
451 ADD_TO_APPEND_LIST (delimiter
);
453 /* Handle the first element of 'ls' specially, so that in the loop
454 that follows we can unconditionally insert the delimiter before
455 every remaining element. */
456 ADD_TO_APPEND_LIST (SCM_CAR (ls
));
459 /* Insert the delimiter before every remaining element. */
460 while (scm_is_pair (ls
))
462 ADD_TO_APPEND_LIST (delimiter
);
463 ADD_TO_APPEND_LIST (SCM_CAR (ls
));
467 /* If using the 'suffix' grammar, add the delimiter to the end. */
468 if (scm_is_eq (grammar
, scm_sym_suffix
))
469 ADD_TO_APPEND_LIST (delimiter
);
471 #undef ADD_TO_APPEND_LIST
474 /* Construct the final result. */
475 return scm_string_append (append_list
);
480 /* There are a number of functions to consider here for Scheme and C:
482 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
483 substring/copy STR start [end] ;; Guile variant of R5RS substring
485 scm_string_copy (str) ;; Old function from Guile
486 scm_substring_copy (str, [start, [end]])
487 ;; C version of SRFI-13 string-copy
488 ;; and C version of substring/copy
490 The C function underlying string-copy is not exported to C
491 programs. scm_substring_copy is defined in strings.c as the
492 underlying function of substring/copy and allows an optional START
496 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
498 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
499 (SCM str
, SCM start
, SCM end
),
500 "Return a freshly allocated copy of the string @var{str}. If\n"
501 "given, @var{start} and @var{end} delimit the portion of\n"
502 "@var{str} which is copied.")
503 #define FUNC_NAME s_scm_srfi13_substring_copy
507 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
510 return scm_i_substring_copy (str
, cstart
, cend
);
515 scm_string_copy (SCM str
)
517 if (!scm_is_string (str
))
518 scm_wrong_type_arg ("scm_string_copy", 0, str
);
520 return scm_i_substring (str
, 0, scm_i_string_length (str
));
523 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
524 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
525 "Copy the sequence of characters from index range [@var{start},\n"
526 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
527 "at index @var{tstart}. The characters are copied left-to-right\n"
528 "or right-to-left as needed -- the copy is guaranteed to work,\n"
529 "even if @var{target} and @var{s} are the same string. It is an\n"
530 "error if the copy operation runs off the end of the target\n"
532 #define FUNC_NAME s_scm_string_copy_x
534 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
535 SCM sdummy
= SCM_UNDEFINED
;
537 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
540 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
546 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
548 target
= scm_i_string_start_writing (target
);
549 if (ctstart
< cstart
)
551 for (i
= 0; i
< len
; i
++)
552 scm_i_string_set_x (target
, ctstart
+ i
,
553 scm_i_string_ref (s
, cstart
+ i
));
558 scm_i_string_set_x (target
, ctstart
+ i
,
559 scm_i_string_ref (s
, cstart
+ i
));
561 scm_i_string_stop_writing ();
562 scm_remember_upto_here_1 (target
);
565 return SCM_UNSPECIFIED
;
569 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
570 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
571 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
572 "into @var{str2} beginning at position @var{start2}.\n"
573 "@var{str1} and @var{str2} can be the same string.")
574 #define FUNC_NAME s_scm_substring_move_x
576 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
580 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
582 "Return the @var{n} first characters of @var{s}.")
583 #define FUNC_NAME s_scm_string_take
585 return scm_substring (s
, SCM_INUM0
, n
);
590 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
592 "Return all but the first @var{n} characters of @var{s}.")
593 #define FUNC_NAME s_scm_string_drop
595 return scm_substring (s
, n
, SCM_UNDEFINED
);
600 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
602 "Return the @var{n} last characters of @var{s}.")
603 #define FUNC_NAME s_scm_string_take_right
605 return scm_substring (s
,
606 scm_difference (scm_string_length (s
), n
),
612 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
614 "Return all but the last @var{n} characters of @var{s}.")
615 #define FUNC_NAME s_scm_string_drop_right
617 return scm_substring (s
,
619 scm_difference (scm_string_length (s
), n
));
624 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
625 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
626 "Take that characters from @var{start} to @var{end} from the\n"
627 "string @var{s} and return a new string, right-padded by the\n"
628 "character @var{chr} to length @var{len}. If the resulting\n"
629 "string is longer than @var{len}, it is truncated on the right.")
630 #define FUNC_NAME s_scm_string_pad
632 size_t cstart
, cend
, clen
;
634 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
637 clen
= scm_to_size_t (len
);
639 if (SCM_UNBNDP (chr
))
640 chr
= SCM_MAKE_CHAR (' ');
643 SCM_VALIDATE_CHAR (3, chr
);
645 if (clen
< (cend
- cstart
))
646 return scm_i_substring (s
, cend
- clen
, cend
);
650 result
= (scm_string_append
651 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
652 scm_i_substring (s
, cstart
, cend
))));
659 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
660 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
661 "Take that characters from @var{start} to @var{end} from the\n"
662 "string @var{s} and return a new string, left-padded by the\n"
663 "character @var{chr} to length @var{len}. If the resulting\n"
664 "string is longer than @var{len}, it is truncated on the left.")
665 #define FUNC_NAME s_scm_string_pad_right
667 size_t cstart
, cend
, clen
;
669 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
672 clen
= scm_to_size_t (len
);
674 if (SCM_UNBNDP (chr
))
675 chr
= SCM_MAKE_CHAR (' ');
678 SCM_VALIDATE_CHAR (3, chr
);
680 if (clen
< (cend
- cstart
))
681 return scm_i_substring (s
, cstart
, cstart
+ clen
);
686 result
= (scm_string_append
687 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
688 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
696 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
697 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
698 "Trim @var{s} by skipping over all characters on the left\n"
699 "that satisfy the parameter @var{char_pred}:\n"
703 "if it is the character @var{ch}, characters equal to\n"
704 "@var{ch} are trimmed,\n"
707 "if it is a procedure @var{pred} characters that\n"
708 "satisfy @var{pred} are trimmed,\n"
711 "if it is a character set, characters in that set are trimmed.\n"
714 "If called without a @var{char_pred} argument, all whitespace is\n"
716 #define FUNC_NAME s_scm_string_trim
720 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
723 if (SCM_UNBNDP (char_pred
)
724 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
726 while (cstart
< cend
)
728 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
733 else if (SCM_CHARP (char_pred
))
735 while (cstart
< cend
)
737 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
742 else if (SCM_CHARSETP (char_pred
))
744 while (cstart
< cend
)
746 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
753 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
754 char_pred
, SCM_ARG2
, FUNC_NAME
);
756 while (cstart
< cend
)
760 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
761 if (scm_is_false (res
))
766 return scm_i_substring (s
, cstart
, cend
);
771 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
772 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
773 "Trim @var{s} by skipping over all characters on the right\n"
774 "that satisfy the parameter @var{char_pred}:\n"
778 "if it is the character @var{ch}, characters equal to @var{ch}\n"
782 "if it is a procedure @var{pred} characters that satisfy\n"
783 "@var{pred} are trimmed,\n"
786 "if it is a character sets, all characters in that set are\n"
790 "If called without a @var{char_pred} argument, all whitespace is\n"
792 #define FUNC_NAME s_scm_string_trim_right
796 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
799 if (SCM_UNBNDP (char_pred
)
800 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
802 while (cstart
< cend
)
804 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
809 else if (SCM_CHARP (char_pred
))
811 while (cstart
< cend
)
813 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
818 else if (SCM_CHARSETP (char_pred
))
820 while (cstart
< cend
)
822 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
829 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
830 char_pred
, SCM_ARG2
, FUNC_NAME
);
832 while (cstart
< cend
)
836 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
837 if (scm_is_false (res
))
842 return scm_i_substring (s
, cstart
, cend
);
847 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
848 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
849 "Trim @var{s} by skipping over all characters on both sides of\n"
850 "the string that satisfy the parameter @var{char_pred}:\n"
854 "if it is the character @var{ch}, characters equal to @var{ch}\n"
858 "if it is a procedure @var{pred} characters that satisfy\n"
859 "@var{pred} are trimmed,\n"
862 "if it is a character set, the characters in the set are\n"
866 "If called without a @var{char_pred} argument, all whitespace is\n"
868 #define FUNC_NAME s_scm_string_trim_both
872 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
875 if (SCM_UNBNDP (char_pred
)
876 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
878 while (cstart
< cend
)
880 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
884 while (cstart
< cend
)
886 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
891 else if (SCM_CHARP (char_pred
))
893 while (cstart
< cend
)
895 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
899 while (cstart
< cend
)
901 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
906 else if (SCM_CHARSETP (char_pred
))
908 while (cstart
< cend
)
910 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
914 while (cstart
< cend
)
916 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
923 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
924 char_pred
, SCM_ARG2
, FUNC_NAME
);
926 while (cstart
< cend
)
930 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
931 if (scm_is_false (res
))
935 while (cstart
< cend
)
939 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
940 if (scm_is_false (res
))
945 return scm_i_substring (s
, cstart
, cend
);
950 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
951 (SCM str
, SCM chr
, SCM start
, SCM end
),
952 "Stores @var{chr} in every element of the given @var{str} and\n"
953 "returns an unspecified value.")
954 #define FUNC_NAME s_scm_substring_fill_x
959 /* Older versions of Guile provided the function
960 scm_substring_fill_x with the following order of arguments:
964 We accomodate this here by detecting such a usage and reordering
975 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
978 SCM_VALIDATE_CHAR (2, chr
);
982 str
= scm_i_string_start_writing (str
);
983 for (k
= cstart
; k
< cend
; k
++)
984 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
985 scm_i_string_stop_writing ();
988 return SCM_UNSPECIFIED
;
993 scm_string_fill_x (SCM str
, SCM chr
)
995 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
998 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
999 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1000 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1001 "mismatch index, depending upon whether @var{s1} is less than,\n"
1002 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1003 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1004 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1005 "@var{i} is the first position that does not match.")
1006 #define FUNC_NAME s_scm_string_compare
1008 size_t cstart1
, cend1
, cstart2
, cend2
;
1011 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1014 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1017 SCM_VALIDATE_PROC (3, proc_lt
);
1018 SCM_VALIDATE_PROC (4, proc_eq
);
1019 SCM_VALIDATE_PROC (5, proc_gt
);
1021 while (cstart1
< cend1
&& cstart2
< cend2
)
1023 if (scm_i_string_ref (s1
, cstart1
)
1024 < scm_i_string_ref (s2
, cstart2
))
1029 else if (scm_i_string_ref (s1
, cstart1
)
1030 > scm_i_string_ref (s2
, 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 where the lowercased letters \n"
1061 #define FUNC_NAME s_scm_string_compare_ci
1063 size_t cstart1
, cend1
, cstart2
, cend2
;
1066 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1069 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1072 SCM_VALIDATE_PROC (3, proc_lt
);
1073 SCM_VALIDATE_PROC (4, proc_eq
);
1074 SCM_VALIDATE_PROC (5, proc_gt
);
1076 while (cstart1
< cend1
&& cstart2
< cend2
)
1078 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1079 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1084 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1085 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, 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
));
1107 /* This function compares two substrings, S1 from START1 to END1 and
1108 S2 from START2 to END2, possibly case insensitively, and returns
1109 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1110 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1111 longer, or equal. */
1113 compare_strings (const char *fname
, int case_insensitive
,
1114 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1115 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1117 size_t cstart1
, cend1
, cstart2
, cend2
;
1121 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1124 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1128 while (cstart1
< cend1
&& cstart2
< cend2
)
1130 if (case_insensitive
)
1132 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1133 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1137 a
= scm_i_string_ref (s1
, cstart1
);
1138 b
= scm_i_string_ref (s2
, cstart2
);
1153 if (cstart1
< cend1
)
1158 else if (cstart2
< cend2
)
1170 scm_remember_upto_here_2 (s1
, s2
);
1175 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1176 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1177 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1179 #define FUNC_NAME s_scm_string_eq
1181 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1182 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1183 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1184 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1186 /* Fast path for this common case, which avoids the repeated calls to
1187 `scm_i_string_ref'. */
1190 len1
= scm_i_string_length (s1
);
1191 len2
= scm_i_string_length (s2
);
1197 if (!scm_i_is_narrow_string (s1
))
1200 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1201 scm_i_string_data (s2
),
1206 return compare_strings (FUNC_NAME
, 0,
1207 s1
, s2
, start1
, end1
, start2
, end2
,
1208 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1213 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1214 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1215 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1217 #define FUNC_NAME s_scm_string_neq
1219 return compare_strings (FUNC_NAME
, 0,
1220 s1
, s2
, start1
, end1
, start2
, end2
,
1221 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1226 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1227 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1228 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1229 "true value otherwise.")
1230 #define FUNC_NAME s_scm_string_lt
1232 return compare_strings (FUNC_NAME
, 0,
1233 s1
, s2
, start1
, end1
, start2
, end2
,
1234 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1239 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1240 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1241 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1242 "true value otherwise.")
1243 #define FUNC_NAME s_scm_string_gt
1245 return compare_strings (FUNC_NAME
, 0,
1246 s1
, s2
, start1
, end1
, start2
, end2
,
1247 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1252 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1253 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1254 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1256 #define FUNC_NAME s_scm_string_le
1258 return compare_strings (FUNC_NAME
, 0,
1259 s1
, s2
, start1
, end1
, start2
, end2
,
1260 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1265 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1266 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1267 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1269 #define FUNC_NAME s_scm_string_ge
1271 return compare_strings (FUNC_NAME
, 0,
1272 s1
, s2
, start1
, end1
, start2
, end2
,
1273 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1278 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1279 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1280 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1281 "value otherwise. The character comparison is done\n"
1282 "case-insensitively.")
1283 #define FUNC_NAME s_scm_string_ci_eq
1285 return compare_strings (FUNC_NAME
, 1,
1286 s1
, s2
, start1
, end1
, start2
, end2
,
1287 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1292 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1293 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1294 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1295 "value otherwise. The character comparison is done\n"
1296 "case-insensitively.")
1297 #define FUNC_NAME s_scm_string_ci_neq
1299 return compare_strings (FUNC_NAME
, 1,
1300 s1
, s2
, start1
, end1
, start2
, end2
,
1301 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1306 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1307 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1308 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1309 "true value otherwise. The character comparison is done\n"
1310 "case-insensitively.")
1311 #define FUNC_NAME s_scm_string_ci_lt
1313 return compare_strings (FUNC_NAME
, 1,
1314 s1
, s2
, start1
, end1
, start2
, end2
,
1315 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1320 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1321 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1322 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1323 "true value otherwise. The character comparison is done\n"
1324 "case-insensitively.")
1325 #define FUNC_NAME s_scm_string_ci_gt
1327 return compare_strings (FUNC_NAME
, 1,
1328 s1
, s2
, start1
, end1
, start2
, end2
,
1329 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1334 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1335 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1336 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1337 "value otherwise. The character comparison is done\n"
1338 "case-insensitively.")
1339 #define FUNC_NAME s_scm_string_ci_le
1341 return compare_strings (FUNC_NAME
, 1,
1342 s1
, s2
, start1
, end1
, start2
, end2
,
1343 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1348 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1349 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1350 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1351 "otherwise. The character comparison is done\n"
1352 "case-insensitively.")
1353 #define FUNC_NAME s_scm_string_ci_ge
1355 return compare_strings (FUNC_NAME
, 1,
1356 s1
, s2
, start1
, end1
, start2
, end2
,
1357 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1361 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1362 (SCM s
, SCM bound
, SCM start
, SCM end
),
1363 "Compute a hash value for @var{s}. the optional argument "
1364 "@var{bound} is a non-negative exact "
1365 "integer specifying the range of the hash function. "
1366 "A positive value restricts the return value to the "
1368 #define FUNC_NAME s_scm_substring_hash
1370 if (SCM_UNBNDP (bound
))
1371 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1372 if (SCM_UNBNDP (start
))
1374 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1378 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1379 (SCM s
, SCM bound
, SCM start
, SCM end
),
1380 "Compute a hash value for @var{s}. the optional argument "
1381 "@var{bound} is a non-negative exact "
1382 "integer specifying the range of the hash function. "
1383 "A positive value restricts the return value to the "
1385 #define FUNC_NAME s_scm_substring_hash_ci
1387 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1389 SCM_UNDEFINED
, SCM_UNDEFINED
);
1393 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1394 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1395 "Return the length of the longest common prefix of the two\n"
1397 #define FUNC_NAME s_scm_string_prefix_length
1399 size_t cstart1
, cend1
, cstart2
, cend2
;
1402 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1405 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1409 while (cstart1
< cend1
&& cstart2
< cend2
)
1411 if (scm_i_string_ref (s1
, cstart1
)
1412 != scm_i_string_ref (s2
, cstart2
))
1420 scm_remember_upto_here_2 (s1
, s2
);
1421 return scm_from_size_t (len
);
1426 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1427 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1428 "Return the length of the longest common prefix of the two\n"
1429 "strings, ignoring character case.")
1430 #define FUNC_NAME s_scm_string_prefix_length_ci
1432 size_t cstart1
, cend1
, cstart2
, cend2
;
1435 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1438 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1441 while (cstart1
< cend1
&& cstart2
< cend2
)
1443 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1444 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1452 scm_remember_upto_here_2 (s1
, s2
);
1453 return scm_from_size_t (len
);
1458 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1459 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1460 "Return the length of the longest common suffix of the two\n"
1462 #define FUNC_NAME s_scm_string_suffix_length
1464 size_t cstart1
, cend1
, cstart2
, cend2
;
1467 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1470 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1473 while (cstart1
< cend1
&& cstart2
< cend2
)
1477 if (scm_i_string_ref (s1
, cend1
)
1478 != scm_i_string_ref (s2
, cend2
))
1484 scm_remember_upto_here_2 (s1
, s2
);
1485 return scm_from_size_t (len
);
1490 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1491 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1492 "Return the length of the longest common suffix of the two\n"
1493 "strings, ignoring character case.")
1494 #define FUNC_NAME s_scm_string_suffix_length_ci
1496 size_t cstart1
, cend1
, cstart2
, cend2
;
1499 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1502 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1505 while (cstart1
< cend1
&& cstart2
< cend2
)
1509 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1510 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1516 scm_remember_upto_here_2 (s1
, s2
);
1517 return scm_from_size_t (len
);
1522 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1523 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1524 "Is @var{s1} a prefix of @var{s2}?")
1525 #define FUNC_NAME s_scm_string_prefix_p
1527 size_t cstart1
, cend1
, cstart2
, cend2
;
1528 size_t len
= 0, len1
;
1530 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1533 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1536 len1
= cend1
- cstart1
;
1537 while (cstart1
< cend1
&& cstart2
< cend2
)
1539 if (scm_i_string_ref (s1
, cstart1
)
1540 != scm_i_string_ref (s2
, cstart2
))
1548 scm_remember_upto_here_2 (s1
, s2
);
1549 return scm_from_bool (len
== len1
);
1554 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1555 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1556 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1557 #define FUNC_NAME s_scm_string_prefix_ci_p
1559 size_t cstart1
, cend1
, cstart2
, cend2
;
1560 size_t len
= 0, len1
;
1562 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1565 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1568 len1
= cend1
- cstart1
;
1569 while (cstart1
< cend1
&& cstart2
< cend2
)
1571 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1572 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1581 scm_remember_upto_here_2 (s1
, s2
);
1582 return scm_from_bool (len
== len1
);
1587 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1588 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1589 "Is @var{s1} a suffix of @var{s2}?")
1590 #define FUNC_NAME s_scm_string_suffix_p
1592 size_t cstart1
, cend1
, cstart2
, cend2
;
1593 size_t len
= 0, len1
;
1595 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1598 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1601 len1
= cend1
- cstart1
;
1602 while (cstart1
< cend1
&& cstart2
< cend2
)
1606 if (scm_i_string_ref (s1
, cend1
)
1607 != scm_i_string_ref (s2
, cend2
))
1613 scm_remember_upto_here_2 (s1
, s2
);
1614 return scm_from_bool (len
== len1
);
1619 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1620 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1621 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1622 #define FUNC_NAME s_scm_string_suffix_ci_p
1624 size_t cstart1
, cend1
, cstart2
, cend2
;
1625 size_t len
= 0, len1
;
1627 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1630 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1633 len1
= cend1
- cstart1
;
1634 while (cstart1
< cend1
&& cstart2
< cend2
)
1638 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1639 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1645 scm_remember_upto_here_2 (s1
, s2
);
1646 return scm_from_bool (len
== len1
);
1651 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1652 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1653 "Search through the string @var{s} from left to right, returning\n"
1654 "the index of the first occurrence of a character which\n"
1656 "@itemize @bullet\n"
1658 "equals @var{char_pred}, if it is character,\n"
1661 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1664 "is in the set @var{char_pred}, if it is a character set.\n"
1666 "Return @code{#f} if no match is found.")
1667 #define FUNC_NAME s_scm_string_index
1669 size_t cstart
, cend
;
1671 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1674 if (SCM_CHARP (char_pred
))
1676 while (cstart
< cend
)
1678 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1683 else if (SCM_CHARSETP (char_pred
))
1685 while (cstart
< cend
)
1687 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1694 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1695 char_pred
, SCM_ARG2
, FUNC_NAME
);
1697 while (cstart
< cend
)
1700 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1701 if (scm_is_true (res
))
1707 scm_remember_upto_here_1 (s
);
1711 scm_remember_upto_here_1 (s
);
1712 return scm_from_size_t (cstart
);
1716 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1717 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1718 "Search through the string @var{s} from right to left, returning\n"
1719 "the index of the last occurrence of a character which\n"
1721 "@itemize @bullet\n"
1723 "equals @var{char_pred}, if it is character,\n"
1726 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1729 "is in the set if @var{char_pred} is a character set.\n"
1731 "Return @code{#f} if no match is found.")
1732 #define FUNC_NAME s_scm_string_index_right
1734 size_t cstart
, cend
;
1736 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1739 if (SCM_CHARP (char_pred
))
1741 while (cstart
< cend
)
1744 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1748 else if (SCM_CHARSETP (char_pred
))
1750 while (cstart
< cend
)
1753 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1759 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1760 char_pred
, SCM_ARG2
, FUNC_NAME
);
1762 while (cstart
< cend
)
1766 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1767 if (scm_is_true (res
))
1772 scm_remember_upto_here_1 (s
);
1776 scm_remember_upto_here_1 (s
);
1777 return scm_from_size_t (cend
);
1781 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1782 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1783 "Search through the string @var{s} from right to left, returning\n"
1784 "the index of the last occurrence of a character which\n"
1786 "@itemize @bullet\n"
1788 "equals @var{char_pred}, if it is character,\n"
1791 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1794 "is in the set if @var{char_pred} is a character set.\n"
1796 "Return @code{#f} if no match is found.")
1797 #define FUNC_NAME s_scm_string_rindex
1799 return scm_string_index_right (s
, char_pred
, start
, end
);
1803 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1804 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1805 "Search through the string @var{s} from left to right, returning\n"
1806 "the index of the first occurrence of a character which\n"
1808 "@itemize @bullet\n"
1810 "does not equal @var{char_pred}, if it is character,\n"
1813 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1817 "is not in the set if @var{char_pred} is a character set.\n"
1819 #define FUNC_NAME s_scm_string_skip
1821 size_t cstart
, cend
;
1823 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1826 if (SCM_CHARP (char_pred
))
1828 while (cstart
< cend
)
1830 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1835 else if (SCM_CHARSETP (char_pred
))
1837 while (cstart
< cend
)
1839 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1846 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1847 char_pred
, SCM_ARG2
, FUNC_NAME
);
1849 while (cstart
< cend
)
1852 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1853 if (scm_is_false (res
))
1859 scm_remember_upto_here_1 (s
);
1863 scm_remember_upto_here_1 (s
);
1864 return scm_from_size_t (cstart
);
1869 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1870 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1871 "Search through the string @var{s} from right to left, returning\n"
1872 "the index of the last occurrence of a character which\n"
1874 "@itemize @bullet\n"
1876 "does not equal @var{char_pred}, if it is character,\n"
1879 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1883 "is not in the set if @var{char_pred} is a character set.\n"
1885 #define FUNC_NAME s_scm_string_skip_right
1887 size_t cstart
, cend
;
1889 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1892 if (SCM_CHARP (char_pred
))
1894 while (cstart
< cend
)
1897 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1901 else if (SCM_CHARSETP (char_pred
))
1903 while (cstart
< cend
)
1906 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1912 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1913 char_pred
, SCM_ARG2
, FUNC_NAME
);
1915 while (cstart
< cend
)
1919 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1920 if (scm_is_false (res
))
1925 scm_remember_upto_here_1 (s
);
1929 scm_remember_upto_here_1 (s
);
1930 return scm_from_size_t (cend
);
1936 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1937 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1938 "Return the count of the number of characters in the string\n"
1941 "@itemize @bullet\n"
1943 "equals @var{char_pred}, if it is character,\n"
1946 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1949 "is in the set @var{char_pred}, if it is a character set.\n"
1951 #define FUNC_NAME s_scm_string_count
1953 size_t cstart
, cend
;
1956 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1959 if (SCM_CHARP (char_pred
))
1961 while (cstart
< cend
)
1963 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1968 else if (SCM_CHARSETP (char_pred
))
1970 while (cstart
< cend
)
1972 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1979 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1980 char_pred
, SCM_ARG2
, FUNC_NAME
);
1982 while (cstart
< cend
)
1985 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1986 if (scm_is_true (res
))
1992 scm_remember_upto_here_1 (s
);
1993 return scm_from_size_t (count
);
1998 /* FIXME::martin: This should definitely get implemented more
1999 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2001 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2002 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2003 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2004 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2005 "The optional start/end indices restrict the operation to the\n"
2006 "indicated substrings.")
2007 #define FUNC_NAME s_scm_string_contains
2009 size_t cstart1
, cend1
, cstart2
, cend2
;
2012 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2015 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2018 len2
= cend2
- cstart2
;
2019 if (cend1
- cstart1
>= len2
)
2020 while (cstart1
<= cend1
- len2
)
2026 && (scm_i_string_ref (s1
, i
)
2027 == scm_i_string_ref (s2
, j
)))
2034 scm_remember_upto_here_2 (s1
, s2
);
2035 return scm_from_size_t (cstart1
);
2040 scm_remember_upto_here_2 (s1
, s2
);
2046 /* FIXME::martin: This should definitely get implemented more
2047 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2049 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2050 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2051 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2052 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2053 "The optional start/end indices restrict the operation to the\n"
2054 "indicated substrings. Character comparison is done\n"
2055 "case-insensitively.")
2056 #define FUNC_NAME s_scm_string_contains_ci
2058 size_t cstart1
, cend1
, cstart2
, cend2
;
2061 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2064 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2067 len2
= cend2
- cstart2
;
2068 if (cend1
- cstart1
>= len2
)
2069 while (cstart1
<= cend1
- len2
)
2075 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2076 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2083 scm_remember_upto_here_2 (s1
, s2
);
2084 return scm_from_size_t (cstart1
);
2089 scm_remember_upto_here_2 (s1
, s2
);
2095 /* Helper function for the string uppercase conversion functions. */
2097 string_upcase_x (SCM v
, size_t start
, size_t end
)
2103 v
= scm_i_string_start_writing (v
);
2104 for (k
= start
; k
< end
; ++k
)
2105 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2106 scm_i_string_stop_writing ();
2107 scm_remember_upto_here_1 (v
);
2113 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2114 (SCM str
, SCM start
, SCM end
),
2115 "Destructively upcase every character in @code{str}.\n"
2118 "(string-upcase! y)\n"
2119 "@result{} \"ARRDEFG\"\n"
2121 "@result{} \"ARRDEFG\"\n"
2123 #define FUNC_NAME s_scm_substring_upcase_x
2125 size_t cstart
, cend
;
2127 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2130 return string_upcase_x (str
, cstart
, cend
);
2135 scm_string_upcase_x (SCM str
)
2137 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2140 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2141 (SCM str
, SCM start
, SCM end
),
2142 "Upcase every character in @code{str}.")
2143 #define FUNC_NAME s_scm_substring_upcase
2145 size_t cstart
, cend
;
2147 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2150 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2155 scm_string_upcase (SCM str
)
2157 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2160 /* Helper function for the string lowercase conversion functions.
2161 * No argument checking is performed. */
2163 string_downcase_x (SCM v
, size_t start
, size_t end
)
2169 v
= scm_i_string_start_writing (v
);
2170 for (k
= start
; k
< end
; ++k
)
2171 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2172 scm_i_string_stop_writing ();
2173 scm_remember_upto_here_1 (v
);
2179 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2180 (SCM str
, SCM start
, SCM end
),
2181 "Destructively downcase every character in @var{str}.\n"
2185 "@result{} \"ARRDEFG\"\n"
2186 "(string-downcase! y)\n"
2187 "@result{} \"arrdefg\"\n"
2189 "@result{} \"arrdefg\"\n"
2191 #define FUNC_NAME s_scm_substring_downcase_x
2193 size_t cstart
, cend
;
2195 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2198 return string_downcase_x (str
, cstart
, cend
);
2203 scm_string_downcase_x (SCM str
)
2205 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2208 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2209 (SCM str
, SCM start
, SCM end
),
2210 "Downcase every character in @var{str}.")
2211 #define FUNC_NAME s_scm_substring_downcase
2213 size_t cstart
, cend
;
2215 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2218 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2223 scm_string_downcase (SCM str
)
2225 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2228 /* Helper function for the string capitalization functions.
2229 * No argument checking is performed. */
2231 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2239 str
= scm_i_string_start_writing (str
);
2240 for(i
= start
; i
< end
; i
++)
2242 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2243 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2247 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2252 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2258 scm_i_string_stop_writing ();
2259 scm_remember_upto_here_1 (str
);
2266 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2267 (SCM str
, SCM start
, SCM end
),
2268 "Destructively titlecase every first character in a word in\n"
2270 #define FUNC_NAME s_scm_string_titlecase_x
2272 size_t cstart
, cend
;
2274 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2277 return string_titlecase_x (str
, cstart
, cend
);
2282 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2283 (SCM str
, SCM start
, SCM end
),
2284 "Titlecase every first character in a word in @var{str}.")
2285 #define FUNC_NAME s_scm_string_titlecase
2287 size_t cstart
, cend
;
2289 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2292 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2296 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2298 "Upcase the first character of every word in @var{str}\n"
2299 "destructively and return @var{str}.\n"
2302 "y @result{} \"hello world\"\n"
2303 "(string-capitalize! y) @result{} \"Hello World\"\n"
2304 "y @result{} \"Hello World\"\n"
2306 #define FUNC_NAME s_scm_string_capitalize_x
2308 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2313 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2315 "Return a freshly allocated string with the characters in\n"
2316 "@var{str}, where the first character of every word is\n"
2318 #define FUNC_NAME s_scm_string_capitalize
2320 return scm_string_capitalize_x (scm_string_copy (str
));
2325 /* Reverse the portion of @var{str} between str[cstart] (including)
2326 and str[cend] excluding. */
2328 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2332 str
= scm_i_string_start_writing (str
);
2338 while (cstart
< cend
)
2340 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2341 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2342 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2347 scm_i_string_stop_writing ();
2352 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2353 (SCM str
, SCM start
, SCM end
),
2354 "Reverse the string @var{str}. The optional arguments\n"
2355 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2357 #define FUNC_NAME s_scm_string_reverse
2359 size_t cstart
, cend
;
2362 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2365 result
= scm_string_copy (str
);
2366 string_reverse_x (result
, cstart
, cend
);
2367 scm_remember_upto_here_1 (str
);
2373 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2374 (SCM str
, SCM start
, SCM end
),
2375 "Reverse the string @var{str} in-place. The optional arguments\n"
2376 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2377 "operate on. The return value is unspecified.")
2378 #define FUNC_NAME s_scm_string_reverse_x
2380 size_t cstart
, cend
;
2382 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2386 string_reverse_x (str
, cstart
, cend
);
2387 scm_remember_upto_here_1 (str
);
2388 return SCM_UNSPECIFIED
;
2393 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2395 "Like @code{string-append}, but the result may share memory\n"
2396 "with the argument strings.")
2397 #define FUNC_NAME s_scm_string_append_shared
2399 /* If "rest" contains just one non-empty string, return that.
2400 If it's entirely empty strings, then return scm_nullstr.
2401 Otherwise use scm_string_concatenate. */
2403 SCM ret
= scm_nullstr
;
2404 int seen_nonempty
= 0;
2407 SCM_VALIDATE_REST_ARGUMENT (rest
);
2409 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2412 if (!scm_is_string (s
))
2413 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2414 if (scm_i_string_length (s
) != 0)
2417 /* two or more non-empty strings, need full concat */
2418 return scm_string_append (rest
);
2429 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2431 "Append the elements of @var{ls} (which must be strings)\n"
2432 "together into a single string. Guaranteed to return a freshly\n"
2433 "allocated string.")
2434 #define FUNC_NAME s_scm_string_concatenate
2436 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2437 return scm_string_append (ls
);
2442 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2443 (SCM ls
, SCM final_string
, SCM end
),
2444 "Without optional arguments, this procedure is equivalent to\n"
2447 "(string-concatenate (reverse ls))\n"
2450 "If the optional argument @var{final_string} is specified, it is\n"
2451 "consed onto the beginning to @var{ls} before performing the\n"
2452 "list-reverse and string-concatenate operations. If @var{end}\n"
2453 "is given, only the characters of @var{final_string} up to index\n"
2454 "@var{end} are used.\n"
2456 "Guaranteed to return a freshly allocated string.")
2457 #define FUNC_NAME s_scm_string_concatenate_reverse
2459 if (!SCM_UNBNDP (end
))
2460 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2462 if (!SCM_UNBNDP (final_string
))
2463 ls
= scm_cons (final_string
, ls
);
2465 return scm_string_concatenate (scm_reverse (ls
));
2470 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2472 "Like @code{string-concatenate}, but the result may share memory\n"
2473 "with the strings in the list @var{ls}.")
2474 #define FUNC_NAME s_scm_string_concatenate_shared
2476 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2477 return scm_string_append_shared (ls
);
2482 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2483 (SCM ls
, SCM final_string
, SCM end
),
2484 "Like @code{string-concatenate-reverse}, but the result may\n"
2485 "share memory with the strings in the @var{ls} arguments.")
2486 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2488 /* Just call the non-sharing version. */
2489 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2494 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2495 (SCM proc
, SCM s
, SCM start
, SCM end
),
2496 "@var{proc} is a char->char procedure, it is mapped over\n"
2497 "@var{s}. The order in which the procedure is applied to the\n"
2498 "string elements is not specified.")
2499 #define FUNC_NAME s_scm_string_map
2502 size_t cstart
, cend
;
2505 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2506 proc
, SCM_ARG1
, FUNC_NAME
);
2507 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2510 result
= scm_i_make_string (cend
- cstart
, NULL
, 0);
2512 while (cstart
< cend
)
2514 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2515 if (!SCM_CHARP (ch
))
2516 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2518 result
= scm_i_string_start_writing (result
);
2519 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2520 scm_i_string_stop_writing ();
2529 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2530 (SCM proc
, SCM s
, SCM start
, SCM end
),
2531 "@var{proc} is a char->char procedure, it is mapped over\n"
2532 "@var{s}. The order in which the procedure is applied to the\n"
2533 "string elements is not specified. The string @var{s} is\n"
2534 "modified in-place, the return value is not specified.")
2535 #define FUNC_NAME s_scm_string_map_x
2537 size_t cstart
, cend
;
2539 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2540 proc
, SCM_ARG1
, FUNC_NAME
);
2541 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2544 while (cstart
< cend
)
2546 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2547 if (!SCM_CHARP (ch
))
2548 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2549 s
= scm_i_string_start_writing (s
);
2550 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2551 scm_i_string_stop_writing ();
2554 return SCM_UNSPECIFIED
;
2559 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2560 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2561 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2562 "as the terminating element, from left to right. @var{kons}\n"
2563 "must expect two arguments: The actual character and the last\n"
2564 "result of @var{kons}' application.")
2565 #define FUNC_NAME s_scm_string_fold
2567 size_t cstart
, cend
;
2570 SCM_VALIDATE_PROC (1, kons
);
2571 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2575 while (cstart
< cend
)
2577 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2581 scm_remember_upto_here_1 (s
);
2587 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2588 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2589 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2590 "as the terminating element, from right to left. @var{kons}\n"
2591 "must expect two arguments: The actual character and the last\n"
2592 "result of @var{kons}' application.")
2593 #define FUNC_NAME s_scm_string_fold_right
2595 size_t cstart
, cend
;
2598 SCM_VALIDATE_PROC (1, kons
);
2599 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2603 while (cstart
< cend
)
2605 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2609 scm_remember_upto_here_1 (s
);
2615 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2616 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2617 "@itemize @bullet\n"
2618 "@item @var{g} is used to generate a series of @emph{seed}\n"
2619 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2620 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2622 "@item @var{p} tells us when to stop -- when it returns true\n"
2623 "when applied to one of these seed values.\n"
2624 "@item @var{f} maps each seed value to the corresponding\n"
2625 "character in the result string. These chars are assembled\n"
2626 "into the string in a left-to-right order.\n"
2627 "@item @var{base} is the optional initial/leftmost portion\n"
2628 "of the constructed string; it default to the empty\n"
2630 "@item @var{make_final} is applied to the terminal seed\n"
2631 "value (on which @var{p} returns true) to produce\n"
2632 "the final/rightmost portion of the constructed string.\n"
2633 "It defaults to @code{(lambda (x) "")}.\n"
2635 #define FUNC_NAME s_scm_string_unfold
2639 SCM_VALIDATE_PROC (1, p
);
2640 SCM_VALIDATE_PROC (2, f
);
2641 SCM_VALIDATE_PROC (3, g
);
2642 if (!SCM_UNBNDP (base
))
2644 SCM_VALIDATE_STRING (5, base
);
2648 ans
= scm_i_make_string (0, NULL
, 0);
2649 if (!SCM_UNBNDP (make_final
))
2650 SCM_VALIDATE_PROC (6, make_final
);
2652 res
= scm_call_1 (p
, seed
);
2653 while (scm_is_false (res
))
2657 SCM ch
= scm_call_1 (f
, seed
);
2658 if (!SCM_CHARP (ch
))
2659 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2660 str
= scm_i_make_string (1, NULL
, 0);
2661 str
= scm_i_string_start_writing (str
);
2662 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2663 scm_i_string_stop_writing ();
2666 ans
= scm_string_append (scm_list_2 (ans
, str
));
2667 seed
= scm_call_1 (g
, seed
);
2668 res
= scm_call_1 (p
, seed
);
2670 if (!SCM_UNBNDP (make_final
))
2672 res
= scm_call_1 (make_final
, seed
);
2673 return scm_string_append (scm_list_2 (ans
, res
));
2681 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2682 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2683 "@itemize @bullet\n"
2684 "@item @var{g} is used to generate a series of @emph{seed}\n"
2685 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2686 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2688 "@item @var{p} tells us when to stop -- when it returns true\n"
2689 "when applied to one of these seed values.\n"
2690 "@item @var{f} maps each seed value to the corresponding\n"
2691 "character in the result string. These chars are assembled\n"
2692 "into the string in a right-to-left order.\n"
2693 "@item @var{base} is the optional initial/rightmost portion\n"
2694 "of the constructed string; it default to the empty\n"
2696 "@item @var{make_final} is applied to the terminal seed\n"
2697 "value (on which @var{p} returns true) to produce\n"
2698 "the final/leftmost portion of the constructed string.\n"
2699 "It defaults to @code{(lambda (x) "")}.\n"
2701 #define FUNC_NAME s_scm_string_unfold_right
2705 SCM_VALIDATE_PROC (1, p
);
2706 SCM_VALIDATE_PROC (2, f
);
2707 SCM_VALIDATE_PROC (3, g
);
2708 if (!SCM_UNBNDP (base
))
2710 SCM_VALIDATE_STRING (5, base
);
2714 ans
= scm_i_make_string (0, NULL
, 0);
2715 if (!SCM_UNBNDP (make_final
))
2716 SCM_VALIDATE_PROC (6, make_final
);
2718 res
= scm_call_1 (p
, seed
);
2719 while (scm_is_false (res
))
2723 SCM ch
= scm_call_1 (f
, seed
);
2724 if (!SCM_CHARP (ch
))
2725 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2726 str
= scm_i_make_string (1, NULL
, 0);
2727 str
= scm_i_string_start_writing (str
);
2728 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2729 scm_i_string_stop_writing ();
2732 ans
= scm_string_append (scm_list_2 (str
, ans
));
2733 seed
= scm_call_1 (g
, seed
);
2734 res
= scm_call_1 (p
, seed
);
2736 if (!SCM_UNBNDP (make_final
))
2738 res
= scm_call_1 (make_final
, seed
);
2739 return scm_string_append (scm_list_2 (res
, ans
));
2747 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2748 (SCM proc
, SCM s
, SCM start
, SCM end
),
2749 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2750 "return value is not specified.")
2751 #define FUNC_NAME s_scm_string_for_each
2753 size_t cstart
, cend
;
2755 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2756 proc
, SCM_ARG1
, FUNC_NAME
);
2757 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2760 while (cstart
< cend
)
2762 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2766 scm_remember_upto_here_1 (s
);
2767 return SCM_UNSPECIFIED
;
2771 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2772 (SCM proc
, SCM s
, SCM start
, SCM end
),
2773 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2776 "For example, to change characters to alternately upper and\n"
2780 "(define str (string-copy \"studly\"))\n"
2781 "(string-for-each-index\n"
2783 " (string-set! str i\n"
2784 " ((if (even? i) char-upcase char-downcase)\n"
2785 " (string-ref str i))))\n"
2787 "str @result{} \"StUdLy\"\n"
2789 #define FUNC_NAME s_scm_string_for_each_index
2791 size_t cstart
, cend
;
2793 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2794 proc
, SCM_ARG1
, FUNC_NAME
);
2795 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2799 while (cstart
< cend
)
2801 scm_call_1 (proc
, scm_from_size_t (cstart
));
2805 scm_remember_upto_here_1 (s
);
2806 return SCM_UNSPECIFIED
;
2810 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2811 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2812 "This is the @emph{extended substring} procedure that implements\n"
2813 "replicated copying of a substring of some string.\n"
2815 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2816 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2817 "0 and the length of @var{s}. Replicate this substring up and\n"
2818 "down index space, in both the positive and negative directions.\n"
2819 "@code{xsubstring} returns the substring of this string\n"
2820 "beginning at index @var{from}, and ending at @var{to}, which\n"
2821 "defaults to @var{from} + (@var{end} - @var{start}).")
2822 #define FUNC_NAME s_scm_xsubstring
2825 size_t cstart
, cend
;
2829 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2833 cfrom
= scm_to_int (from
);
2834 if (SCM_UNBNDP (to
))
2835 cto
= cfrom
+ (cend
- cstart
);
2837 cto
= scm_to_int (to
);
2838 if (cstart
== cend
&& cfrom
!= cto
)
2839 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2841 result
= scm_i_make_string (cto
- cfrom
, NULL
, 0);
2842 result
= scm_i_string_start_writing (result
);
2847 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2849 scm_i_string_set_x (result
, p
,
2850 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2852 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2856 scm_i_string_stop_writing ();
2858 scm_remember_upto_here_1 (s
);
2864 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2865 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2866 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2867 "is written into the string @var{target} starting at index\n"
2868 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2869 "@var{target} @var{s})} or these arguments share storage -- you\n"
2870 "cannot copy a string on top of itself.")
2871 #define FUNC_NAME s_scm_string_xcopy_x
2874 size_t ctstart
, cstart
, cend
;
2876 SCM dummy
= SCM_UNDEFINED
;
2879 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2882 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2885 csfrom
= scm_to_int (sfrom
);
2886 if (SCM_UNBNDP (sto
))
2887 csto
= csfrom
+ (cend
- cstart
);
2889 csto
= scm_to_int (sto
);
2893 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2894 SCM_ASSERT_RANGE (1, tstart
,
2895 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2898 target
= scm_i_string_start_writing (target
);
2899 while (csfrom
< csto
)
2901 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2903 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2905 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2909 scm_i_string_stop_writing ();
2911 scm_remember_upto_here_2 (target
, s
);
2913 return SCM_UNSPECIFIED
;
2918 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2919 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2920 "Return the string @var{s1}, but with the characters\n"
2921 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2922 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2923 #define FUNC_NAME s_scm_string_replace
2925 size_t cstart1
, cend1
, cstart2
, cend2
;
2928 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2931 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2934 return (scm_string_append
2935 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2936 scm_i_substring (s2
, cstart2
, cend2
),
2937 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2943 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2944 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2945 "Split the string @var{s} into a list of substrings, where each\n"
2946 "substring is a maximal non-empty contiguous sequence of\n"
2947 "characters from the character set @var{token_set}, which\n"
2948 "defaults to @code{char-set:graphic}.\n"
2949 "If @var{start} or @var{end} indices are provided, they restrict\n"
2950 "@code{string-tokenize} to operating on the indicated substring\n"
2952 #define FUNC_NAME s_scm_string_tokenize
2954 size_t cstart
, cend
;
2955 SCM result
= SCM_EOL
;
2957 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2961 if (SCM_UNBNDP (token_set
))
2962 token_set
= scm_char_set_graphic
;
2964 if (SCM_CHARSETP (token_set
))
2968 while (cstart
< cend
)
2970 while (cstart
< cend
)
2972 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2979 while (cstart
< cend
)
2981 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2985 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2989 SCM_WRONG_TYPE_ARG (2, token_set
);
2991 scm_remember_upto_here_1 (s
);
2996 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2997 (SCM str
, SCM char_pred
),
2998 "Split the string @var{str} into a list of the substrings delimited\n"
2999 "by appearances of characters that\n"
3001 "@itemize @bullet\n"
3003 "equal @var{char_pred}, if it is a character,\n"
3006 "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
3009 "are in the set @var{char_pred}, if it is a character set.\n"
3011 "Note that an empty substring between separator characters\n"
3012 "will result in an empty string in the result list.\n"
3015 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3017 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3019 "(string-split \"::\" #\\:)\n"
3021 "(\"\" \"\" \"\")\n"
3023 "(string-split \"\" #\\:)\n"
3027 #define FUNC_NAME s_scm_string_split
3031 SCM_VALIDATE_STRING (1, str
);
3033 if (SCM_CHARP (char_pred
))
3038 /* This is explicit wide/narrow logic (instead of using
3039 scm_i_string_ref) is a speed optimization. */
3040 idx
= scm_i_string_length (str
);
3041 narrow
= scm_i_is_narrow_string (str
);
3044 const char *buf
= scm_i_string_chars (str
);
3048 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(char_pred
))
3052 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3059 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3063 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(char_pred
))
3067 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3075 SCM sidx
, slast_idx
;
3077 if (!SCM_CHARSETP (char_pred
))
3078 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3079 char_pred
, SCM_ARG2
, FUNC_NAME
);
3081 /* Supporting predicates and character sets involves handling SCM
3082 values so there is less chance to optimize. */
3083 slast_idx
= scm_string_length (str
);
3086 sidx
= scm_string_index_right (str
, char_pred
, SCM_INUM0
, slast_idx
);
3087 if (scm_is_false (sidx
))
3089 res
= scm_cons (scm_substring (str
, scm_oneplus (sidx
), slast_idx
), res
);
3093 res
= scm_cons (scm_substring (str
, SCM_INUM0
, slast_idx
), res
);
3096 scm_remember_upto_here_1 (str
);
3102 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3103 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3104 "Filter the string @var{s}, retaining only those characters\n"
3105 "which satisfy @var{char_pred}.\n"
3107 "If @var{char_pred} is a procedure, it is applied to each\n"
3108 "character as a predicate, if it is a character, it is tested\n"
3109 "for equality and if it is a character set, it is tested for\n"
3111 #define FUNC_NAME s_scm_string_filter
3113 size_t cstart
, cend
;
3117 #if SCM_ENABLE_DEPRECATED == 1
3118 if (scm_is_string (char_pred
))
3122 scm_c_issue_deprecation_warning
3123 ("Guile used to use the wrong argument order for string-filter.\n"
3124 "This call to string-filter had the arguments in the wrong order.\n"
3125 "See SRFI-13 for more details. At some point we will remove this hack.");
3133 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3137 /* The explicit loops below stripping leading and trailing non-matches
3138 mean we can return a substring if those are the only deletions, making
3139 string-filter as efficient as string-trim-both in that case. */
3141 if (SCM_CHARP (char_pred
))
3145 /* strip leading non-matches by incrementing cstart */
3146 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3149 /* strip trailing non-matches by decrementing cend */
3150 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3153 /* count chars to keep */
3155 for (idx
= cstart
; idx
< cend
; idx
++)
3156 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3159 if (count
== cend
- cstart
)
3161 /* whole of cstart to cend is to be kept, return a copy-on-write
3164 result
= scm_i_substring (s
, cstart
, cend
);
3167 result
= scm_c_make_string (count
, char_pred
);
3169 else if (SCM_CHARSETP (char_pred
))
3173 /* strip leading non-matches by incrementing cstart */
3174 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3177 /* strip trailing non-matches by decrementing cend */
3178 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3181 /* count chars to be kept */
3183 for (idx
= cstart
; idx
< cend
; idx
++)
3184 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3187 /* if whole of start to end kept then return substring */
3188 if (count
== cend
- cstart
)
3189 goto result_substring
;
3193 result
= scm_i_make_string (count
, NULL
, 0);
3194 result
= scm_i_string_start_writing (result
);
3196 /* decrement "count" in this loop as well as using idx, so that if
3197 another thread is simultaneously changing "s" there's no chance
3198 it'll make us copy more than count characters */
3199 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3201 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3203 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3208 scm_i_string_stop_writing ();
3215 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3216 char_pred
, SCM_ARG1
, FUNC_NAME
);
3221 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3222 res
= scm_call_1 (char_pred
, ch
);
3223 if (scm_is_true (res
))
3224 ls
= scm_cons (ch
, ls
);
3227 result
= scm_reverse_list_to_string (ls
);
3230 scm_remember_upto_here_1 (s
);
3236 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3237 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3238 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3240 "If @var{char_pred} is a procedure, it is applied to each\n"
3241 "character as a predicate, if it is a character, it is tested\n"
3242 "for equality and if it is a character set, it is tested for\n"
3244 #define FUNC_NAME s_scm_string_delete
3246 size_t cstart
, cend
;
3250 #if SCM_ENABLE_DEPRECATED == 1
3251 if (scm_is_string (char_pred
))
3255 scm_c_issue_deprecation_warning
3256 ("Guile used to use the wrong argument order for string-delete.\n"
3257 "This call to string-filter had the arguments in the wrong order.\n"
3258 "See SRFI-13 for more details. At some point we will remove this hack.");
3266 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3270 /* The explicit loops below stripping leading and trailing matches mean we
3271 can return a substring if those are the only deletions, making
3272 string-delete as efficient as string-trim-both in that case. */
3274 if (SCM_CHARP (char_pred
))
3278 /* strip leading matches by incrementing cstart */
3279 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3282 /* strip trailing matches by decrementing cend */
3283 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3286 /* count chars to be kept */
3288 for (idx
= cstart
; idx
< cend
; idx
++)
3289 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3292 if (count
== cend
- cstart
)
3294 /* whole of cstart to cend is to be kept, return a copy-on-write
3297 result
= scm_i_substring (s
, cstart
, cend
);
3302 /* new string for retained portion */
3303 result
= scm_i_make_string (count
, NULL
, 0);
3304 result
= scm_i_string_start_writing (result
);
3305 /* decrement "count" in this loop as well as using idx, so that if
3306 another thread is simultaneously changing "s" there's no chance
3307 it'll make us copy more than count characters */
3308 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3310 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3311 if (c
!= SCM_CHAR (char_pred
))
3313 scm_i_string_set_x (result
, i
, c
);
3318 scm_i_string_stop_writing ();
3321 else if (SCM_CHARSETP (char_pred
))
3325 /* strip leading matches by incrementing cstart */
3326 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3329 /* strip trailing matches by decrementing cend */
3330 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3333 /* count chars to be kept */
3335 for (idx
= cstart
; idx
< cend
; idx
++)
3336 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3339 if (count
== cend
- cstart
)
3340 goto result_substring
;
3344 /* new string for retained portion */
3345 result
= scm_i_make_string (count
, NULL
, 0);
3346 result
= scm_i_string_start_writing (result
);
3348 /* decrement "count" in this loop as well as using idx, so that if
3349 another thread is simultaneously changing "s" there's no chance
3350 it'll make us copy more than count characters */
3351 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3353 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3355 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3360 scm_i_string_stop_writing ();
3366 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3367 char_pred
, SCM_ARG1
, FUNC_NAME
);
3372 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3373 res
= scm_call_1 (char_pred
, ch
);
3374 if (scm_is_false (res
))
3375 ls
= scm_cons (ch
, ls
);
3378 result
= scm_reverse_list_to_string (ls
);
3381 scm_remember_upto_here_1 (s
);
3387 scm_init_srfi_13 (void)
3389 #include "libguile/srfi-13.x"
3392 /* End of srfi-13.c. */