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 for (i
= 0; i
< cend
- cstart
; i
++)
551 scm_i_string_set_x (target
, ctstart
+ i
,
552 scm_i_string_ref (s
, cstart
+ i
));
554 scm_i_string_stop_writing ();
555 scm_remember_upto_here_1 (target
);
558 return SCM_UNSPECIFIED
;
562 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
563 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
564 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
565 "into @var{str2} beginning at position @var{start2}.\n"
566 "@var{str1} and @var{str2} can be the same string.")
567 #define FUNC_NAME s_scm_substring_move_x
569 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
573 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
575 "Return the @var{n} first characters of @var{s}.")
576 #define FUNC_NAME s_scm_string_take
578 return scm_substring (s
, SCM_INUM0
, n
);
583 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
585 "Return all but the first @var{n} characters of @var{s}.")
586 #define FUNC_NAME s_scm_string_drop
588 return scm_substring (s
, n
, SCM_UNDEFINED
);
593 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
595 "Return the @var{n} last characters of @var{s}.")
596 #define FUNC_NAME s_scm_string_take_right
598 return scm_substring (s
,
599 scm_difference (scm_string_length (s
), n
),
605 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
607 "Return all but the last @var{n} characters of @var{s}.")
608 #define FUNC_NAME s_scm_string_drop_right
610 return scm_substring (s
,
612 scm_difference (scm_string_length (s
), n
));
617 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
618 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
619 "Take that characters from @var{start} to @var{end} from the\n"
620 "string @var{s} and return a new string, right-padded by the\n"
621 "character @var{chr} to length @var{len}. If the resulting\n"
622 "string is longer than @var{len}, it is truncated on the right.")
623 #define FUNC_NAME s_scm_string_pad
625 size_t cstart
, cend
, clen
;
627 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
630 clen
= scm_to_size_t (len
);
632 if (SCM_UNBNDP (chr
))
633 chr
= SCM_MAKE_CHAR (' ');
636 SCM_VALIDATE_CHAR (3, chr
);
638 if (clen
< (cend
- cstart
))
639 return scm_i_substring (s
, cend
- clen
, cend
);
643 result
= (scm_string_append
644 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
645 scm_i_substring (s
, cstart
, cend
))));
652 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
653 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
654 "Take that characters from @var{start} to @var{end} from the\n"
655 "string @var{s} and return a new string, left-padded by the\n"
656 "character @var{chr} to length @var{len}. If the resulting\n"
657 "string is longer than @var{len}, it is truncated on the left.")
658 #define FUNC_NAME s_scm_string_pad_right
660 size_t cstart
, cend
, clen
;
662 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
665 clen
= scm_to_size_t (len
);
667 if (SCM_UNBNDP (chr
))
668 chr
= SCM_MAKE_CHAR (' ');
671 SCM_VALIDATE_CHAR (3, chr
);
673 if (clen
< (cend
- cstart
))
674 return scm_i_substring (s
, cstart
, cstart
+ clen
);
679 result
= (scm_string_append
680 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
681 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
689 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
690 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
691 "Trim @var{s} by skipping over all characters on the left\n"
692 "that satisfy the parameter @var{char_pred}:\n"
696 "if it is the character @var{ch}, characters equal to\n"
697 "@var{ch} are trimmed,\n"
700 "if it is a procedure @var{pred} characters that\n"
701 "satisfy @var{pred} are trimmed,\n"
704 "if it is a character set, characters in that set are trimmed.\n"
707 "If called without a @var{char_pred} argument, all whitespace is\n"
709 #define FUNC_NAME s_scm_string_trim
713 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
716 if (SCM_UNBNDP (char_pred
)
717 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
719 while (cstart
< cend
)
721 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
726 else if (SCM_CHARP (char_pred
))
728 while (cstart
< cend
)
730 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
735 else if (SCM_CHARSETP (char_pred
))
737 while (cstart
< cend
)
739 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
746 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
747 char_pred
, SCM_ARG2
, FUNC_NAME
);
749 while (cstart
< cend
)
753 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
754 if (scm_is_false (res
))
759 return scm_i_substring (s
, cstart
, cend
);
764 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
765 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
766 "Trim @var{s} by skipping over all characters on the right\n"
767 "that satisfy the parameter @var{char_pred}:\n"
771 "if it is the character @var{ch}, characters equal to @var{ch}\n"
775 "if it is a procedure @var{pred} characters that satisfy\n"
776 "@var{pred} are trimmed,\n"
779 "if it is a character sets, all characters in that set are\n"
783 "If called without a @var{char_pred} argument, all whitespace is\n"
785 #define FUNC_NAME s_scm_string_trim_right
789 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
792 if (SCM_UNBNDP (char_pred
)
793 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
795 while (cstart
< cend
)
797 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
802 else if (SCM_CHARP (char_pred
))
804 while (cstart
< cend
)
806 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
811 else if (SCM_CHARSETP (char_pred
))
813 while (cstart
< cend
)
815 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
822 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
823 char_pred
, SCM_ARG2
, FUNC_NAME
);
825 while (cstart
< cend
)
829 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
830 if (scm_is_false (res
))
835 return scm_i_substring (s
, cstart
, cend
);
840 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
841 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
842 "Trim @var{s} by skipping over all characters on both sides of\n"
843 "the string that satisfy the parameter @var{char_pred}:\n"
847 "if it is the character @var{ch}, characters equal to @var{ch}\n"
851 "if it is a procedure @var{pred} characters that satisfy\n"
852 "@var{pred} are trimmed,\n"
855 "if it is a character set, the characters in the set are\n"
859 "If called without a @var{char_pred} argument, all whitespace is\n"
861 #define FUNC_NAME s_scm_string_trim_both
865 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
868 if (SCM_UNBNDP (char_pred
)
869 || scm_is_eq (char_pred
, scm_char_set_whitespace
))
871 while (cstart
< cend
)
873 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
877 while (cstart
< cend
)
879 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
884 else if (SCM_CHARP (char_pred
))
886 while (cstart
< cend
)
888 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
892 while (cstart
< cend
)
894 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
899 else if (SCM_CHARSETP (char_pred
))
901 while (cstart
< cend
)
903 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
907 while (cstart
< cend
)
909 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
916 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
917 char_pred
, SCM_ARG2
, FUNC_NAME
);
919 while (cstart
< cend
)
923 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
924 if (scm_is_false (res
))
928 while (cstart
< cend
)
932 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
933 if (scm_is_false (res
))
938 return scm_i_substring (s
, cstart
, cend
);
943 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
944 (SCM str
, SCM chr
, SCM start
, SCM end
),
945 "Stores @var{chr} in every element of the given @var{str} and\n"
946 "returns an unspecified value.")
947 #define FUNC_NAME s_scm_substring_fill_x
952 /* Older versions of Guile provided the function
953 scm_substring_fill_x with the following order of arguments:
957 We accomodate this here by detecting such a usage and reordering
968 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
971 SCM_VALIDATE_CHAR (2, chr
);
975 str
= scm_i_string_start_writing (str
);
976 for (k
= cstart
; k
< cend
; k
++)
977 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
978 scm_i_string_stop_writing ();
981 return SCM_UNSPECIFIED
;
986 scm_string_fill_x (SCM str
, SCM chr
)
988 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
991 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
992 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
993 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
994 "mismatch index, depending upon whether @var{s1} is less than,\n"
995 "equal to, or greater than @var{s2}. The mismatch index is the\n"
996 "largest index @var{i} such that for every 0 <= @var{j} <\n"
997 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
998 "@var{i} is the first position that does not match.")
999 #define FUNC_NAME s_scm_string_compare
1001 size_t cstart1
, cend1
, cstart2
, cend2
;
1004 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1007 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1010 SCM_VALIDATE_PROC (3, proc_lt
);
1011 SCM_VALIDATE_PROC (4, proc_eq
);
1012 SCM_VALIDATE_PROC (5, proc_gt
);
1014 while (cstart1
< cend1
&& cstart2
< cend2
)
1016 if (scm_i_string_ref (s1
, cstart1
)
1017 < scm_i_string_ref (s2
, cstart2
))
1022 else if (scm_i_string_ref (s1
, cstart1
)
1023 > scm_i_string_ref (s2
, cstart2
))
1031 if (cstart1
< cend1
)
1033 else if (cstart2
< cend2
)
1039 scm_remember_upto_here_2 (s1
, s2
);
1040 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1045 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1046 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1047 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1048 "mismatch index, depending upon whether @var{s1} is less than,\n"
1049 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1050 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1051 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1052 "@var{i} is the first position where the lowercased letters \n"
1054 #define FUNC_NAME s_scm_string_compare_ci
1056 size_t cstart1
, cend1
, cstart2
, cend2
;
1059 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1062 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1065 SCM_VALIDATE_PROC (3, proc_lt
);
1066 SCM_VALIDATE_PROC (4, proc_eq
);
1067 SCM_VALIDATE_PROC (5, proc_gt
);
1069 while (cstart1
< cend1
&& cstart2
< cend2
)
1071 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1072 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1077 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1078 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1087 if (cstart1
< cend1
)
1089 else if (cstart2
< cend2
)
1095 scm_remember_upto_here (s1
, s2
);
1096 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1100 /* This function compares two substrings, S1 from START1 to END1 and
1101 S2 from START2 to END2, possibly case insensitively, and returns
1102 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1103 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1104 longer, or equal. */
1106 compare_strings (const char *fname
, int case_insensitive
,
1107 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1108 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1110 size_t cstart1
, cend1
, cstart2
, cend2
;
1114 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1117 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1121 while (cstart1
< cend1
&& cstart2
< cend2
)
1123 if (case_insensitive
)
1125 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1126 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1130 a
= scm_i_string_ref (s1
, cstart1
);
1131 b
= scm_i_string_ref (s2
, cstart2
);
1146 if (cstart1
< cend1
)
1151 else if (cstart2
< cend2
)
1163 scm_remember_upto_here_2 (s1
, s2
);
1168 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1169 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1170 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1172 #define FUNC_NAME s_scm_string_eq
1174 if (SCM_LIKELY (scm_is_string (s1
) && scm_is_string (s2
) &&
1175 scm_i_is_narrow_string (s1
) == scm_i_is_narrow_string (s2
)
1176 && SCM_UNBNDP (start1
) && SCM_UNBNDP (end1
)
1177 && SCM_UNBNDP (start2
) && SCM_UNBNDP (end2
)))
1179 /* Fast path for this common case, which avoids the repeated calls to
1180 `scm_i_string_ref'. */
1183 len1
= scm_i_string_length (s1
);
1184 len2
= scm_i_string_length (s2
);
1190 if (!scm_i_is_narrow_string (s1
))
1193 return scm_from_bool (memcmp (scm_i_string_data (s1
),
1194 scm_i_string_data (s2
),
1199 return compare_strings (FUNC_NAME
, 0,
1200 s1
, s2
, start1
, end1
, start2
, end2
,
1201 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1206 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1207 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1208 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1210 #define FUNC_NAME s_scm_string_neq
1212 return compare_strings (FUNC_NAME
, 0,
1213 s1
, s2
, start1
, end1
, start2
, end2
,
1214 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1219 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1220 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1221 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1222 "true value otherwise.")
1223 #define FUNC_NAME s_scm_string_lt
1225 return compare_strings (FUNC_NAME
, 0,
1226 s1
, s2
, start1
, end1
, start2
, end2
,
1227 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1232 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1233 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1234 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1235 "true value otherwise.")
1236 #define FUNC_NAME s_scm_string_gt
1238 return compare_strings (FUNC_NAME
, 0,
1239 s1
, s2
, start1
, end1
, start2
, end2
,
1240 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1245 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1246 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1247 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1249 #define FUNC_NAME s_scm_string_le
1251 return compare_strings (FUNC_NAME
, 0,
1252 s1
, s2
, start1
, end1
, start2
, end2
,
1253 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1258 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1259 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1260 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1262 #define FUNC_NAME s_scm_string_ge
1264 return compare_strings (FUNC_NAME
, 0,
1265 s1
, s2
, start1
, end1
, start2
, end2
,
1266 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1271 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1272 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1273 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1274 "value otherwise. The character comparison is done\n"
1275 "case-insensitively.")
1276 #define FUNC_NAME s_scm_string_ci_eq
1278 return compare_strings (FUNC_NAME
, 1,
1279 s1
, s2
, start1
, end1
, start2
, end2
,
1280 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1285 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1286 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1287 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1288 "value otherwise. The character comparison is done\n"
1289 "case-insensitively.")
1290 #define FUNC_NAME s_scm_string_ci_neq
1292 return compare_strings (FUNC_NAME
, 1,
1293 s1
, s2
, start1
, end1
, start2
, end2
,
1294 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1299 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1300 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1301 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1302 "true value otherwise. The character comparison is done\n"
1303 "case-insensitively.")
1304 #define FUNC_NAME s_scm_string_ci_lt
1306 return compare_strings (FUNC_NAME
, 1,
1307 s1
, s2
, start1
, end1
, start2
, end2
,
1308 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1313 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1314 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1315 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1316 "true value otherwise. The character comparison is done\n"
1317 "case-insensitively.")
1318 #define FUNC_NAME s_scm_string_ci_gt
1320 return compare_strings (FUNC_NAME
, 1,
1321 s1
, s2
, start1
, end1
, start2
, end2
,
1322 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1327 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1328 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1329 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1330 "value otherwise. The character comparison is done\n"
1331 "case-insensitively.")
1332 #define FUNC_NAME s_scm_string_ci_le
1334 return compare_strings (FUNC_NAME
, 1,
1335 s1
, s2
, start1
, end1
, start2
, end2
,
1336 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1341 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1342 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1343 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1344 "otherwise. The character comparison is done\n"
1345 "case-insensitively.")
1346 #define FUNC_NAME s_scm_string_ci_ge
1348 return compare_strings (FUNC_NAME
, 1,
1349 s1
, s2
, start1
, end1
, start2
, end2
,
1350 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1354 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1355 (SCM s
, SCM bound
, SCM start
, SCM end
),
1356 "Compute a hash value for @var{s}. the optional argument "
1357 "@var{bound} is a non-negative exact "
1358 "integer specifying the range of the hash function. "
1359 "A positive value restricts the return value to the "
1361 #define FUNC_NAME s_scm_substring_hash
1363 if (SCM_UNBNDP (bound
))
1364 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1365 if (SCM_UNBNDP (start
))
1367 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1371 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1372 (SCM s
, SCM bound
, SCM start
, SCM end
),
1373 "Compute a hash value for @var{s}. the optional argument "
1374 "@var{bound} is a non-negative exact "
1375 "integer specifying the range of the hash function. "
1376 "A positive value restricts the return value to the "
1378 #define FUNC_NAME s_scm_substring_hash_ci
1380 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1382 SCM_UNDEFINED
, SCM_UNDEFINED
);
1386 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1387 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1388 "Return the length of the longest common prefix of the two\n"
1390 #define FUNC_NAME s_scm_string_prefix_length
1392 size_t cstart1
, cend1
, cstart2
, cend2
;
1395 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1398 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1402 while (cstart1
< cend1
&& cstart2
< cend2
)
1404 if (scm_i_string_ref (s1
, cstart1
)
1405 != scm_i_string_ref (s2
, cstart2
))
1413 scm_remember_upto_here_2 (s1
, s2
);
1414 return scm_from_size_t (len
);
1419 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1420 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1421 "Return the length of the longest common prefix of the two\n"
1422 "strings, ignoring character case.")
1423 #define FUNC_NAME s_scm_string_prefix_length_ci
1425 size_t cstart1
, cend1
, cstart2
, cend2
;
1428 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1431 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1434 while (cstart1
< cend1
&& cstart2
< cend2
)
1436 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1437 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1445 scm_remember_upto_here_2 (s1
, s2
);
1446 return scm_from_size_t (len
);
1451 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1452 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1453 "Return the length of the longest common suffix of the two\n"
1455 #define FUNC_NAME s_scm_string_suffix_length
1457 size_t cstart1
, cend1
, cstart2
, cend2
;
1460 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1463 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1466 while (cstart1
< cend1
&& cstart2
< cend2
)
1470 if (scm_i_string_ref (s1
, cend1
)
1471 != scm_i_string_ref (s2
, cend2
))
1477 scm_remember_upto_here_2 (s1
, s2
);
1478 return scm_from_size_t (len
);
1483 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1484 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1485 "Return the length of the longest common suffix of the two\n"
1486 "strings, ignoring character case.")
1487 #define FUNC_NAME s_scm_string_suffix_length_ci
1489 size_t cstart1
, cend1
, cstart2
, cend2
;
1492 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1495 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1498 while (cstart1
< cend1
&& cstart2
< cend2
)
1502 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1503 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1509 scm_remember_upto_here_2 (s1
, s2
);
1510 return scm_from_size_t (len
);
1515 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1516 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1517 "Is @var{s1} a prefix of @var{s2}?")
1518 #define FUNC_NAME s_scm_string_prefix_p
1520 size_t cstart1
, cend1
, cstart2
, cend2
;
1521 size_t len
= 0, len1
;
1523 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1526 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1529 len1
= cend1
- cstart1
;
1530 while (cstart1
< cend1
&& cstart2
< cend2
)
1532 if (scm_i_string_ref (s1
, cstart1
)
1533 != scm_i_string_ref (s2
, cstart2
))
1541 scm_remember_upto_here_2 (s1
, s2
);
1542 return scm_from_bool (len
== len1
);
1547 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1548 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1549 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1550 #define FUNC_NAME s_scm_string_prefix_ci_p
1552 size_t cstart1
, cend1
, cstart2
, cend2
;
1553 size_t len
= 0, len1
;
1555 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1558 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1561 len1
= cend1
- cstart1
;
1562 while (cstart1
< cend1
&& cstart2
< cend2
)
1564 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1565 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1574 scm_remember_upto_here_2 (s1
, s2
);
1575 return scm_from_bool (len
== len1
);
1580 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1581 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1582 "Is @var{s1} a suffix of @var{s2}?")
1583 #define FUNC_NAME s_scm_string_suffix_p
1585 size_t cstart1
, cend1
, cstart2
, cend2
;
1586 size_t len
= 0, len1
;
1588 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1591 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1594 len1
= cend1
- cstart1
;
1595 while (cstart1
< cend1
&& cstart2
< cend2
)
1599 if (scm_i_string_ref (s1
, cend1
)
1600 != scm_i_string_ref (s2
, cend2
))
1606 scm_remember_upto_here_2 (s1
, s2
);
1607 return scm_from_bool (len
== len1
);
1612 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1613 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1614 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1615 #define FUNC_NAME s_scm_string_suffix_ci_p
1617 size_t cstart1
, cend1
, cstart2
, cend2
;
1618 size_t len
= 0, len1
;
1620 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1623 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1626 len1
= cend1
- cstart1
;
1627 while (cstart1
< cend1
&& cstart2
< cend2
)
1631 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1632 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1638 scm_remember_upto_here_2 (s1
, s2
);
1639 return scm_from_bool (len
== len1
);
1644 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1645 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1646 "Search through the string @var{s} from left to right, returning\n"
1647 "the index of the first occurrence of a character which\n"
1649 "@itemize @bullet\n"
1651 "equals @var{char_pred}, if it is character,\n"
1654 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1657 "is in the set @var{char_pred}, if it is a character set.\n"
1659 "Return @code{#f} if no match is found.")
1660 #define FUNC_NAME s_scm_string_index
1662 size_t cstart
, cend
;
1664 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1667 if (SCM_CHARP (char_pred
))
1669 while (cstart
< cend
)
1671 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1676 else if (SCM_CHARSETP (char_pred
))
1678 while (cstart
< cend
)
1680 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1687 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1688 char_pred
, SCM_ARG2
, FUNC_NAME
);
1690 while (cstart
< cend
)
1693 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1694 if (scm_is_true (res
))
1700 scm_remember_upto_here_1 (s
);
1704 scm_remember_upto_here_1 (s
);
1705 return scm_from_size_t (cstart
);
1709 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1710 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1711 "Search through the string @var{s} from right to left, returning\n"
1712 "the index of the last occurrence of a character which\n"
1714 "@itemize @bullet\n"
1716 "equals @var{char_pred}, if it is character,\n"
1719 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1722 "is in the set if @var{char_pred} is a character set.\n"
1724 "Return @code{#f} if no match is found.")
1725 #define FUNC_NAME s_scm_string_index_right
1727 size_t cstart
, cend
;
1729 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1732 if (SCM_CHARP (char_pred
))
1734 while (cstart
< cend
)
1737 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1741 else if (SCM_CHARSETP (char_pred
))
1743 while (cstart
< cend
)
1746 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1752 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1753 char_pred
, SCM_ARG2
, FUNC_NAME
);
1755 while (cstart
< cend
)
1759 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1760 if (scm_is_true (res
))
1765 scm_remember_upto_here_1 (s
);
1769 scm_remember_upto_here_1 (s
);
1770 return scm_from_size_t (cend
);
1774 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1775 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1776 "Search through the string @var{s} from right to left, returning\n"
1777 "the index of the last occurrence of a character which\n"
1779 "@itemize @bullet\n"
1781 "equals @var{char_pred}, if it is character,\n"
1784 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
1787 "is in the set if @var{char_pred} is a character set.\n"
1789 "Return @code{#f} if no match is found.")
1790 #define FUNC_NAME s_scm_string_rindex
1792 return scm_string_index_right (s
, char_pred
, start
, end
);
1796 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1797 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1798 "Search through the string @var{s} from left to right, returning\n"
1799 "the index of the first occurrence of a character which\n"
1801 "@itemize @bullet\n"
1803 "does not equal @var{char_pred}, if it is character,\n"
1806 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1810 "is not in the set if @var{char_pred} is a character set.\n"
1812 #define FUNC_NAME s_scm_string_skip
1814 size_t cstart
, cend
;
1816 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1819 if (SCM_CHARP (char_pred
))
1821 while (cstart
< cend
)
1823 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1828 else if (SCM_CHARSETP (char_pred
))
1830 while (cstart
< cend
)
1832 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1839 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1840 char_pred
, SCM_ARG2
, FUNC_NAME
);
1842 while (cstart
< cend
)
1845 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1846 if (scm_is_false (res
))
1852 scm_remember_upto_here_1 (s
);
1856 scm_remember_upto_here_1 (s
);
1857 return scm_from_size_t (cstart
);
1862 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1863 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1864 "Search through the string @var{s} from right to left, returning\n"
1865 "the index of the last occurrence of a character which\n"
1867 "@itemize @bullet\n"
1869 "does not equal @var{char_pred}, if it is character,\n"
1872 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1876 "is not in the set if @var{char_pred} is a character set.\n"
1878 #define FUNC_NAME s_scm_string_skip_right
1880 size_t cstart
, cend
;
1882 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1885 if (SCM_CHARP (char_pred
))
1887 while (cstart
< cend
)
1890 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1894 else if (SCM_CHARSETP (char_pred
))
1896 while (cstart
< cend
)
1899 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1905 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1906 char_pred
, SCM_ARG2
, FUNC_NAME
);
1908 while (cstart
< cend
)
1912 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1913 if (scm_is_false (res
))
1918 scm_remember_upto_here_1 (s
);
1922 scm_remember_upto_here_1 (s
);
1923 return scm_from_size_t (cend
);
1929 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1930 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1931 "Return the count of the number of characters in the string\n"
1934 "@itemize @bullet\n"
1936 "equals @var{char_pred}, if it is character,\n"
1939 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
1942 "is in the set @var{char_pred}, if it is a character set.\n"
1944 #define FUNC_NAME s_scm_string_count
1946 size_t cstart
, cend
;
1949 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1952 if (SCM_CHARP (char_pred
))
1954 while (cstart
< cend
)
1956 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1961 else if (SCM_CHARSETP (char_pred
))
1963 while (cstart
< cend
)
1965 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1972 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1973 char_pred
, SCM_ARG2
, FUNC_NAME
);
1975 while (cstart
< cend
)
1978 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1979 if (scm_is_true (res
))
1985 scm_remember_upto_here_1 (s
);
1986 return scm_from_size_t (count
);
1991 /* FIXME::martin: This should definitely get implemented more
1992 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1994 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1995 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1996 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1997 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1998 "The optional start/end indices restrict the operation to the\n"
1999 "indicated substrings.")
2000 #define FUNC_NAME s_scm_string_contains
2002 size_t cstart1
, cend1
, cstart2
, cend2
;
2005 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2008 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2011 len2
= cend2
- cstart2
;
2012 if (cend1
- cstart1
>= len2
)
2013 while (cstart1
<= cend1
- len2
)
2019 && (scm_i_string_ref (s1
, i
)
2020 == scm_i_string_ref (s2
, j
)))
2027 scm_remember_upto_here_2 (s1
, s2
);
2028 return scm_from_size_t (cstart1
);
2033 scm_remember_upto_here_2 (s1
, s2
);
2039 /* FIXME::martin: This should definitely get implemented more
2040 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2042 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2043 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2044 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2045 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2046 "The optional start/end indices restrict the operation to the\n"
2047 "indicated substrings. Character comparison is done\n"
2048 "case-insensitively.")
2049 #define FUNC_NAME s_scm_string_contains_ci
2051 size_t cstart1
, cend1
, cstart2
, cend2
;
2054 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2057 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2060 len2
= cend2
- cstart2
;
2061 if (cend1
- cstart1
>= len2
)
2062 while (cstart1
<= cend1
- len2
)
2068 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2069 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2076 scm_remember_upto_here_2 (s1
, s2
);
2077 return scm_from_size_t (cstart1
);
2082 scm_remember_upto_here_2 (s1
, s2
);
2088 /* Helper function for the string uppercase conversion functions. */
2090 string_upcase_x (SCM v
, size_t start
, size_t end
)
2096 v
= scm_i_string_start_writing (v
);
2097 for (k
= start
; k
< end
; ++k
)
2098 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2099 scm_i_string_stop_writing ();
2100 scm_remember_upto_here_1 (v
);
2106 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2107 (SCM str
, SCM start
, SCM end
),
2108 "Destructively upcase every character in @code{str}.\n"
2111 "(string-upcase! y)\n"
2112 "@result{} \"ARRDEFG\"\n"
2114 "@result{} \"ARRDEFG\"\n"
2116 #define FUNC_NAME s_scm_substring_upcase_x
2118 size_t cstart
, cend
;
2120 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2123 return string_upcase_x (str
, cstart
, cend
);
2128 scm_string_upcase_x (SCM str
)
2130 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2133 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2134 (SCM str
, SCM start
, SCM end
),
2135 "Upcase every character in @code{str}.")
2136 #define FUNC_NAME s_scm_substring_upcase
2138 size_t cstart
, cend
;
2140 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2143 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2148 scm_string_upcase (SCM str
)
2150 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2153 /* Helper function for the string lowercase conversion functions.
2154 * No argument checking is performed. */
2156 string_downcase_x (SCM v
, size_t start
, size_t end
)
2162 v
= scm_i_string_start_writing (v
);
2163 for (k
= start
; k
< end
; ++k
)
2164 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2165 scm_i_string_stop_writing ();
2166 scm_remember_upto_here_1 (v
);
2172 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2173 (SCM str
, SCM start
, SCM end
),
2174 "Destructively downcase every character in @var{str}.\n"
2178 "@result{} \"ARRDEFG\"\n"
2179 "(string-downcase! y)\n"
2180 "@result{} \"arrdefg\"\n"
2182 "@result{} \"arrdefg\"\n"
2184 #define FUNC_NAME s_scm_substring_downcase_x
2186 size_t cstart
, cend
;
2188 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2191 return string_downcase_x (str
, cstart
, cend
);
2196 scm_string_downcase_x (SCM str
)
2198 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2201 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2202 (SCM str
, SCM start
, SCM end
),
2203 "Downcase every character in @var{str}.")
2204 #define FUNC_NAME s_scm_substring_downcase
2206 size_t cstart
, cend
;
2208 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2211 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2216 scm_string_downcase (SCM str
)
2218 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2221 /* Helper function for the string capitalization functions.
2222 * No argument checking is performed. */
2224 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2232 str
= scm_i_string_start_writing (str
);
2233 for(i
= start
; i
< end
; i
++)
2235 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2236 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2240 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2245 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2251 scm_i_string_stop_writing ();
2252 scm_remember_upto_here_1 (str
);
2259 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2260 (SCM str
, SCM start
, SCM end
),
2261 "Destructively titlecase every first character in a word in\n"
2263 #define FUNC_NAME s_scm_string_titlecase_x
2265 size_t cstart
, cend
;
2267 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2270 return string_titlecase_x (str
, cstart
, cend
);
2275 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2276 (SCM str
, SCM start
, SCM end
),
2277 "Titlecase every first character in a word in @var{str}.")
2278 #define FUNC_NAME s_scm_string_titlecase
2280 size_t cstart
, cend
;
2282 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2285 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2289 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2291 "Upcase the first character of every word in @var{str}\n"
2292 "destructively and return @var{str}.\n"
2295 "y @result{} \"hello world\"\n"
2296 "(string-capitalize! y) @result{} \"Hello World\"\n"
2297 "y @result{} \"Hello World\"\n"
2299 #define FUNC_NAME s_scm_string_capitalize_x
2301 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2306 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2308 "Return a freshly allocated string with the characters in\n"
2309 "@var{str}, where the first character of every word is\n"
2311 #define FUNC_NAME s_scm_string_capitalize
2313 return scm_string_capitalize_x (scm_string_copy (str
));
2318 /* Reverse the portion of @var{str} between str[cstart] (including)
2319 and str[cend] excluding. */
2321 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2325 str
= scm_i_string_start_writing (str
);
2331 while (cstart
< cend
)
2333 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2334 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2335 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2340 scm_i_string_stop_writing ();
2345 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2346 (SCM str
, SCM start
, SCM end
),
2347 "Reverse the string @var{str}. The optional arguments\n"
2348 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2350 #define FUNC_NAME s_scm_string_reverse
2352 size_t cstart
, cend
;
2355 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2358 result
= scm_string_copy (str
);
2359 string_reverse_x (result
, cstart
, cend
);
2360 scm_remember_upto_here_1 (str
);
2366 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2367 (SCM str
, SCM start
, SCM end
),
2368 "Reverse the string @var{str} in-place. The optional arguments\n"
2369 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2370 "operate on. The return value is unspecified.")
2371 #define FUNC_NAME s_scm_string_reverse_x
2373 size_t cstart
, cend
;
2375 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2379 string_reverse_x (str
, cstart
, cend
);
2380 scm_remember_upto_here_1 (str
);
2381 return SCM_UNSPECIFIED
;
2386 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2388 "Like @code{string-append}, but the result may share memory\n"
2389 "with the argument strings.")
2390 #define FUNC_NAME s_scm_string_append_shared
2392 /* If "rest" contains just one non-empty string, return that.
2393 If it's entirely empty strings, then return scm_nullstr.
2394 Otherwise use scm_string_concatenate. */
2396 SCM ret
= scm_nullstr
;
2397 int seen_nonempty
= 0;
2400 SCM_VALIDATE_REST_ARGUMENT (rest
);
2402 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2405 if (!scm_is_string (s
))
2406 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2407 if (scm_i_string_length (s
) != 0)
2410 /* two or more non-empty strings, need full concat */
2411 return scm_string_append (rest
);
2422 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2424 "Append the elements of @var{ls} (which must be strings)\n"
2425 "together into a single string. Guaranteed to return a freshly\n"
2426 "allocated string.")
2427 #define FUNC_NAME s_scm_string_concatenate
2429 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2430 return scm_string_append (ls
);
2435 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2436 (SCM ls
, SCM final_string
, SCM end
),
2437 "Without optional arguments, this procedure is equivalent to\n"
2440 "(string-concatenate (reverse ls))\n"
2443 "If the optional argument @var{final_string} is specified, it is\n"
2444 "consed onto the beginning to @var{ls} before performing the\n"
2445 "list-reverse and string-concatenate operations. If @var{end}\n"
2446 "is given, only the characters of @var{final_string} up to index\n"
2447 "@var{end} are used.\n"
2449 "Guaranteed to return a freshly allocated string.")
2450 #define FUNC_NAME s_scm_string_concatenate_reverse
2452 if (!SCM_UNBNDP (end
))
2453 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2455 if (!SCM_UNBNDP (final_string
))
2456 ls
= scm_cons (final_string
, ls
);
2458 return scm_string_concatenate (scm_reverse (ls
));
2463 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2465 "Like @code{string-concatenate}, but the result may share memory\n"
2466 "with the strings in the list @var{ls}.")
2467 #define FUNC_NAME s_scm_string_concatenate_shared
2469 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2470 return scm_string_append_shared (ls
);
2475 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2476 (SCM ls
, SCM final_string
, SCM end
),
2477 "Like @code{string-concatenate-reverse}, but the result may\n"
2478 "share memory with the strings in the @var{ls} arguments.")
2479 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2481 /* Just call the non-sharing version. */
2482 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2487 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2488 (SCM proc
, SCM s
, SCM start
, SCM end
),
2489 "@var{proc} is a char->char procedure, it is mapped over\n"
2490 "@var{s}. The order in which the procedure is applied to the\n"
2491 "string elements is not specified.")
2492 #define FUNC_NAME s_scm_string_map
2495 size_t cstart
, cend
;
2498 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2499 proc
, SCM_ARG1
, FUNC_NAME
);
2500 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2503 result
= scm_i_make_string (cend
- cstart
, NULL
, 0);
2505 while (cstart
< cend
)
2507 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2508 if (!SCM_CHARP (ch
))
2509 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2511 result
= scm_i_string_start_writing (result
);
2512 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2513 scm_i_string_stop_writing ();
2522 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2523 (SCM proc
, SCM s
, SCM start
, SCM end
),
2524 "@var{proc} is a char->char procedure, it is mapped over\n"
2525 "@var{s}. The order in which the procedure is applied to the\n"
2526 "string elements is not specified. The string @var{s} is\n"
2527 "modified in-place, the return value is not specified.")
2528 #define FUNC_NAME s_scm_string_map_x
2530 size_t cstart
, cend
;
2532 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2533 proc
, SCM_ARG1
, FUNC_NAME
);
2534 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2537 while (cstart
< cend
)
2539 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2540 if (!SCM_CHARP (ch
))
2541 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2542 s
= scm_i_string_start_writing (s
);
2543 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2544 scm_i_string_stop_writing ();
2547 return SCM_UNSPECIFIED
;
2552 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2553 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2554 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2555 "as the terminating element, from left to right. @var{kons}\n"
2556 "must expect two arguments: The actual character and the last\n"
2557 "result of @var{kons}' application.")
2558 #define FUNC_NAME s_scm_string_fold
2560 size_t cstart
, cend
;
2563 SCM_VALIDATE_PROC (1, kons
);
2564 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2568 while (cstart
< cend
)
2570 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2574 scm_remember_upto_here_1 (s
);
2580 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2581 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2582 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2583 "as the terminating element, from right to left. @var{kons}\n"
2584 "must expect two arguments: The actual character and the last\n"
2585 "result of @var{kons}' application.")
2586 #define FUNC_NAME s_scm_string_fold_right
2588 size_t cstart
, cend
;
2591 SCM_VALIDATE_PROC (1, kons
);
2592 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2596 while (cstart
< cend
)
2598 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2602 scm_remember_upto_here_1 (s
);
2608 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2609 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2610 "@itemize @bullet\n"
2611 "@item @var{g} is used to generate a series of @emph{seed}\n"
2612 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2613 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2615 "@item @var{p} tells us when to stop -- when it returns true\n"
2616 "when applied to one of these seed values.\n"
2617 "@item @var{f} maps each seed value to the corresponding\n"
2618 "character in the result string. These chars are assembled\n"
2619 "into the string in a left-to-right order.\n"
2620 "@item @var{base} is the optional initial/leftmost portion\n"
2621 "of the constructed string; it default to the empty\n"
2623 "@item @var{make_final} is applied to the terminal seed\n"
2624 "value (on which @var{p} returns true) to produce\n"
2625 "the final/rightmost portion of the constructed string.\n"
2626 "It defaults to @code{(lambda (x) "")}.\n"
2628 #define FUNC_NAME s_scm_string_unfold
2632 SCM_VALIDATE_PROC (1, p
);
2633 SCM_VALIDATE_PROC (2, f
);
2634 SCM_VALIDATE_PROC (3, g
);
2635 if (!SCM_UNBNDP (base
))
2637 SCM_VALIDATE_STRING (5, base
);
2641 ans
= scm_i_make_string (0, NULL
, 0);
2642 if (!SCM_UNBNDP (make_final
))
2643 SCM_VALIDATE_PROC (6, make_final
);
2645 res
= scm_call_1 (p
, seed
);
2646 while (scm_is_false (res
))
2650 SCM ch
= scm_call_1 (f
, seed
);
2651 if (!SCM_CHARP (ch
))
2652 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2653 str
= scm_i_make_string (1, NULL
, 0);
2654 str
= scm_i_string_start_writing (str
);
2655 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2656 scm_i_string_stop_writing ();
2659 ans
= scm_string_append (scm_list_2 (ans
, str
));
2660 seed
= scm_call_1 (g
, seed
);
2661 res
= scm_call_1 (p
, seed
);
2663 if (!SCM_UNBNDP (make_final
))
2665 res
= scm_call_1 (make_final
, seed
);
2666 return scm_string_append (scm_list_2 (ans
, res
));
2674 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2675 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2676 "@itemize @bullet\n"
2677 "@item @var{g} is used to generate a series of @emph{seed}\n"
2678 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2679 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2681 "@item @var{p} tells us when to stop -- when it returns true\n"
2682 "when applied to one of these seed values.\n"
2683 "@item @var{f} maps each seed value to the corresponding\n"
2684 "character in the result string. These chars are assembled\n"
2685 "into the string in a right-to-left order.\n"
2686 "@item @var{base} is the optional initial/rightmost portion\n"
2687 "of the constructed string; it default to the empty\n"
2689 "@item @var{make_final} is applied to the terminal seed\n"
2690 "value (on which @var{p} returns true) to produce\n"
2691 "the final/leftmost portion of the constructed string.\n"
2692 "It defaults to @code{(lambda (x) "")}.\n"
2694 #define FUNC_NAME s_scm_string_unfold_right
2698 SCM_VALIDATE_PROC (1, p
);
2699 SCM_VALIDATE_PROC (2, f
);
2700 SCM_VALIDATE_PROC (3, g
);
2701 if (!SCM_UNBNDP (base
))
2703 SCM_VALIDATE_STRING (5, base
);
2707 ans
= scm_i_make_string (0, NULL
, 0);
2708 if (!SCM_UNBNDP (make_final
))
2709 SCM_VALIDATE_PROC (6, make_final
);
2711 res
= scm_call_1 (p
, seed
);
2712 while (scm_is_false (res
))
2716 SCM ch
= scm_call_1 (f
, seed
);
2717 if (!SCM_CHARP (ch
))
2718 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2719 str
= scm_i_make_string (1, NULL
, 0);
2720 str
= scm_i_string_start_writing (str
);
2721 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2722 scm_i_string_stop_writing ();
2725 ans
= scm_string_append (scm_list_2 (str
, ans
));
2726 seed
= scm_call_1 (g
, seed
);
2727 res
= scm_call_1 (p
, seed
);
2729 if (!SCM_UNBNDP (make_final
))
2731 res
= scm_call_1 (make_final
, seed
);
2732 return scm_string_append (scm_list_2 (res
, ans
));
2740 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2741 (SCM proc
, SCM s
, SCM start
, SCM end
),
2742 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2743 "return value is not specified.")
2744 #define FUNC_NAME s_scm_string_for_each
2746 size_t cstart
, cend
;
2748 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2749 proc
, SCM_ARG1
, FUNC_NAME
);
2750 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2753 while (cstart
< cend
)
2755 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2759 scm_remember_upto_here_1 (s
);
2760 return SCM_UNSPECIFIED
;
2764 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2765 (SCM proc
, SCM s
, SCM start
, SCM end
),
2766 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2769 "For example, to change characters to alternately upper and\n"
2773 "(define str (string-copy \"studly\"))\n"
2774 "(string-for-each-index\n"
2776 " (string-set! str i\n"
2777 " ((if (even? i) char-upcase char-downcase)\n"
2778 " (string-ref str i))))\n"
2780 "str @result{} \"StUdLy\"\n"
2782 #define FUNC_NAME s_scm_string_for_each_index
2784 size_t cstart
, cend
;
2786 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2787 proc
, SCM_ARG1
, FUNC_NAME
);
2788 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2792 while (cstart
< cend
)
2794 scm_call_1 (proc
, scm_from_size_t (cstart
));
2798 scm_remember_upto_here_1 (s
);
2799 return SCM_UNSPECIFIED
;
2803 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2804 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2805 "This is the @emph{extended substring} procedure that implements\n"
2806 "replicated copying of a substring of some string.\n"
2808 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2809 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2810 "0 and the length of @var{s}. Replicate this substring up and\n"
2811 "down index space, in both the positive and negative directions.\n"
2812 "@code{xsubstring} returns the substring of this string\n"
2813 "beginning at index @var{from}, and ending at @var{to}, which\n"
2814 "defaults to @var{from} + (@var{end} - @var{start}).")
2815 #define FUNC_NAME s_scm_xsubstring
2818 size_t cstart
, cend
;
2822 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2826 cfrom
= scm_to_int (from
);
2827 if (SCM_UNBNDP (to
))
2828 cto
= cfrom
+ (cend
- cstart
);
2830 cto
= scm_to_int (to
);
2831 if (cstart
== cend
&& cfrom
!= cto
)
2832 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2834 result
= scm_i_make_string (cto
- cfrom
, NULL
, 0);
2835 result
= scm_i_string_start_writing (result
);
2840 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2842 scm_i_string_set_x (result
, p
,
2843 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2845 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2849 scm_i_string_stop_writing ();
2851 scm_remember_upto_here_1 (s
);
2857 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2858 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2859 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2860 "is written into the string @var{target} starting at index\n"
2861 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2862 "@var{target} @var{s})} or these arguments share storage -- you\n"
2863 "cannot copy a string on top of itself.")
2864 #define FUNC_NAME s_scm_string_xcopy_x
2867 size_t ctstart
, cstart
, cend
;
2869 SCM dummy
= SCM_UNDEFINED
;
2872 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2875 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2878 csfrom
= scm_to_int (sfrom
);
2879 if (SCM_UNBNDP (sto
))
2880 csto
= csfrom
+ (cend
- cstart
);
2882 csto
= scm_to_int (sto
);
2886 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2887 SCM_ASSERT_RANGE (1, tstart
,
2888 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2891 target
= scm_i_string_start_writing (target
);
2892 while (csfrom
< csto
)
2894 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2896 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2898 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2902 scm_i_string_stop_writing ();
2904 scm_remember_upto_here_2 (target
, s
);
2906 return SCM_UNSPECIFIED
;
2911 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2912 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2913 "Return the string @var{s1}, but with the characters\n"
2914 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2915 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2916 #define FUNC_NAME s_scm_string_replace
2918 size_t cstart1
, cend1
, cstart2
, cend2
;
2921 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2924 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2927 return (scm_string_append
2928 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2929 scm_i_substring (s2
, cstart2
, cend2
),
2930 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2936 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2937 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2938 "Split the string @var{s} into a list of substrings, where each\n"
2939 "substring is a maximal non-empty contiguous sequence of\n"
2940 "characters from the character set @var{token_set}, which\n"
2941 "defaults to @code{char-set:graphic}.\n"
2942 "If @var{start} or @var{end} indices are provided, they restrict\n"
2943 "@code{string-tokenize} to operating on the indicated substring\n"
2945 #define FUNC_NAME s_scm_string_tokenize
2947 size_t cstart
, cend
;
2948 SCM result
= SCM_EOL
;
2950 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2954 if (SCM_UNBNDP (token_set
))
2955 token_set
= scm_char_set_graphic
;
2957 if (SCM_CHARSETP (token_set
))
2961 while (cstart
< cend
)
2963 while (cstart
< cend
)
2965 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2972 while (cstart
< cend
)
2974 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2978 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2982 SCM_WRONG_TYPE_ARG (2, token_set
);
2984 scm_remember_upto_here_1 (s
);
2989 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2990 (SCM str
, SCM char_pred
),
2991 "Split the string @var{str} into a list of the substrings delimited\n"
2992 "by appearances of characters that\n"
2994 "@itemize @bullet\n"
2996 "equal @var{char_pred}, if it is a character,\n"
2999 "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
3002 "are in the set @var{char_pred}, if it is a character set.\n"
3004 "Note that an empty substring between separator characters\n"
3005 "will result in an empty string in the result list.\n"
3008 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3010 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3012 "(string-split \"::\" #\\:)\n"
3014 "(\"\" \"\" \"\")\n"
3016 "(string-split \"\" #\\:)\n"
3020 #define FUNC_NAME s_scm_string_split
3024 SCM_VALIDATE_STRING (1, str
);
3026 if (SCM_CHARP (char_pred
))
3031 /* This is explicit wide/narrow logic (instead of using
3032 scm_i_string_ref) is a speed optimization. */
3033 idx
= scm_i_string_length (str
);
3034 narrow
= scm_i_is_narrow_string (str
);
3037 const char *buf
= scm_i_string_chars (str
);
3041 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(char_pred
))
3045 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3052 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
3056 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(char_pred
))
3060 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3068 SCM sidx
, slast_idx
;
3070 if (!SCM_CHARSETP (char_pred
))
3071 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3072 char_pred
, SCM_ARG2
, FUNC_NAME
);
3074 /* Supporting predicates and character sets involves handling SCM
3075 values so there is less chance to optimize. */
3076 slast_idx
= scm_string_length (str
);
3079 sidx
= scm_string_index_right (str
, char_pred
, SCM_INUM0
, slast_idx
);
3080 if (scm_is_false (sidx
))
3082 res
= scm_cons (scm_substring (str
, scm_oneplus (sidx
), slast_idx
), res
);
3086 res
= scm_cons (scm_substring (str
, SCM_INUM0
, slast_idx
), res
);
3089 scm_remember_upto_here_1 (str
);
3095 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3096 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3097 "Filter the string @var{s}, retaining only those characters\n"
3098 "which satisfy @var{char_pred}.\n"
3100 "If @var{char_pred} is a procedure, it is applied to each\n"
3101 "character as a predicate, if it is a character, it is tested\n"
3102 "for equality and if it is a character set, it is tested for\n"
3104 #define FUNC_NAME s_scm_string_filter
3106 size_t cstart
, cend
;
3110 #if SCM_ENABLE_DEPRECATED == 1
3111 if (scm_is_string (char_pred
))
3115 scm_c_issue_deprecation_warning
3116 ("Guile used to use the wrong argument order for string-filter.\n"
3117 "This call to string-filter had the arguments in the wrong order.\n"
3118 "See SRFI-13 for more details. At some point we will remove this hack.");
3126 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3130 /* The explicit loops below stripping leading and trailing non-matches
3131 mean we can return a substring if those are the only deletions, making
3132 string-filter as efficient as string-trim-both in that case. */
3134 if (SCM_CHARP (char_pred
))
3138 /* strip leading non-matches by incrementing cstart */
3139 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3142 /* strip trailing non-matches by decrementing cend */
3143 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3146 /* count chars to keep */
3148 for (idx
= cstart
; idx
< cend
; idx
++)
3149 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3152 if (count
== cend
- cstart
)
3154 /* whole of cstart to cend is to be kept, return a copy-on-write
3157 result
= scm_i_substring (s
, cstart
, cend
);
3160 result
= scm_c_make_string (count
, char_pred
);
3162 else if (SCM_CHARSETP (char_pred
))
3166 /* strip leading non-matches by incrementing cstart */
3167 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3170 /* strip trailing non-matches by decrementing cend */
3171 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3174 /* count chars to be kept */
3176 for (idx
= cstart
; idx
< cend
; idx
++)
3177 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3180 /* if whole of start to end kept then return substring */
3181 if (count
== cend
- cstart
)
3182 goto result_substring
;
3186 result
= scm_i_make_string (count
, NULL
, 0);
3187 result
= scm_i_string_start_writing (result
);
3189 /* decrement "count" in this loop as well as using idx, so that if
3190 another thread is simultaneously changing "s" there's no chance
3191 it'll make us copy more than count characters */
3192 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3194 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3196 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3201 scm_i_string_stop_writing ();
3208 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3209 char_pred
, SCM_ARG1
, FUNC_NAME
);
3214 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3215 res
= scm_call_1 (char_pred
, ch
);
3216 if (scm_is_true (res
))
3217 ls
= scm_cons (ch
, ls
);
3220 result
= scm_reverse_list_to_string (ls
);
3223 scm_remember_upto_here_1 (s
);
3229 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3230 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
3231 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3233 "If @var{char_pred} is a procedure, it is applied to each\n"
3234 "character as a predicate, if it is a character, it is tested\n"
3235 "for equality and if it is a character set, it is tested for\n"
3237 #define FUNC_NAME s_scm_string_delete
3239 size_t cstart
, cend
;
3243 #if SCM_ENABLE_DEPRECATED == 1
3244 if (scm_is_string (char_pred
))
3248 scm_c_issue_deprecation_warning
3249 ("Guile used to use the wrong argument order for string-delete.\n"
3250 "This call to string-filter had the arguments in the wrong order.\n"
3251 "See SRFI-13 for more details. At some point we will remove this hack.");
3259 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
3263 /* The explicit loops below stripping leading and trailing matches mean we
3264 can return a substring if those are the only deletions, making
3265 string-delete as efficient as string-trim-both in that case. */
3267 if (SCM_CHARP (char_pred
))
3271 /* strip leading matches by incrementing cstart */
3272 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3275 /* strip trailing matches by decrementing cend */
3276 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3279 /* count chars to be kept */
3281 for (idx
= cstart
; idx
< cend
; idx
++)
3282 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3285 if (count
== cend
- cstart
)
3287 /* whole of cstart to cend is to be kept, return a copy-on-write
3290 result
= scm_i_substring (s
, cstart
, cend
);
3295 /* new string for retained portion */
3296 result
= scm_i_make_string (count
, NULL
, 0);
3297 result
= scm_i_string_start_writing (result
);
3298 /* decrement "count" in this loop as well as using idx, so that if
3299 another thread is simultaneously changing "s" there's no chance
3300 it'll make us copy more than count characters */
3301 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3303 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3304 if (c
!= SCM_CHAR (char_pred
))
3306 scm_i_string_set_x (result
, i
, c
);
3311 scm_i_string_stop_writing ();
3314 else if (SCM_CHARSETP (char_pred
))
3318 /* strip leading matches by incrementing cstart */
3319 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3322 /* strip trailing matches by decrementing cend */
3323 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3326 /* count chars to be kept */
3328 for (idx
= cstart
; idx
< cend
; idx
++)
3329 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3332 if (count
== cend
- cstart
)
3333 goto result_substring
;
3337 /* new string for retained portion */
3338 result
= scm_i_make_string (count
, NULL
, 0);
3339 result
= scm_i_string_start_writing (result
);
3341 /* decrement "count" in this loop as well as using idx, so that if
3342 another thread is simultaneously changing "s" there's no chance
3343 it'll make us copy more than count characters */
3344 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3346 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3348 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3353 scm_i_string_stop_writing ();
3359 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3360 char_pred
, SCM_ARG1
, FUNC_NAME
);
3365 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3366 res
= scm_call_1 (char_pred
, ch
);
3367 if (scm_is_false (res
))
3368 ls
= scm_cons (ch
, ls
);
3371 result
= scm_reverse_list_to_string (ls
);
3374 scm_remember_upto_here_1 (s
);
3380 scm_init_srfi_13 (void)
3382 #include "libguile/srfi-13.x"
3385 /* End of srfi-13.c. */