1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009 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/srfi-13.h"
33 #include "libguile/srfi-14.h"
35 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 scm_i_get_substring_spec (scm_i_string_length (str), \
41 start, &c_start, end, &c_end); \
44 #define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
45 pos_start, start, c_start, \
46 pos_end, end, c_end) \
48 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
49 scm_i_get_substring_spec (scm_i_string_length (str), \
50 start, &c_start, end, &c_end); \
53 #define REF_IN_CHARSET(s, i, cs) \
54 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
56 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
58 "Return @code{#t} if @var{str}'s length is zero, and\n"
59 "@code{#f} otherwise.\n"
61 "(string-null? \"\") @result{} #t\n"
62 "y @result{} \"foo\"\n"
63 "(string-null? y) @result{} #f\n"
65 #define FUNC_NAME s_scm_string_null_p
67 SCM_VALIDATE_STRING (1, str
);
68 return scm_from_bool (scm_i_string_length (str
) == 0);
76 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
80 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
81 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
82 "Check if @var{char_pred} is true for any character in string @var{s}.\n"
84 "@var{char_pred} can be a character to check for any equal to that, or\n"
85 "a character set (@pxref{Character Sets}) to check for any in that set,\n"
86 "or a predicate procedure to call.\n"
88 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
89 "successively on the characters from @var{start} to @var{end}. If\n"
90 "@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
91 "stops and that return value is the return from @code{string-any}. The\n"
92 "call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
93 "point is reached, is a tail call.\n"
95 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
96 "@var{end}) then the return is @code{#f}.\n")
97 #define FUNC_NAME s_scm_string_any
100 SCM res
= SCM_BOOL_F
;
102 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
106 if (SCM_CHARP (char_pred
))
109 for (i
= cstart
; i
< cend
; i
++)
110 if (scm_i_string_ref (s
, i
) == SCM_CHAR (char_pred
))
116 else if (SCM_CHARSETP (char_pred
))
119 for (i
= cstart
; i
< cend
; i
++)
120 if (REF_IN_CHARSET (s
, i
, char_pred
))
128 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
129 char_pred
, SCM_ARG1
, FUNC_NAME
);
131 while (cstart
< cend
)
133 res
= scm_call_1 (char_pred
,
134 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
135 if (scm_is_true (res
))
141 scm_remember_upto_here_1 (s
);
147 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
148 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
149 "Check if @var{char_pred} is true for every character in string\n"
152 "@var{char_pred} can be a character to check for every character equal\n"
153 "to that, or a character set (@pxref{Character Sets}) to check for\n"
154 "every character being in that set, or a predicate procedure to call.\n"
156 "For a procedure, calls @code{(@var{char_pred} c)} are made\n"
157 "successively on the characters from @var{start} to @var{end}. If\n"
158 "@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
159 "returns @code{#f}. The call on the last character (ie.@: at\n"
160 "@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
161 "return from that call is the return from @code{string-every}.\n"
163 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
164 "@var{end}) then the return is @code{#t}.\n")
165 #define FUNC_NAME s_scm_string_every
168 SCM res
= SCM_BOOL_T
;
170 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
173 if (SCM_CHARP (char_pred
))
176 for (i
= cstart
; i
< cend
; i
++)
177 if (scm_i_string_ref (s
, i
) != SCM_CHAR (char_pred
))
183 else if (SCM_CHARSETP (char_pred
))
186 for (i
= cstart
; i
< cend
; i
++)
187 if (!REF_IN_CHARSET (s
, i
, char_pred
))
195 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
196 char_pred
, SCM_ARG1
, FUNC_NAME
);
198 while (cstart
< cend
)
200 res
= scm_call_1 (char_pred
,
201 SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
202 if (scm_is_false (res
))
208 scm_remember_upto_here_1 (s
);
214 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
216 "@var{proc} is an integer->char procedure. Construct a string\n"
217 "of size @var{len} by applying @var{proc} to each index to\n"
218 "produce the corresponding string element. The order in which\n"
219 "@var{proc} is applied to the indices is not specified.")
220 #define FUNC_NAME s_scm_string_tabulate
226 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
227 proc
, SCM_ARG1
, FUNC_NAME
);
229 SCM_ASSERT_RANGE (2, len
, scm_to_int (len
) >= 0);
230 clen
= scm_to_size_t (len
);
233 /* This function is more complicated than necessary for the sake
235 scm_t_wchar
*buf
= scm_malloc (clen
* sizeof (scm_t_wchar
));
240 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
243 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
245 if (SCM_CHAR (ch
) > 255)
247 buf
[i
] = SCM_CHAR (ch
);
252 scm_t_wchar
*wbuf
= NULL
;
253 res
= scm_i_make_wide_string (clen
, &wbuf
);
254 memcpy (wbuf
, buf
, clen
* sizeof (scm_t_wchar
));
260 res
= scm_i_make_string (clen
, &nbuf
);
261 for (i
= 0; i
< clen
; i
++)
262 nbuf
[i
] = (unsigned char) buf
[i
];
272 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
273 (SCM str
, SCM start
, SCM end
),
274 "Convert the string @var{str} into a list of characters.")
275 #define FUNC_NAME s_scm_substring_to_list
279 SCM result
= SCM_EOL
;
281 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
285 /* This explicit narrow/wide logic (instead of just using
286 scm_i_string_ref) is for speed optimizaion. */
287 narrow
= scm_i_is_narrow_string (str
);
290 const char *buf
= scm_i_string_chars (str
);
291 while (cstart
< cend
)
294 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
299 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
300 while (cstart
< cend
)
303 result
= scm_cons (SCM_MAKE_CHAR (buf
[cend
]), result
);
306 scm_remember_upto_here_1 (str
);
311 /* We export scm_substring_to_list as "string->list" since it is
312 compatible and more general. This function remains for the benefit
313 of C code that used it.
317 scm_string_to_list (SCM str
)
319 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
322 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
324 "An efficient implementation of @code{(compose string->list\n"
328 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
330 #define FUNC_NAME s_scm_reverse_list_to_string
333 long i
= scm_ilength (chrs
), j
;
337 SCM_WRONG_TYPE_ARG (1, chrs
);
338 result
= scm_i_make_string (i
, &data
);
344 while (j
< i
&& scm_is_pair (rest
))
346 SCM elt
= SCM_CAR (rest
);
347 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
349 rest
= SCM_CDR (rest
);
353 result
= scm_i_string_start_writing (result
);
354 while (j
> 0 && scm_is_pair (rest
))
356 SCM elt
= SCM_CAR (rest
);
357 scm_i_string_set_x (result
, j
-1, SCM_CHAR (elt
));
358 rest
= SCM_CDR (rest
);
361 scm_i_string_stop_writing ();
369 SCM_SYMBOL (scm_sym_infix
, "infix");
370 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
371 SCM_SYMBOL (scm_sym_suffix
, "suffix");
372 SCM_SYMBOL (scm_sym_prefix
, "prefix");
374 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
375 (SCM ls
, SCM delimiter
, SCM grammar
),
376 "Append the string in the string list @var{ls}, using the string\n"
377 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
378 "@var{grammar} is a symbol which specifies how the delimiter is\n"
379 "placed between the strings, and defaults to the symbol\n"
384 "Insert the separator between list elements. An empty string\n"
385 "will produce an empty list.\n"
386 "@item string-infix\n"
387 "Like @code{infix}, but will raise an error if given the empty\n"
390 "Insert the separator after every list element.\n"
392 "Insert the separator before each list element.\n"
394 #define FUNC_NAME s_scm_string_join
397 #define GRAM_STRICT_INFIX 1
398 #define GRAM_SUFFIX 2
399 #define GRAM_PREFIX 3
402 int gram
= GRAM_INFIX
;
404 long strings
= scm_ilength (ls
);
406 /* Validate the string list. */
408 SCM_WRONG_TYPE_ARG (1, ls
);
410 /* Validate the delimiter and record its length. */
411 if (SCM_UNBNDP (delimiter
))
413 delimiter
= scm_from_locale_string (" ");
418 SCM_VALIDATE_STRING (2, delimiter
);
419 del_len
= scm_i_string_length (delimiter
);
422 /* Validate the grammar symbol and remember the grammar. */
423 if (SCM_UNBNDP (grammar
))
425 else if (scm_is_eq (grammar
, scm_sym_infix
))
427 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
428 gram
= GRAM_STRICT_INFIX
;
429 else if (scm_is_eq (grammar
, scm_sym_suffix
))
431 else if (scm_is_eq (grammar
, scm_sym_prefix
))
434 SCM_WRONG_TYPE_ARG (3, grammar
);
436 /* Check grammar constraints. */
437 if (strings
== 0 && gram
== GRAM_STRICT_INFIX
)
438 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
441 result
= scm_i_make_string (0, NULL
);
447 case GRAM_STRICT_INFIX
:
448 while (scm_is_pair (tmp
))
450 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
451 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
452 result
= scm_string_append (scm_list_2 (result
, delimiter
));
457 while (scm_is_pair (tmp
))
459 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
461 result
= scm_string_append (scm_list_2 (result
, delimiter
));
466 while (scm_is_pair (tmp
))
469 result
= scm_string_append (scm_list_2 (result
, delimiter
));
470 result
= scm_string_append (scm_list_2 (result
, SCM_CAR (tmp
)));
478 #undef GRAM_STRICT_INFIX
485 /* There are a number of functions to consider here for Scheme and C:
487 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
488 substring/copy STR start [end] ;; Guile variant of R5RS substring
490 scm_string_copy (str) ;; Old function from Guile
491 scm_substring_copy (str, [start, [end]])
492 ;; C version of SRFI-13 string-copy
493 ;; and C version of substring/copy
495 The C function underlying string-copy is not exported to C
496 programs. scm_substring_copy is defined in strings.c as the
497 underlying function of substring/copy and allows an optional START
501 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
503 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
504 (SCM str
, SCM start
, SCM end
),
505 "Return a freshly allocated copy of the string @var{str}. If\n"
506 "given, @var{start} and @var{end} delimit the portion of\n"
507 "@var{str} which is copied.")
508 #define FUNC_NAME s_scm_srfi13_substring_copy
512 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
515 return scm_i_substring_copy (str
, cstart
, cend
);
520 scm_string_copy (SCM str
)
522 if (!scm_is_string (str
))
523 scm_wrong_type_arg ("scm_string_copy", 0, str
);
525 return scm_i_substring (str
, 0, scm_i_string_length (str
));
528 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
529 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
530 "Copy the sequence of characters from index range [@var{start},\n"
531 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
532 "at index @var{tstart}. The characters are copied left-to-right\n"
533 "or right-to-left as needed -- the copy is guaranteed to work,\n"
534 "even if @var{target} and @var{s} are the same string. It is an\n"
535 "error if the copy operation runs off the end of the target\n"
537 #define FUNC_NAME s_scm_string_copy_x
539 size_t cstart
, cend
, ctstart
, dummy
, len
, i
;
540 SCM sdummy
= SCM_UNDEFINED
;
542 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
545 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
549 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
551 target
= scm_i_string_start_writing (target
);
552 for (i
= 0; i
< cend
- cstart
; i
++)
554 scm_i_string_set_x (target
, ctstart
+ i
,
555 scm_i_string_ref (s
, cstart
+ i
));
557 scm_i_string_stop_writing ();
558 scm_remember_upto_here_1 (target
);
560 return SCM_UNSPECIFIED
;
564 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
565 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
566 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
567 "into @var{str2} beginning at position @var{start2}.\n"
568 "@var{str1} and @var{str2} can be the same string.")
569 #define FUNC_NAME s_scm_substring_move_x
571 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
575 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
577 "Return the @var{n} first characters of @var{s}.")
578 #define FUNC_NAME s_scm_string_take
580 return scm_substring (s
, SCM_INUM0
, n
);
585 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
587 "Return all but the first @var{n} characters of @var{s}.")
588 #define FUNC_NAME s_scm_string_drop
590 return scm_substring (s
, n
, SCM_UNDEFINED
);
595 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
597 "Return the @var{n} last characters of @var{s}.")
598 #define FUNC_NAME s_scm_string_take_right
600 return scm_substring (s
,
601 scm_difference (scm_string_length (s
), n
),
607 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
609 "Return all but the last @var{n} characters of @var{s}.")
610 #define FUNC_NAME s_scm_string_drop_right
612 return scm_substring (s
,
614 scm_difference (scm_string_length (s
), n
));
619 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
620 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
621 "Take that characters from @var{start} to @var{end} from the\n"
622 "string @var{s} and return a new string, right-padded by the\n"
623 "character @var{chr} to length @var{len}. If the resulting\n"
624 "string is longer than @var{len}, it is truncated on the right.")
625 #define FUNC_NAME s_scm_string_pad
627 size_t cstart
, cend
, clen
;
629 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
632 clen
= scm_to_size_t (len
);
634 if (SCM_UNBNDP (chr
))
635 chr
= SCM_MAKE_CHAR (' ');
638 SCM_VALIDATE_CHAR (3, chr
);
640 if (clen
< (cend
- cstart
))
641 return scm_i_substring (s
, cend
- clen
, cend
);
645 result
= (scm_string_append
646 (scm_list_2 (scm_c_make_string (clen
- (cend
- cstart
), chr
),
647 scm_i_substring (s
, cstart
, cend
))));
654 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
655 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
656 "Take that characters from @var{start} to @var{end} from the\n"
657 "string @var{s} and return a new string, left-padded by the\n"
658 "character @var{chr} to length @var{len}. If the resulting\n"
659 "string is longer than @var{len}, it is truncated on the left.")
660 #define FUNC_NAME s_scm_string_pad_right
662 size_t cstart
, cend
, clen
;
664 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
667 clen
= scm_to_size_t (len
);
669 if (SCM_UNBNDP (chr
))
670 chr
= SCM_MAKE_CHAR (' ');
673 SCM_VALIDATE_CHAR (3, chr
);
675 if (clen
< (cend
- cstart
))
676 return scm_i_substring (s
, cstart
, cstart
+ clen
);
681 result
= (scm_string_append
682 (scm_list_2 (scm_i_substring (s
, cstart
, cend
),
683 scm_c_make_string (clen
- (cend
- cstart
), chr
))));
691 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
692 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
693 "Trim @var{s} by skipping over all characters on the left\n"
694 "that satisfy the parameter @var{char_pred}:\n"
698 "if it is the character @var{ch}, characters equal to\n"
699 "@var{ch} are trimmed,\n"
702 "if it is a procedure @var{pred} characters that\n"
703 "satisfy @var{pred} are trimmed,\n"
706 "if it is a character set, characters in that set are trimmed.\n"
709 "If called without a @var{char_pred} argument, all whitespace is\n"
711 #define FUNC_NAME s_scm_string_trim
715 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
718 if (SCM_UNBNDP (char_pred
))
720 while (cstart
< cend
)
722 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
727 else if (SCM_CHARP (char_pred
))
729 while (cstart
< cend
)
731 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
736 else if (SCM_CHARSETP (char_pred
))
738 while (cstart
< cend
)
740 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
747 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
748 char_pred
, SCM_ARG2
, FUNC_NAME
);
750 while (cstart
< cend
)
754 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
755 if (scm_is_false (res
))
760 return scm_i_substring (s
, cstart
, cend
);
765 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
766 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
767 "Trim @var{s} by skipping over all characters on the right\n"
768 "that satisfy the parameter @var{char_pred}:\n"
772 "if it is the character @var{ch}, characters equal to @var{ch}\n"
776 "if it is a procedure @var{pred} characters that satisfy\n"
777 "@var{pred} are trimmed,\n"
780 "if it is a character sets, all characters in that set are\n"
784 "If called without a @var{char_pred} argument, all whitespace is\n"
786 #define FUNC_NAME s_scm_string_trim_right
790 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
793 if (SCM_UNBNDP (char_pred
))
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
))
870 while (cstart
< cend
)
872 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cstart
)))
876 while (cstart
< cend
)
878 if (!uc_is_c_whitespace (scm_i_string_ref (s
, cend
- 1)))
883 else if (SCM_CHARP (char_pred
))
885 while (cstart
< cend
)
887 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR(char_pred
))
891 while (cstart
< cend
)
893 if (scm_i_string_ref (s
, cend
- 1) != SCM_CHAR (char_pred
))
898 else if (SCM_CHARSETP (char_pred
))
900 while (cstart
< cend
)
902 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
906 while (cstart
< cend
)
908 if (!REF_IN_CHARSET (s
, cend
-1, char_pred
))
915 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
916 char_pred
, SCM_ARG2
, FUNC_NAME
);
918 while (cstart
< cend
)
922 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
923 if (scm_is_false (res
))
927 while (cstart
< cend
)
931 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
- 1)));
932 if (scm_is_false (res
))
937 return scm_i_substring (s
, cstart
, cend
);
942 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
943 (SCM str
, SCM chr
, SCM start
, SCM end
),
944 "Stores @var{chr} in every element of the given @var{str} and\n"
945 "returns an unspecified value.")
946 #define FUNC_NAME s_scm_substring_fill_x
951 /* Older versions of Guile provided the function
952 scm_substring_fill_x with the following order of arguments:
956 We accomodate this here by detecting such a usage and reordering
967 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
970 SCM_VALIDATE_CHAR (2, chr
);
973 str
= scm_i_string_start_writing (str
);
974 for (k
= cstart
; k
< cend
; k
++)
975 scm_i_string_set_x (str
, k
, SCM_CHAR (chr
));
976 scm_i_string_stop_writing ();
978 return SCM_UNSPECIFIED
;
983 scm_string_fill_x (SCM str
, SCM chr
)
985 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
988 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
989 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
990 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
991 "mismatch index, depending upon whether @var{s1} is less than,\n"
992 "equal to, or greater than @var{s2}. The mismatch index is the\n"
993 "largest index @var{i} such that for every 0 <= @var{j} <\n"
994 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
995 "@var{i} is the first position that does not match.")
996 #define FUNC_NAME s_scm_string_compare
998 size_t cstart1
, cend1
, cstart2
, cend2
;
1001 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1004 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1007 SCM_VALIDATE_PROC (3, proc_lt
);
1008 SCM_VALIDATE_PROC (4, proc_eq
);
1009 SCM_VALIDATE_PROC (5, proc_gt
);
1011 while (cstart1
< cend1
&& cstart2
< cend2
)
1013 if (scm_i_string_ref (s1
, cstart1
)
1014 < scm_i_string_ref (s2
, cstart2
))
1019 else if (scm_i_string_ref (s1
, cstart1
)
1020 > scm_i_string_ref (s2
, cstart2
))
1028 if (cstart1
< cend1
)
1030 else if (cstart2
< cend2
)
1036 scm_remember_upto_here_2 (s1
, s2
);
1037 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1042 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1043 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1044 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1045 "mismatch index, depending upon whether @var{s1} is less than,\n"
1046 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1047 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1048 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1049 "@var{i} is the first position where the lowercased letters \n"
1051 #define FUNC_NAME s_scm_string_compare_ci
1053 size_t cstart1
, cend1
, cstart2
, cend2
;
1056 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1059 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1062 SCM_VALIDATE_PROC (3, proc_lt
);
1063 SCM_VALIDATE_PROC (4, proc_eq
);
1064 SCM_VALIDATE_PROC (5, proc_gt
);
1066 while (cstart1
< cend1
&& cstart2
< cend2
)
1068 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1069 < uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1074 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1075 > uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1084 if (cstart1
< cend1
)
1086 else if (cstart2
< cend2
)
1092 scm_remember_upto_here (s1
, s2
);
1093 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1097 /* This function compares two substrings, S1 from START1 to END1 and
1098 S2 from START2 to END2, possibly case insensitively, and returns
1099 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1100 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1101 longer, or equal. */
1103 compare_strings (const char *fname
, int case_insensitive
,
1104 SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
,
1105 SCM lessthan
, SCM greaterthan
, SCM shorter
, SCM longer
, SCM equal
)
1107 size_t cstart1
, cend1
, cstart2
, cend2
;
1111 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 1, s1
,
1114 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname
, 2, s2
,
1118 while (cstart1
< cend1
&& cstart2
< cend2
)
1120 if (case_insensitive
)
1122 a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1123 b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1127 a
= scm_i_string_ref (s1
, cstart1
);
1128 b
= scm_i_string_ref (s2
, cstart2
);
1143 if (cstart1
< cend1
)
1148 else if (cstart2
< cend2
)
1160 scm_remember_upto_here_2 (s1
, s2
);
1165 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1166 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1167 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1169 #define FUNC_NAME s_scm_string_eq
1171 return compare_strings (FUNC_NAME
, 0,
1172 s1
, s2
, start1
, end1
, start2
, end2
,
1173 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1178 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1179 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1180 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1182 #define FUNC_NAME s_scm_string_neq
1184 return compare_strings (FUNC_NAME
, 0,
1185 s1
, s2
, start1
, end1
, start2
, end2
,
1186 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1191 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1192 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1193 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1194 "true value otherwise.")
1195 #define FUNC_NAME s_scm_string_lt
1197 return compare_strings (FUNC_NAME
, 0,
1198 s1
, s2
, start1
, end1
, start2
, end2
,
1199 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1204 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1205 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1206 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1207 "true value otherwise.")
1208 #define FUNC_NAME s_scm_string_gt
1210 return compare_strings (FUNC_NAME
, 0,
1211 s1
, s2
, start1
, end1
, start2
, end2
,
1212 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1217 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1218 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1219 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1221 #define FUNC_NAME s_scm_string_le
1223 return compare_strings (FUNC_NAME
, 0,
1224 s1
, s2
, start1
, end1
, start2
, end2
,
1225 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
);
1230 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1231 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1232 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1234 #define FUNC_NAME s_scm_string_ge
1236 return compare_strings (FUNC_NAME
, 0,
1237 s1
, s2
, start1
, end1
, start2
, end2
,
1238 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_T
);
1243 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1244 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1245 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1246 "value otherwise. The character comparison is done\n"
1247 "case-insensitively.")
1248 #define FUNC_NAME s_scm_string_ci_eq
1250 return compare_strings (FUNC_NAME
, 1,
1251 s1
, s2
, start1
, end1
, start2
, end2
,
1252 SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_F
, SCM_BOOL_T
);
1257 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1258 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1259 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1260 "value otherwise. The character comparison is done\n"
1261 "case-insensitively.")
1262 #define FUNC_NAME s_scm_string_ci_neq
1264 return compare_strings (FUNC_NAME
, 1,
1265 s1
, s2
, start1
, end1
, start2
, end2
,
1266 SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_T
, SCM_BOOL_F
);
1271 SCM_DEFINE (scm_string_ci_lt
, "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} is greater or equal to @var{s2}, a\n"
1274 "true value otherwise. The character comparison is done\n"
1275 "case-insensitively.")
1276 #define FUNC_NAME s_scm_string_ci_lt
1278 return compare_strings (FUNC_NAME
, 1,
1279 s1
, s2
, start1
, end1
, start2
, end2
,
1280 SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_F
);
1285 SCM_DEFINE (scm_string_ci_gt
, "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} is less or equal to @var{s2}, a\n"
1288 "true value otherwise. The character comparison is done\n"
1289 "case-insensitively.")
1290 #define FUNC_NAME s_scm_string_ci_gt
1292 return compare_strings (FUNC_NAME
, 1,
1293 s1
, s2
, start1
, end1
, start2
, end2
,
1294 SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
, SCM_BOOL_T
, SCM_BOOL_F
);
1299 SCM_DEFINE (scm_string_ci_le
, "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 to @var{s2}, a true\n"
1302 "value otherwise. The character comparison is done\n"
1303 "case-insensitively.")
1304 #define FUNC_NAME s_scm_string_ci_le
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_T
);
1313 SCM_DEFINE (scm_string_ci_ge
, "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 to @var{s2}, a true value\n"
1316 "otherwise. The character comparison is done\n"
1317 "case-insensitively.")
1318 #define FUNC_NAME s_scm_string_ci_ge
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_T
);
1326 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1327 (SCM s
, SCM bound
, SCM start
, SCM end
),
1328 "Compute a hash value for @var{S}. the optional argument "
1329 "@var{bound} is a non-negative exact "
1330 "integer specifying the range of the hash function. "
1331 "A positive value restricts the return value to the "
1333 #define FUNC_NAME s_scm_substring_hash
1335 if (SCM_UNBNDP (bound
))
1336 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1337 if (SCM_UNBNDP (start
))
1339 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1343 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1344 (SCM s
, SCM bound
, SCM start
, SCM end
),
1345 "Compute a hash value for @var{S}. the optional argument "
1346 "@var{bound} is a non-negative exact "
1347 "integer specifying the range of the hash function. "
1348 "A positive value restricts the return value to the "
1350 #define FUNC_NAME s_scm_substring_hash_ci
1352 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1354 SCM_UNDEFINED
, SCM_UNDEFINED
);
1358 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1359 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1360 "Return the length of the longest common prefix of the two\n"
1362 #define FUNC_NAME s_scm_string_prefix_length
1364 size_t cstart1
, cend1
, cstart2
, cend2
;
1367 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1370 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1374 while (cstart1
< cend1
&& cstart2
< cend2
)
1376 if (scm_i_string_ref (s1
, cstart1
)
1377 != scm_i_string_ref (s2
, cstart2
))
1385 scm_remember_upto_here_2 (s1
, s2
);
1386 return scm_from_size_t (len
);
1391 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1392 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1393 "Return the length of the longest common prefix of the two\n"
1394 "strings, ignoring character case.")
1395 #define FUNC_NAME s_scm_string_prefix_length_ci
1397 size_t cstart1
, cend1
, cstart2
, cend2
;
1400 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1403 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1406 while (cstart1
< cend1
&& cstart2
< cend2
)
1408 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)))
1409 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
))))
1417 scm_remember_upto_here_2 (s1
, s2
);
1418 return scm_from_size_t (len
);
1423 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1424 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1425 "Return the length of the longest common suffix of the two\n"
1427 #define FUNC_NAME s_scm_string_suffix_length
1429 size_t cstart1
, cend1
, cstart2
, cend2
;
1432 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1435 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1438 while (cstart1
< cend1
&& cstart2
< cend2
)
1442 if (scm_i_string_ref (s1
, cend1
)
1443 != scm_i_string_ref (s2
, cend2
))
1449 scm_remember_upto_here_2 (s1
, s2
);
1450 return scm_from_size_t (len
);
1455 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1456 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1457 "Return the length of the longest common suffix of the two\n"
1458 "strings, ignoring character case.")
1459 #define FUNC_NAME s_scm_string_suffix_length_ci
1461 size_t cstart1
, cend1
, cstart2
, cend2
;
1464 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1467 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1470 while (cstart1
< cend1
&& cstart2
< cend2
)
1474 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1475 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1481 scm_remember_upto_here_2 (s1
, s2
);
1482 return scm_from_size_t (len
);
1487 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1488 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1489 "Is @var{s1} a prefix of @var{s2}?")
1490 #define FUNC_NAME s_scm_string_prefix_p
1492 size_t cstart1
, cend1
, cstart2
, cend2
;
1493 size_t len
= 0, len1
;
1495 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1498 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1501 len1
= cend1
- cstart1
;
1502 while (cstart1
< cend1
&& cstart2
< cend2
)
1504 if (scm_i_string_ref (s1
, cstart1
)
1505 != scm_i_string_ref (s2
, cstart2
))
1513 scm_remember_upto_here_2 (s1
, s2
);
1514 return scm_from_bool (len
== len1
);
1519 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1520 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1521 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1522 #define FUNC_NAME s_scm_string_prefix_ci_p
1524 size_t cstart1
, cend1
, cstart2
, cend2
;
1525 size_t len
= 0, len1
;
1527 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1530 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1533 len1
= cend1
- cstart1
;
1534 while (cstart1
< cend1
&& cstart2
< cend2
)
1536 scm_t_wchar a
= uc_tolower (uc_toupper (scm_i_string_ref (s1
, cstart1
)));
1537 scm_t_wchar b
= uc_tolower (uc_toupper (scm_i_string_ref (s2
, cstart2
)));
1546 scm_remember_upto_here_2 (s1
, s2
);
1547 return scm_from_bool (len
== len1
);
1552 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1553 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1554 "Is @var{s1} a suffix of @var{s2}?")
1555 #define FUNC_NAME s_scm_string_suffix_p
1557 size_t cstart1
, cend1
, cstart2
, cend2
;
1558 size_t len
= 0, len1
;
1560 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1563 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1566 len1
= cend1
- cstart1
;
1567 while (cstart1
< cend1
&& cstart2
< cend2
)
1571 if (scm_i_string_ref (s1
, cend1
)
1572 != scm_i_string_ref (s2
, cend2
))
1578 scm_remember_upto_here_2 (s1
, s2
);
1579 return scm_from_bool (len
== len1
);
1584 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1585 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1586 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1587 #define FUNC_NAME s_scm_string_suffix_ci_p
1589 size_t cstart1
, cend1
, cstart2
, cend2
;
1590 size_t len
= 0, len1
;
1592 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1595 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1598 len1
= cend1
- cstart1
;
1599 while (cstart1
< cend1
&& cstart2
< cend2
)
1603 if (uc_tolower (uc_toupper (scm_i_string_ref (s1
, cend1
)))
1604 != uc_tolower (uc_toupper (scm_i_string_ref (s2
, cend2
))))
1610 scm_remember_upto_here_2 (s1
, s2
);
1611 return scm_from_bool (len
== len1
);
1616 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1617 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1618 "Search through the string @var{s} from left to right, returning\n"
1619 "the index of the first occurence of a character which\n"
1621 "@itemize @bullet\n"
1623 "equals @var{char_pred}, if it is character,\n"
1626 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1629 "is in the set @var{char_pred}, if it is a character set.\n"
1631 #define FUNC_NAME s_scm_string_index
1633 size_t cstart
, cend
;
1635 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1638 if (SCM_CHARP (char_pred
))
1640 while (cstart
< cend
)
1642 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR (char_pred
))
1647 else if (SCM_CHARSETP (char_pred
))
1649 while (cstart
< cend
)
1651 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1658 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1659 char_pred
, SCM_ARG2
, FUNC_NAME
);
1661 while (cstart
< cend
)
1664 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1665 if (scm_is_true (res
))
1671 scm_remember_upto_here_1 (s
);
1675 scm_remember_upto_here_1 (s
);
1676 return scm_from_size_t (cstart
);
1680 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1681 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1682 "Search through the string @var{s} from right to left, returning\n"
1683 "the index of the last occurence of a character which\n"
1685 "@itemize @bullet\n"
1687 "equals @var{char_pred}, if it is character,\n"
1690 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1693 "is in the set if @var{char_pred} is a character set.\n"
1695 #define FUNC_NAME s_scm_string_index_right
1697 size_t cstart
, cend
;
1699 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1702 if (SCM_CHARP (char_pred
))
1704 while (cstart
< cend
)
1707 if (scm_i_string_ref (s
, cend
) == SCM_CHAR (char_pred
))
1711 else if (SCM_CHARSETP (char_pred
))
1713 while (cstart
< cend
)
1716 if (REF_IN_CHARSET (s
, cend
, char_pred
))
1722 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1723 char_pred
, SCM_ARG2
, FUNC_NAME
);
1725 while (cstart
< cend
)
1729 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1730 if (scm_is_true (res
))
1735 scm_remember_upto_here_1 (s
);
1739 scm_remember_upto_here_1 (s
);
1740 return scm_from_size_t (cend
);
1744 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1745 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1746 "Search through the string @var{s} from right to left, returning\n"
1747 "the index of the last occurence of a character which\n"
1749 "@itemize @bullet\n"
1751 "equals @var{char_pred}, if it is character,\n"
1754 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1757 "is in the set if @var{char_pred} is a character set.\n"
1759 #define FUNC_NAME s_scm_string_rindex
1761 return scm_string_index_right (s
, char_pred
, start
, end
);
1765 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1766 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1767 "Search through the string @var{s} from left to right, returning\n"
1768 "the index of the first occurence of a character which\n"
1770 "@itemize @bullet\n"
1772 "does not equal @var{char_pred}, if it is character,\n"
1775 "does not satisify the predicate @var{char_pred}, if it is a\n"
1779 "is not in the set if @var{char_pred} is a character set.\n"
1781 #define FUNC_NAME s_scm_string_skip
1783 size_t cstart
, cend
;
1785 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1788 if (SCM_CHARP (char_pred
))
1790 while (cstart
< cend
)
1792 if (scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
1797 else if (SCM_CHARSETP (char_pred
))
1799 while (cstart
< cend
)
1801 if (!REF_IN_CHARSET (s
, cstart
, char_pred
))
1808 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1809 char_pred
, SCM_ARG2
, FUNC_NAME
);
1811 while (cstart
< cend
)
1814 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1815 if (scm_is_false (res
))
1821 scm_remember_upto_here_1 (s
);
1825 scm_remember_upto_here_1 (s
);
1826 return scm_from_size_t (cstart
);
1831 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1832 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1833 "Search through the string @var{s} from right to left, returning\n"
1834 "the index of the last occurence of a character which\n"
1836 "@itemize @bullet\n"
1838 "does not equal @var{char_pred}, if it is character,\n"
1841 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1845 "is not in the set if @var{char_pred} is a character set.\n"
1847 #define FUNC_NAME s_scm_string_skip_right
1849 size_t cstart
, cend
;
1851 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1854 if (SCM_CHARP (char_pred
))
1856 while (cstart
< cend
)
1859 if (scm_i_string_ref (s
, cend
) != SCM_CHAR (char_pred
))
1863 else if (SCM_CHARSETP (char_pred
))
1865 while (cstart
< cend
)
1868 if (!REF_IN_CHARSET (s
, cend
, char_pred
))
1874 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1875 char_pred
, SCM_ARG2
, FUNC_NAME
);
1877 while (cstart
< cend
)
1881 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
)));
1882 if (scm_is_false (res
))
1887 scm_remember_upto_here_1 (s
);
1891 scm_remember_upto_here_1 (s
);
1892 return scm_from_size_t (cend
);
1898 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1899 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1900 "Return the count of the number of characters in the string\n"
1903 "@itemize @bullet\n"
1905 "equals @var{char_pred}, if it is character,\n"
1908 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1911 "is in the set @var{char_pred}, if it is a character set.\n"
1913 #define FUNC_NAME s_scm_string_count
1915 size_t cstart
, cend
;
1918 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
1921 if (SCM_CHARP (char_pred
))
1923 while (cstart
< cend
)
1925 if (scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
1930 else if (SCM_CHARSETP (char_pred
))
1932 while (cstart
< cend
)
1934 if (REF_IN_CHARSET (s
, cstart
, char_pred
))
1941 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
1942 char_pred
, SCM_ARG2
, FUNC_NAME
);
1944 while (cstart
< cend
)
1947 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
1948 if (scm_is_true (res
))
1954 scm_remember_upto_here_1 (s
);
1955 return scm_from_size_t (count
);
1960 /* FIXME::martin: This should definitely get implemented more
1961 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1963 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1964 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1965 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1966 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1967 "The optional start/end indices restrict the operation to the\n"
1968 "indicated substrings.")
1969 #define FUNC_NAME s_scm_string_contains
1971 size_t cstart1
, cend1
, cstart2
, cend2
;
1974 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
1977 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
1980 len2
= cend2
- cstart2
;
1981 if (cend1
- cstart1
>= len2
)
1982 while (cstart1
<= cend1
- len2
)
1988 && (scm_i_string_ref (s1
, i
)
1989 == scm_i_string_ref (s2
, j
)))
1996 scm_remember_upto_here_2 (s1
, s2
);
1997 return scm_from_size_t (cstart1
);
2002 scm_remember_upto_here_2 (s1
, s2
);
2008 /* FIXME::martin: This should definitely get implemented more
2009 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2011 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2012 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2013 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2014 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2015 "The optional start/end indices restrict the operation to the\n"
2016 "indicated substrings. Character comparison is done\n"
2017 "case-insensitively.")
2018 #define FUNC_NAME s_scm_string_contains_ci
2020 size_t cstart1
, cend1
, cstart2
, cend2
;
2023 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2026 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2029 len2
= cend2
- cstart2
;
2030 if (cend1
- cstart1
>= len2
)
2031 while (cstart1
<= cend1
- len2
)
2037 && (uc_tolower (uc_toupper (scm_i_string_ref (s1
, i
)))
2038 == uc_tolower (uc_toupper (scm_i_string_ref (s2
, j
)))))
2045 scm_remember_upto_here_2 (s1
, s2
);
2046 return scm_from_size_t (cstart1
);
2051 scm_remember_upto_here_2 (s1
, s2
);
2057 /* Helper function for the string uppercase conversion functions. */
2059 string_upcase_x (SCM v
, size_t start
, size_t end
)
2063 v
= scm_i_string_start_writing (v
);
2064 for (k
= start
; k
< end
; ++k
)
2065 scm_i_string_set_x (v
, k
, uc_toupper (scm_i_string_ref (v
, k
)));
2066 scm_i_string_stop_writing ();
2067 scm_remember_upto_here_1 (v
);
2072 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2073 (SCM str
, SCM start
, SCM end
),
2074 "Destructively upcase every character in @code{str}.\n"
2077 "(string-upcase! y)\n"
2078 "@result{} \"ARRDEFG\"\n"
2080 "@result{} \"ARRDEFG\"\n"
2082 #define FUNC_NAME s_scm_substring_upcase_x
2084 size_t cstart
, cend
;
2086 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2089 return string_upcase_x (str
, cstart
, cend
);
2094 scm_string_upcase_x (SCM str
)
2096 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2099 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2100 (SCM str
, SCM start
, SCM end
),
2101 "Upcase every character in @code{str}.")
2102 #define FUNC_NAME s_scm_substring_upcase
2104 size_t cstart
, cend
;
2106 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2109 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2114 scm_string_upcase (SCM str
)
2116 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2119 /* Helper function for the string lowercase conversion functions.
2120 * No argument checking is performed. */
2122 string_downcase_x (SCM v
, size_t start
, size_t end
)
2126 v
= scm_i_string_start_writing (v
);
2127 for (k
= start
; k
< end
; ++k
)
2128 scm_i_string_set_x (v
, k
, uc_tolower (scm_i_string_ref (v
, k
)));
2129 scm_i_string_stop_writing ();
2130 scm_remember_upto_here_1 (v
);
2135 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2136 (SCM str
, SCM start
, SCM end
),
2137 "Destructively downcase every character in @var{str}.\n"
2141 "@result{} \"ARRDEFG\"\n"
2142 "(string-downcase! y)\n"
2143 "@result{} \"arrdefg\"\n"
2145 "@result{} \"arrdefg\"\n"
2147 #define FUNC_NAME s_scm_substring_downcase_x
2149 size_t cstart
, cend
;
2151 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2154 return string_downcase_x (str
, cstart
, cend
);
2159 scm_string_downcase_x (SCM str
)
2161 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2164 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2165 (SCM str
, SCM start
, SCM end
),
2166 "Downcase every character in @var{str}.")
2167 #define FUNC_NAME s_scm_substring_downcase
2169 size_t cstart
, cend
;
2171 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2174 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2179 scm_string_downcase (SCM str
)
2181 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2184 /* Helper function for the string capitalization functions.
2185 * No argument checking is performed. */
2187 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2193 str
= scm_i_string_start_writing (str
);
2194 for(i
= start
; i
< end
; i
++)
2196 ch
= SCM_MAKE_CHAR (scm_i_string_ref (str
, i
));
2197 if (scm_is_true (scm_char_alphabetic_p (ch
)))
2201 scm_i_string_set_x (str
, i
, uc_totitle (SCM_CHAR (ch
)));
2206 scm_i_string_set_x (str
, i
, uc_tolower (SCM_CHAR (ch
)));
2212 scm_i_string_stop_writing ();
2213 scm_remember_upto_here_1 (str
);
2219 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2220 (SCM str
, SCM start
, SCM end
),
2221 "Destructively titlecase every first character in a word in\n"
2223 #define FUNC_NAME s_scm_string_titlecase_x
2225 size_t cstart
, cend
;
2227 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2230 return string_titlecase_x (str
, cstart
, cend
);
2235 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2236 (SCM str
, SCM start
, SCM end
),
2237 "Titlecase every first character in a word in @var{str}.")
2238 #define FUNC_NAME s_scm_string_titlecase
2240 size_t cstart
, cend
;
2242 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2245 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2249 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2251 "Upcase the first character of every word in @var{str}\n"
2252 "destructively and return @var{str}.\n"
2255 "y @result{} \"hello world\"\n"
2256 "(string-capitalize! y) @result{} \"Hello World\"\n"
2257 "y @result{} \"Hello World\"\n"
2259 #define FUNC_NAME s_scm_string_capitalize_x
2261 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2266 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2268 "Return a freshly allocated string with the characters in\n"
2269 "@var{str}, where the first character of every word is\n"
2271 #define FUNC_NAME s_scm_string_capitalize
2273 return scm_string_capitalize_x (scm_string_copy (str
));
2278 /* Reverse the portion of @var{str} between str[cstart] (including)
2279 and str[cend] excluding. */
2281 string_reverse_x (SCM str
, size_t cstart
, size_t cend
)
2285 str
= scm_i_string_start_writing (str
);
2289 while (cstart
< cend
)
2291 tmp
= SCM_MAKE_CHAR (scm_i_string_ref (str
, cstart
));
2292 scm_i_string_set_x (str
, cstart
, scm_i_string_ref (str
, cend
));
2293 scm_i_string_set_x (str
, cend
, SCM_CHAR (tmp
));
2298 scm_i_string_stop_writing ();
2302 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2303 (SCM str
, SCM start
, SCM end
),
2304 "Reverse the string @var{str}. The optional arguments\n"
2305 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2307 #define FUNC_NAME s_scm_string_reverse
2309 size_t cstart
, cend
;
2312 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2315 result
= scm_string_copy (str
);
2316 string_reverse_x (result
, cstart
, cend
);
2317 scm_remember_upto_here_1 (str
);
2323 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2324 (SCM str
, SCM start
, SCM end
),
2325 "Reverse the string @var{str} in-place. The optional arguments\n"
2326 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2327 "operate on. The return value is unspecified.")
2328 #define FUNC_NAME s_scm_string_reverse_x
2330 size_t cstart
, cend
;
2332 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2336 string_reverse_x (str
, cstart
, cend
);
2337 scm_remember_upto_here_1 (str
);
2338 return SCM_UNSPECIFIED
;
2343 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2345 "Like @code{string-append}, but the result may share memory\n"
2346 "with the argument strings.")
2347 #define FUNC_NAME s_scm_string_append_shared
2349 /* If "rest" contains just one non-empty string, return that.
2350 If it's entirely empty strings, then return scm_nullstr.
2351 Otherwise use scm_string_concatenate. */
2353 SCM ret
= scm_nullstr
;
2354 int seen_nonempty
= 0;
2357 SCM_VALIDATE_REST_ARGUMENT (rest
);
2359 for (l
= rest
; scm_is_pair (l
); l
= SCM_CDR (l
))
2362 if (!scm_is_string (s
))
2363 scm_wrong_type_arg (FUNC_NAME
, 0, s
);
2364 if (scm_i_string_length (s
) != 0)
2367 /* two or more non-empty strings, need full concat */
2368 return scm_string_append (rest
);
2379 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2381 "Append the elements of @var{ls} (which must be strings)\n"
2382 "together into a single string. Guaranteed to return a freshly\n"
2383 "allocated string.")
2384 #define FUNC_NAME s_scm_string_concatenate
2386 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2387 return scm_string_append (ls
);
2392 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2393 (SCM ls
, SCM final_string
, SCM end
),
2394 "Without optional arguments, this procedure is equivalent to\n"
2397 "(string-concatenate (reverse ls))\n"
2400 "If the optional argument @var{final_string} is specified, it is\n"
2401 "consed onto the beginning to @var{ls} before performing the\n"
2402 "list-reverse and string-concatenate operations. If @var{end}\n"
2403 "is given, only the characters of @var{final_string} up to index\n"
2404 "@var{end} are used.\n"
2406 "Guaranteed to return a freshly allocated string.")
2407 #define FUNC_NAME s_scm_string_concatenate_reverse
2409 if (!SCM_UNBNDP (end
))
2410 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2412 if (!SCM_UNBNDP (final_string
))
2413 ls
= scm_cons (final_string
, ls
);
2415 return scm_string_concatenate (scm_reverse (ls
));
2420 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2422 "Like @code{string-concatenate}, but the result may share memory\n"
2423 "with the strings in the list @var{ls}.")
2424 #define FUNC_NAME s_scm_string_concatenate_shared
2426 SCM_VALIDATE_LIST (SCM_ARG1
, ls
);
2427 return scm_string_append_shared (ls
);
2432 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2433 (SCM ls
, SCM final_string
, SCM end
),
2434 "Like @code{string-concatenate-reverse}, but the result may\n"
2435 "share memory with the the strings in the @var{ls} arguments.")
2436 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2438 /* Just call the non-sharing version. */
2439 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2444 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2445 (SCM proc
, SCM s
, SCM start
, SCM end
),
2446 "@var{proc} is a char->char procedure, it is mapped over\n"
2447 "@var{s}. The order in which the procedure is applied to the\n"
2448 "string elements is not specified.")
2449 #define FUNC_NAME s_scm_string_map
2452 size_t cstart
, cend
;
2455 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2456 proc
, SCM_ARG1
, FUNC_NAME
);
2457 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2460 result
= scm_i_make_string (cend
- cstart
, NULL
);
2462 while (cstart
< cend
)
2464 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2465 if (!SCM_CHARP (ch
))
2466 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2468 result
= scm_i_string_start_writing (result
);
2469 scm_i_string_set_x (result
, p
, SCM_CHAR (ch
));
2470 scm_i_string_stop_writing ();
2479 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2480 (SCM proc
, SCM s
, SCM start
, SCM end
),
2481 "@var{proc} is a char->char procedure, it is mapped over\n"
2482 "@var{s}. The order in which the procedure is applied to the\n"
2483 "string elements is not specified. The string @var{s} is\n"
2484 "modified in-place, the return value is not specified.")
2485 #define FUNC_NAME s_scm_string_map_x
2487 size_t cstart
, cend
;
2489 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2490 proc
, SCM_ARG1
, FUNC_NAME
);
2491 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2494 while (cstart
< cend
)
2496 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2497 if (!SCM_CHARP (ch
))
2498 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2499 s
= scm_i_string_start_writing (s
);
2500 scm_i_string_set_x (s
, cstart
, SCM_CHAR (ch
));
2501 scm_i_string_stop_writing ();
2504 return SCM_UNSPECIFIED
;
2509 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2510 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2511 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2512 "as the terminating element, from left to right. @var{kons}\n"
2513 "must expect two arguments: The actual character and the last\n"
2514 "result of @var{kons}' application.")
2515 #define FUNC_NAME s_scm_string_fold
2517 size_t cstart
, cend
;
2520 SCM_VALIDATE_PROC (1, kons
);
2521 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2525 while (cstart
< cend
)
2527 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)), result
);
2531 scm_remember_upto_here_1 (s
);
2537 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2538 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2539 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2540 "as the terminating element, from right to left. @var{kons}\n"
2541 "must expect two arguments: The actual character and the last\n"
2542 "result of @var{kons}' application.")
2543 #define FUNC_NAME s_scm_string_fold_right
2545 size_t cstart
, cend
;
2548 SCM_VALIDATE_PROC (1, kons
);
2549 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2553 while (cstart
< cend
)
2555 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cend
-1)), result
);
2559 scm_remember_upto_here_1 (s
);
2565 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2566 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2567 "@itemize @bullet\n"
2568 "@item @var{g} is used to generate a series of @emph{seed}\n"
2569 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2570 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2572 "@item @var{p} tells us when to stop -- when it returns true\n"
2573 "when applied to one of these seed values.\n"
2574 "@item @var{f} maps each seed value to the corresponding\n"
2575 "character in the result string. These chars are assembled\n"
2576 "into the string in a left-to-right order.\n"
2577 "@item @var{base} is the optional initial/leftmost portion\n"
2578 "of the constructed string; it default to the empty\n"
2580 "@item @var{make_final} is applied to the terminal seed\n"
2581 "value (on which @var{p} returns true) to produce\n"
2582 "the final/rightmost portion of the constructed string.\n"
2583 "It defaults to @code{(lambda (x) "")}.\n"
2585 #define FUNC_NAME s_scm_string_unfold
2589 SCM_VALIDATE_PROC (1, p
);
2590 SCM_VALIDATE_PROC (2, f
);
2591 SCM_VALIDATE_PROC (3, g
);
2592 if (!SCM_UNBNDP (base
))
2594 SCM_VALIDATE_STRING (5, base
);
2598 ans
= scm_i_make_string (0, NULL
);
2599 if (!SCM_UNBNDP (make_final
))
2600 SCM_VALIDATE_PROC (6, make_final
);
2602 res
= scm_call_1 (p
, seed
);
2603 while (scm_is_false (res
))
2607 SCM ch
= scm_call_1 (f
, seed
);
2608 if (!SCM_CHARP (ch
))
2609 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2610 str
= scm_i_make_string (1, NULL
);
2611 str
= scm_i_string_start_writing (str
);
2612 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2613 scm_i_string_stop_writing ();
2616 ans
= scm_string_append (scm_list_2 (ans
, str
));
2617 seed
= scm_call_1 (g
, seed
);
2618 res
= scm_call_1 (p
, seed
);
2620 if (!SCM_UNBNDP (make_final
))
2622 res
= scm_call_1 (make_final
, seed
);
2623 return scm_string_append (scm_list_2 (ans
, res
));
2631 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2632 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2633 "@itemize @bullet\n"
2634 "@item @var{g} is used to generate a series of @emph{seed}\n"
2635 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2636 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2638 "@item @var{p} tells us when to stop -- when it returns true\n"
2639 "when applied to one of these seed values.\n"
2640 "@item @var{f} maps each seed value to the corresponding\n"
2641 "character in the result string. These chars are assembled\n"
2642 "into the string in a right-to-left order.\n"
2643 "@item @var{base} is the optional initial/rightmost portion\n"
2644 "of the constructed string; it default to the empty\n"
2646 "@item @var{make_final} is applied to the terminal seed\n"
2647 "value (on which @var{p} returns true) to produce\n"
2648 "the final/leftmost portion of the constructed string.\n"
2649 "It defaults to @code{(lambda (x) "")}.\n"
2651 #define FUNC_NAME s_scm_string_unfold_right
2655 SCM_VALIDATE_PROC (1, p
);
2656 SCM_VALIDATE_PROC (2, f
);
2657 SCM_VALIDATE_PROC (3, g
);
2658 if (!SCM_UNBNDP (base
))
2660 SCM_VALIDATE_STRING (5, base
);
2664 ans
= scm_i_make_string (0, NULL
);
2665 if (!SCM_UNBNDP (make_final
))
2666 SCM_VALIDATE_PROC (6, make_final
);
2668 res
= scm_call_1 (p
, seed
);
2669 while (scm_is_false (res
))
2673 SCM ch
= scm_call_1 (f
, seed
);
2674 if (!SCM_CHARP (ch
))
2675 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2676 str
= scm_i_make_string (1, NULL
);
2677 str
= scm_i_string_start_writing (str
);
2678 scm_i_string_set_x (str
, i
, SCM_CHAR (ch
));
2679 scm_i_string_stop_writing ();
2682 ans
= scm_string_append (scm_list_2 (str
, ans
));
2683 seed
= scm_call_1 (g
, seed
);
2684 res
= scm_call_1 (p
, seed
);
2686 if (!SCM_UNBNDP (make_final
))
2688 res
= scm_call_1 (make_final
, seed
);
2689 return scm_string_append (scm_list_2 (res
, ans
));
2697 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2698 (SCM proc
, SCM s
, SCM start
, SCM end
),
2699 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2700 "return value is not specified.")
2701 #define FUNC_NAME s_scm_string_for_each
2703 size_t cstart
, cend
;
2705 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2706 proc
, SCM_ARG1
, FUNC_NAME
);
2707 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2710 while (cstart
< cend
)
2712 scm_call_1 (proc
, SCM_MAKE_CHAR (scm_i_string_ref (s
, cstart
)));
2716 scm_remember_upto_here_1 (s
);
2717 return SCM_UNSPECIFIED
;
2721 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2722 (SCM proc
, SCM s
, SCM start
, SCM end
),
2723 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2726 "For example, to change characters to alternately upper and\n"
2730 "(define str (string-copy \"studly\"))\n"
2731 "(string-for-each-index\n"
2733 " (string-set! str i\n"
2734 " ((if (even? i) char-upcase char-downcase)\n"
2735 " (string-ref str i))))\n"
2737 "str @result{} \"StUdLy\"\n"
2739 #define FUNC_NAME s_scm_string_for_each_index
2741 size_t cstart
, cend
;
2743 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)),
2744 proc
, SCM_ARG1
, FUNC_NAME
);
2745 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2749 while (cstart
< cend
)
2751 scm_call_1 (proc
, scm_from_size_t (cstart
));
2755 scm_remember_upto_here_1 (s
);
2756 return SCM_UNSPECIFIED
;
2760 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2761 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2762 "This is the @emph{extended substring} procedure that implements\n"
2763 "replicated copying of a substring of some string.\n"
2765 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2766 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2767 "0 and the length of @var{s}. Replicate this substring up and\n"
2768 "down index space, in both the positive and negative directions.\n"
2769 "@code{xsubstring} returns the substring of this string\n"
2770 "beginning at index @var{from}, and ending at @var{to}, which\n"
2771 "defaults to @var{from} + (@var{end} - @var{start}).")
2772 #define FUNC_NAME s_scm_xsubstring
2775 size_t cstart
, cend
;
2779 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2783 cfrom
= scm_to_int (from
);
2784 if (SCM_UNBNDP (to
))
2785 cto
= cfrom
+ (cend
- cstart
);
2787 cto
= scm_to_int (to
);
2788 if (cstart
== cend
&& cfrom
!= cto
)
2789 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2791 result
= scm_i_make_string (cto
- cfrom
, NULL
);
2792 result
= scm_i_string_start_writing (result
);
2797 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2799 scm_i_string_set_x (result
, p
,
2800 scm_i_string_ref (s
, (cend
- cstart
) - t
));
2802 scm_i_string_set_x (result
, p
, scm_i_string_ref (s
, t
));
2806 scm_i_string_stop_writing ();
2808 scm_remember_upto_here_1 (s
);
2814 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2815 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2816 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2817 "is written into the string @var{target} starting at index\n"
2818 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2819 "@var{target} @var{s})} or these arguments share storage -- you\n"
2820 "cannot copy a string on top of itself.")
2821 #define FUNC_NAME s_scm_string_xcopy_x
2824 size_t ctstart
, cstart
, cend
;
2826 SCM dummy
= SCM_UNDEFINED
;
2829 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
2832 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
2835 csfrom
= scm_to_int (sfrom
);
2836 if (SCM_UNBNDP (sto
))
2837 csto
= csfrom
+ (cend
- cstart
);
2839 csto
= scm_to_int (sto
);
2840 if (cstart
== cend
&& csfrom
!= csto
)
2841 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2842 SCM_ASSERT_RANGE (1, tstart
,
2843 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
2846 target
= scm_i_string_start_writing (target
);
2847 while (csfrom
< csto
)
2849 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2851 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, (cend
- cstart
) - t
));
2853 scm_i_string_set_x (target
, p
+ cstart
, scm_i_string_ref (s
, t
));
2857 scm_i_string_stop_writing ();
2859 scm_remember_upto_here_2 (target
, s
);
2860 return SCM_UNSPECIFIED
;
2865 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2866 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2867 "Return the string @var{s1}, but with the characters\n"
2868 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2869 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2870 #define FUNC_NAME s_scm_string_replace
2872 size_t cstart1
, cend1
, cstart2
, cend2
;
2875 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
2878 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
2881 return (scm_string_append
2882 (scm_list_3 (scm_i_substring (s1
, 0, cstart1
),
2883 scm_i_substring (s2
, cstart2
, cend2
),
2884 scm_i_substring (s1
, cend1
, scm_i_string_length (s1
)))));
2890 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2891 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2892 "Split the string @var{s} into a list of substrings, where each\n"
2893 "substring is a maximal non-empty contiguous sequence of\n"
2894 "characters from the character set @var{token_set}, which\n"
2895 "defaults to @code{char-set:graphic}.\n"
2896 "If @var{start} or @var{end} indices are provided, they restrict\n"
2897 "@code{string-tokenize} to operating on the indicated substring\n"
2899 #define FUNC_NAME s_scm_string_tokenize
2901 size_t cstart
, cend
;
2902 SCM result
= SCM_EOL
;
2904 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
2908 if (SCM_UNBNDP (token_set
))
2909 token_set
= scm_char_set_graphic
;
2911 if (SCM_CHARSETP (token_set
))
2915 while (cstart
< cend
)
2917 while (cstart
< cend
)
2919 if (REF_IN_CHARSET (s
, cend
-1, token_set
))
2926 while (cstart
< cend
)
2928 if (!REF_IN_CHARSET (s
, cend
-1, token_set
))
2932 result
= scm_cons (scm_i_substring (s
, cend
, idx
), result
);
2936 SCM_WRONG_TYPE_ARG (2, token_set
);
2938 scm_remember_upto_here_1 (s
);
2943 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
2945 "Split the string @var{str} into the a list of the substrings delimited\n"
2946 "by appearances of the character @var{chr}. Note that an empty substring\n"
2947 "between separator characters will result in an empty string in the\n"
2951 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2953 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2955 "(string-split \"::\" #\\:)\n"
2957 "(\"\" \"\" \"\")\n"
2959 "(string-split \"\" #\\:)\n"
2963 #define FUNC_NAME s_scm_string_split
2969 SCM_VALIDATE_STRING (1, str
);
2970 SCM_VALIDATE_CHAR (2, chr
);
2972 /* This is explicit wide/narrow logic (instead of using
2973 scm_i_string_ref) is a speed optimization. */
2974 idx
= scm_i_string_length (str
);
2975 narrow
= scm_i_is_narrow_string (str
);
2978 const char *buf
= scm_i_string_chars (str
);
2982 while (idx
> 0 && buf
[idx
-1] != (char) SCM_CHAR(chr
))
2986 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
2993 const scm_t_wchar
*buf
= scm_i_string_wide_chars (str
);
2997 while (idx
> 0 && buf
[idx
-1] != SCM_CHAR(chr
))
3001 res
= scm_cons (scm_i_substring (str
, idx
, last_idx
), res
);
3006 scm_remember_upto_here_1 (str
);
3012 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3013 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3014 "Filter the string @var{s}, retaining only those characters\n"
3015 "which satisfy @var{char_pred}.\n"
3017 "If @var{char_pred} is a procedure, it is applied to each\n"
3018 "character as a predicate, if it is a character, it is tested\n"
3019 "for equality and if it is a character set, it is tested for\n"
3021 #define FUNC_NAME s_scm_string_filter
3023 size_t cstart
, cend
;
3027 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3031 /* The explicit loops below stripping leading and trailing non-matches
3032 mean we can return a substring if those are the only deletions, making
3033 string-filter as efficient as string-trim-both in that case. */
3035 if (SCM_CHARP (char_pred
))
3039 /* strip leading non-matches by incrementing cstart */
3040 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) != SCM_CHAR (char_pred
))
3043 /* strip trailing non-matches by decrementing cend */
3044 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) != SCM_CHAR (char_pred
))
3047 /* count chars to keep */
3049 for (idx
= cstart
; idx
< cend
; idx
++)
3050 if (scm_i_string_ref (s
, idx
) == SCM_CHAR (char_pred
))
3053 if (count
== cend
- cstart
)
3055 /* whole of cstart to cend is to be kept, return a copy-on-write
3058 result
= scm_i_substring (s
, cstart
, cend
);
3061 result
= scm_c_make_string (count
, char_pred
);
3063 else if (SCM_CHARSETP (char_pred
))
3067 /* strip leading non-matches by incrementing cstart */
3068 while (cstart
< cend
&& ! REF_IN_CHARSET (s
, cstart
, char_pred
))
3071 /* strip trailing non-matches by decrementing cend */
3072 while (cend
> cstart
&& ! REF_IN_CHARSET (s
, cend
-1, char_pred
))
3075 /* count chars to be kept */
3077 for (idx
= cstart
; idx
< cend
; idx
++)
3078 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3081 /* if whole of start to end kept then return substring */
3082 if (count
== cend
- cstart
)
3083 goto result_substring
;
3087 result
= scm_i_make_string (count
, NULL
);
3088 result
= scm_i_string_start_writing (result
);
3090 /* decrement "count" in this loop as well as using idx, so that if
3091 another thread is simultaneously changing "s" there's no chance
3092 it'll make us copy more than count characters */
3093 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3095 if (REF_IN_CHARSET (s
, idx
, char_pred
))
3097 scm_i_string_set_x (result
, dst
, scm_i_string_ref (s
, idx
));
3102 scm_i_string_stop_writing ();
3109 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3110 char_pred
, SCM_ARG2
, FUNC_NAME
);
3115 ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3116 res
= scm_call_1 (char_pred
, ch
);
3117 if (scm_is_true (res
))
3118 ls
= scm_cons (ch
, ls
);
3121 result
= scm_reverse_list_to_string (ls
);
3124 scm_remember_upto_here_1 (s
);
3130 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3131 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3132 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
3134 "If @var{char_pred} is a procedure, it is applied to each\n"
3135 "character as a predicate, if it is a character, it is tested\n"
3136 "for equality and if it is a character set, it is tested for\n"
3138 #define FUNC_NAME s_scm_string_delete
3140 size_t cstart
, cend
;
3144 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3148 /* The explicit loops below stripping leading and trailing matches mean we
3149 can return a substring if those are the only deletions, making
3150 string-delete as efficient as string-trim-both in that case. */
3152 if (SCM_CHARP (char_pred
))
3156 /* strip leading matches by incrementing cstart */
3157 while (cstart
< cend
&& scm_i_string_ref (s
, cstart
) == SCM_CHAR(char_pred
))
3160 /* strip trailing matches by decrementing cend */
3161 while (cend
> cstart
&& scm_i_string_ref (s
, cend
-1) == SCM_CHAR (char_pred
))
3164 /* count chars to be kept */
3166 for (idx
= cstart
; idx
< cend
; idx
++)
3167 if (scm_i_string_ref (s
, idx
) != SCM_CHAR (char_pred
))
3170 if (count
== cend
- cstart
)
3172 /* whole of cstart to cend is to be kept, return a copy-on-write
3175 result
= scm_i_substring (s
, cstart
, cend
);
3180 /* new string for retained portion */
3181 result
= scm_i_make_string (count
, NULL
);
3182 result
= scm_i_string_start_writing (result
);
3183 /* decrement "count" in this loop as well as using idx, so that if
3184 another thread is simultaneously changing "s" there's no chance
3185 it'll make us copy more than count characters */
3186 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3188 scm_t_wchar c
= scm_i_string_ref (s
, idx
);
3189 if (c
!= SCM_CHAR (char_pred
))
3191 scm_i_string_set_x (result
, i
, c
);
3196 scm_i_string_stop_writing ();
3199 else if (SCM_CHARSETP (char_pred
))
3203 /* strip leading matches by incrementing cstart */
3204 while (cstart
< cend
&& REF_IN_CHARSET (s
, cstart
, char_pred
))
3207 /* strip trailing matches by decrementing cend */
3208 while (cend
> cstart
&& REF_IN_CHARSET (s
, cend
-1, char_pred
))
3211 /* count chars to be kept */
3213 for (idx
= cstart
; idx
< cend
; idx
++)
3214 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3217 if (count
== cend
- cstart
)
3218 goto result_substring
;
3222 /* new string for retained portion */
3223 result
= scm_i_make_string (count
, NULL
);
3224 result
= scm_i_string_start_writing (result
);
3226 /* decrement "count" in this loop as well as using idx, so that if
3227 another thread is simultaneously changing "s" there's no chance
3228 it'll make us copy more than count characters */
3229 for (idx
= cstart
; idx
< cend
&& count
!= 0; idx
++)
3231 if (!REF_IN_CHARSET (s
, idx
, char_pred
))
3233 scm_i_string_set_x (result
, i
, scm_i_string_ref (s
, idx
));
3238 scm_i_string_stop_writing ();
3244 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred
)),
3245 char_pred
, SCM_ARG2
, FUNC_NAME
);
3250 SCM res
, ch
= SCM_MAKE_CHAR (scm_i_string_ref (s
, idx
));
3251 res
= scm_call_1 (char_pred
, ch
);
3252 if (scm_is_false (res
))
3253 ls
= scm_cons (ch
, ls
);
3256 result
= scm_reverse_list_to_string (ls
);
3259 scm_remember_upto_here_1 (s
);
3265 scm_init_srfi_13 (void)
3267 #include "libguile/srfi-13.x"
3270 /* End of srfi-13.c. */