1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
26 #include "libguile/srfi-13.h"
27 #include "libguile/srfi-14.h"
29 /* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
30 messing with the internal representation of strings. We define our
31 own version since we use it so much and are messing with Guile
35 #define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 c_str = scm_i_string_chars (str); \
41 scm_i_get_substring_spec (scm_i_string_length (str), \
42 start, &c_start, end, &c_end); \
45 #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
46 pos_start, start, c_start, \
47 pos_end, end, c_end) \
49 SCM_VALIDATE_STRING (pos_str, str); \
50 scm_i_get_substring_spec (scm_i_string_length (str), \
51 start, &c_start, end, &c_end); \
54 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
56 "Return @code{#t} if @var{str}'s length is zero, and\n"
57 "@code{#f} otherwise.\n"
59 "(string-null? \"\") @result{} #t\n"
60 "y @result{} \"foo\"\n"
61 "(string-null? y) @result{} #f\n"
63 #define FUNC_NAME s_scm_string_null_p
65 SCM_VALIDATE_STRING (1, str
);
66 return scm_from_bool (scm_i_string_length (str
) == 0);
74 scm_misc_error (NULL
, "race condition detected", SCM_EOL
);
78 SCM_DEFINE (scm_string_any
, "string-any-c-code", 2, 2, 0,
79 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
80 "Check if the predicate @var{pred} is true for any character in\n"
81 "the string @var{s}.\n"
83 "Calls to @var{pred} are made from left to right across @var{s}.\n"
84 "When it returns true (ie.@: non-@code{#f}), that return value\n"
85 "is the return from @code{string-any}.\n"
87 "The SRFI-13 specification requires that the call to @var{pred}\n"
88 "on the last character of @var{s} (assuming that point is\n"
89 "reached) be a tail call, but currently in Guile this is not the\n"
91 #define FUNC_NAME s_scm_string_any
97 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
101 if (SCM_CHARP (char_pred
))
103 res
= (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
105 ? SCM_BOOL_F
: SCM_BOOL_T
);
107 else if (SCM_CHARSETP (char_pred
))
110 for (i
= cstart
; i
< cend
; i
++)
111 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
119 SCM_VALIDATE_PROC (1, char_pred
);
121 while (cstart
< cend
)
123 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
124 if (scm_is_true (res
))
126 cstr
= scm_i_string_chars (s
);
131 scm_remember_upto_here_1 (s
);
137 SCM_DEFINE (scm_string_every
, "string-every-c-code", 2, 2, 0,
138 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
139 "Check if the predicate @var{pred} is true for every character\n"
140 "in the string @var{s}.\n"
142 "Calls to @var{pred} are made from left to right across @var{s}.\n"
143 "If the predicate is true for every character then the return\n"
144 "value from the last @var{pred} call is the return from\n"
145 "@code{string-every}.\n"
147 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
148 "@var{end}) then the return is @code{#t}.\n"
150 "The SRFI-13 specification requires that the call to @var{pred}\n"
151 "on the last character of @var{s} (assuming that point is\n"
152 "reached) be a tail call, but currently in Guile this is not the\n"
154 #define FUNC_NAME s_scm_string_every
158 SCM res
= SCM_BOOL_T
;
160 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
163 if (SCM_CHARP (char_pred
))
165 char cchr
= SCM_CHAR (char_pred
);
167 for (i
= cstart
; i
< cend
; i
++)
174 else if (SCM_CHARSETP (char_pred
))
177 for (i
= cstart
; i
< cend
; i
++)
178 if (!SCM_CHARSET_GET (char_pred
, cstr
[i
]))
186 SCM_VALIDATE_PROC (1, char_pred
);
188 while (cstart
< cend
)
190 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
191 if (scm_is_false (res
))
193 cstr
= scm_i_string_chars (s
);
198 scm_remember_upto_here_1 (s
);
204 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
206 "@var{proc} is an integer->char procedure. Construct a string\n"
207 "of size @var{len} by applying @var{proc} to each index to\n"
208 "produce the corresponding string element. The order in which\n"
209 "@var{proc} is applied to the indices is not specified.")
210 #define FUNC_NAME s_scm_string_tabulate
217 SCM_VALIDATE_PROC (1, proc
);
218 clen
= scm_to_size_t (len
);
219 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
221 res
= scm_i_make_string (clen
, &p
);
225 /* The RES string remains untouched since nobody knows about it
226 yet. No need to refetch P.
228 ch
= scm_call_1 (proc
, scm_from_size_t (i
));
230 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
231 *p
++ = SCM_CHAR (ch
);
239 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
240 (SCM str
, SCM start
, SCM end
),
241 "Convert the string @var{str} into a list of characters.")
242 #define FUNC_NAME s_scm_substring_to_list
246 SCM result
= SCM_EOL
;
248 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
251 while (cstart
< cend
)
254 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
255 cstr
= scm_i_string_chars (str
);
257 scm_remember_upto_here_1 (str
);
262 /* We export scm_substring_to_list as "string->list" since it is
263 compatible and more general. This function remains for the benefit
264 of C code that used it.
268 scm_string_to_list (SCM str
)
270 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
273 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
275 "An efficient implementation of @code{(compose string->list\n"
279 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
281 #define FUNC_NAME s_scm_reverse_list_to_string
284 long i
= scm_ilength (chrs
);
288 SCM_WRONG_TYPE_ARG (1, chrs
);
289 result
= scm_i_make_string (i
, &data
);
294 while (i
> 0 && scm_is_pair (chrs
))
296 SCM elt
= SCM_CAR (chrs
);
298 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
300 *data
= SCM_CHAR (elt
);
301 chrs
= SCM_CDR (chrs
);
311 SCM_SYMBOL (scm_sym_infix
, "infix");
312 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
313 SCM_SYMBOL (scm_sym_suffix
, "suffix");
314 SCM_SYMBOL (scm_sym_prefix
, "prefix");
317 append_string (char **sp
, size_t *lp
, SCM str
)
320 len
= scm_c_string_length (str
);
323 memcpy (*sp
, scm_i_string_chars (str
), len
);
328 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
329 (SCM ls
, SCM delimiter
, SCM grammar
),
330 "Append the string in the string list @var{ls}, using the string\n"
331 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
332 "@var{grammar} is a symbol which specifies how the delimiter is\n"
333 "placed between the strings, and defaults to the symbol\n"
338 "Insert the separator between list elements. An empty string\n"
339 "will produce an empty list.\n"
340 "@item string-infix\n"
341 "Like @code{infix}, but will raise an error if given the empty\n"
344 "Insert the separator after every list element.\n"
346 "Insert the separator before each list element.\n"
348 #define FUNC_NAME s_scm_string_join
351 #define GRAM_STRICT_INFIX 1
352 #define GRAM_SUFFIX 2
353 #define GRAM_PREFIX 3
356 int gram
= GRAM_INFIX
;
360 long strings
= scm_ilength (ls
);
362 /* Validate the string list. */
364 SCM_WRONG_TYPE_ARG (1, ls
);
366 /* Validate the delimiter and record its length. */
367 if (SCM_UNBNDP (delimiter
))
369 delimiter
= scm_from_locale_string (" ");
373 del_len
= scm_c_string_length (delimiter
);
375 /* Validate the grammar symbol and remember the grammar. */
376 if (SCM_UNBNDP (grammar
))
378 else if (scm_is_eq (grammar
, scm_sym_infix
))
380 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
381 gram
= GRAM_STRICT_INFIX
;
382 else if (scm_is_eq (grammar
, scm_sym_suffix
))
384 else if (scm_is_eq (grammar
, scm_sym_prefix
))
387 SCM_WRONG_TYPE_ARG (3, grammar
);
389 /* Check grammar constraints and calculate the space required for
394 if (!scm_is_null (ls
))
395 len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
397 case GRAM_STRICT_INFIX
:
399 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
401 len
= (strings
- 1) * del_len
;
404 len
= strings
* del_len
;
409 while (scm_is_pair (tmp
))
411 len
+= scm_c_string_length (SCM_CAR (tmp
));
415 result
= scm_i_make_string (len
, &p
);
421 case GRAM_STRICT_INFIX
:
422 while (scm_is_pair (tmp
))
424 append_string (&p
, &len
, SCM_CAR (tmp
));
425 if (!scm_is_null (SCM_CDR (tmp
)) && del_len
> 0)
426 append_string (&p
, &len
, delimiter
);
431 while (scm_is_pair (tmp
))
433 append_string (&p
, &len
, SCM_CAR (tmp
));
435 append_string (&p
, &len
, delimiter
);
440 while (scm_is_pair (tmp
))
443 append_string (&p
, &len
, delimiter
);
444 append_string (&p
, &len
, SCM_CAR (tmp
));
452 #undef GRAM_STRICT_INFIX
459 /* There are a number of functions to consider here for Scheme and C:
461 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
462 substring/copy STR start [end] ;; Guile variant of R5RS substring
464 scm_string_copy (str) ;; Old function from Guile
465 scm_substring_copy (str, [start, [end]])
466 ;; C version of SRFI-13 string-copy
467 ;; and C version of substring/copy
469 The C function underlying string-copy is not exported to C
470 programs. scm_substring_copy is defined in strings.c as the
471 underlying function of substring/copy and allows an optional START
475 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
477 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
478 (SCM str
, SCM start
, SCM end
),
479 "Return a freshly allocated copy of the string @var{str}. If\n"
480 "given, @var{start} and @var{end} delimit the portion of\n"
481 "@var{str} which is copied.")
482 #define FUNC_NAME s_scm_srfi13_substring_copy
487 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
490 return scm_c_substring_copy (str
, cstart
, cend
);
495 scm_string_copy (SCM str
)
497 return scm_c_substring (str
, 0, scm_c_string_length (str
));
500 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
501 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
502 "Copy the sequence of characters from index range [@var{start},\n"
503 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
504 "at index @var{tstart}. The characters are copied left-to-right\n"
505 "or right-to-left as needed -- the copy is guaranteed to work,\n"
506 "even if @var{target} and @var{s} are the same string. It is an\n"
507 "error if the copy operation runs off the end of the target\n"
509 #define FUNC_NAME s_scm_string_copy_x
513 size_t cstart
, cend
, ctstart
, dummy
, len
;
514 SCM sdummy
= SCM_UNDEFINED
;
516 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
519 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
523 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
525 ctarget
= scm_i_string_writable_chars (target
);
526 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
527 scm_i_string_stop_writing ();
528 scm_remember_upto_here_1 (target
);
530 return SCM_UNSPECIFIED
;
534 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
535 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
536 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
537 "into @var{str2} beginning at position @var{start2}.\n"
538 "@var{str1} and @var{str2} can be the same string.")
539 #define FUNC_NAME s_scm_substring_move_x
541 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
545 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
547 "Return the @var{n} first characters of @var{s}.")
548 #define FUNC_NAME s_scm_string_take
550 return scm_substring (s
, SCM_INUM0
, n
);
555 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
557 "Return all but the first @var{n} characters of @var{s}.")
558 #define FUNC_NAME s_scm_string_drop
560 return scm_substring (s
, n
, SCM_UNDEFINED
);
565 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
567 "Return the @var{n} last characters of @var{s}.")
568 #define FUNC_NAME s_scm_string_take_right
570 return scm_substring (s
,
571 scm_difference (scm_string_length (s
), n
),
577 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
579 "Return all but the last @var{n} characters of @var{s}.")
580 #define FUNC_NAME s_scm_string_drop_right
582 return scm_substring (s
,
584 scm_difference (scm_string_length (s
), n
));
589 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
590 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
591 "Take that characters from @var{start} to @var{end} from the\n"
592 "string @var{s} and return a new string, right-padded by the\n"
593 "character @var{chr} to length @var{len}. If the resulting\n"
594 "string is longer than @var{len}, it is truncated on the right.")
595 #define FUNC_NAME s_scm_string_pad
598 size_t cstart
, cend
, clen
;
600 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
603 clen
= scm_to_size_t (len
);
605 if (SCM_UNBNDP (chr
))
609 SCM_VALIDATE_CHAR (3, chr
);
610 cchr
= SCM_CHAR (chr
);
612 if (clen
< (cend
- cstart
))
613 return scm_c_substring (s
, cend
- clen
, cend
);
619 result
= scm_i_make_string (clen
, &dst
);
620 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
621 memmove (dst
+ clen
- (cend
- cstart
),
622 scm_i_string_chars (s
) + cstart
, cend
- cstart
);
629 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
630 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
631 "Take that characters from @var{start} to @var{end} from the\n"
632 "string @var{s} and return a new string, left-padded by the\n"
633 "character @var{chr} to length @var{len}. If the resulting\n"
634 "string is longer than @var{len}, it is truncated on the left.")
635 #define FUNC_NAME s_scm_string_pad_right
638 size_t cstart
, cend
, clen
;
640 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
643 clen
= scm_to_size_t (len
);
645 if (SCM_UNBNDP (chr
))
649 SCM_VALIDATE_CHAR (3, chr
);
650 cchr
= SCM_CHAR (chr
);
652 if (clen
< (cend
- cstart
))
653 return scm_c_substring (s
, cstart
, cstart
+ clen
);
659 result
= scm_i_make_string (clen
, &dst
);
660 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
661 memmove (dst
, scm_i_string_chars (s
) + cstart
, cend
- cstart
);
668 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
669 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
670 "Trim @var{s} by skipping over all characters on the left\n"
671 "that satisfy the parameter @var{char_pred}:\n"
675 "if it is the character @var{ch}, characters equal to\n"
676 "@var{ch} are trimmed,\n"
679 "if it is a procedure @var{pred} characters that\n"
680 "satisfy @var{pred} are trimmed,\n"
683 "if it is a character set, characters in that set are trimmed.\n"
686 "If called without a @var{char_pred} argument, all whitespace is\n"
688 #define FUNC_NAME s_scm_string_trim
693 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
696 if (SCM_UNBNDP (char_pred
))
698 while (cstart
< cend
)
700 if (!isspace((int) (unsigned char) cstr
[cstart
]))
705 else if (SCM_CHARP (char_pred
))
707 char chr
= SCM_CHAR (char_pred
);
708 while (cstart
< cend
)
710 if (chr
!= cstr
[cstart
])
715 else if (SCM_CHARSETP (char_pred
))
717 while (cstart
< cend
)
719 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
726 SCM_VALIDATE_PROC (2, char_pred
);
727 while (cstart
< cend
)
731 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
732 if (scm_is_false (res
))
734 cstr
= scm_i_string_chars (s
);
738 return scm_c_substring (s
, cstart
, cend
);
743 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
744 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
745 "Trim @var{s} by skipping over all characters on the rightt\n"
746 "that satisfy the parameter @var{char_pred}:\n"
750 "if it is the character @var{ch}, characters equal to @var{ch}\n"
754 "if it is a procedure @var{pred} characters that satisfy\n"
755 "@var{pred} are trimmed,\n"
758 "if it is a character sets, all characters in that set are\n"
762 "If called without a @var{char_pred} argument, all whitespace is\n"
764 #define FUNC_NAME s_scm_string_trim_right
769 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
772 if (SCM_UNBNDP (char_pred
))
774 while (cstart
< cend
)
776 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
781 else if (SCM_CHARP (char_pred
))
783 char chr
= SCM_CHAR (char_pred
);
784 while (cstart
< cend
)
786 if (chr
!= cstr
[cend
- 1])
791 else if (SCM_CHARSETP (char_pred
))
793 while (cstart
< cend
)
795 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
802 SCM_VALIDATE_PROC (2, char_pred
);
803 while (cstart
< cend
)
807 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
808 if (scm_is_false (res
))
810 cstr
= scm_i_string_chars (s
);
814 return scm_c_substring (s
, cstart
, cend
);
819 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
820 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
821 "Trim @var{s} by skipping over all characters on both sides of\n"
822 "the string that satisfy the parameter @var{char_pred}:\n"
826 "if it is the character @var{ch}, characters equal to @var{ch}\n"
830 "if it is a procedure @var{pred} characters that satisfy\n"
831 "@var{pred} are trimmed,\n"
834 "if it is a character set, the characters in the set are\n"
838 "If called without a @var{char_pred} argument, all whitespace is\n"
840 #define FUNC_NAME s_scm_string_trim_both
845 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
848 if (SCM_UNBNDP (char_pred
))
850 while (cstart
< cend
)
852 if (!isspace((int) (unsigned char) cstr
[cstart
]))
856 while (cstart
< cend
)
858 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
863 else if (SCM_CHARP (char_pred
))
865 char chr
= SCM_CHAR (char_pred
);
866 while (cstart
< cend
)
868 if (chr
!= cstr
[cstart
])
872 while (cstart
< cend
)
874 if (chr
!= cstr
[cend
- 1])
879 else if (SCM_CHARSETP (char_pred
))
881 while (cstart
< cend
)
883 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
887 while (cstart
< cend
)
889 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
896 SCM_VALIDATE_PROC (2, char_pred
);
897 while (cstart
< cend
)
901 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
902 if (scm_is_false (res
))
904 cstr
= scm_i_string_chars (s
);
907 while (cstart
< cend
)
911 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
912 if (scm_is_false (res
))
914 cstr
= scm_i_string_chars (s
);
918 return scm_c_substring (s
, cstart
, cend
);
923 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
924 (SCM str
, SCM chr
, SCM start
, SCM end
),
925 "Stores @var{chr} in every element of the given @var{str} and\n"
926 "returns an unspecified value.")
927 #define FUNC_NAME s_scm_substring_fill_x
934 /* Older versions of Guile provided the function
935 scm_substring_fill_x with the following order of arguments:
939 We accomodate this here by detecting such a usage and reordering
950 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
953 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
955 cstr
= scm_i_string_writable_chars (str
);
956 for (k
= cstart
; k
< cend
; k
++)
958 scm_i_string_stop_writing ();
959 scm_remember_upto_here_1 (str
);
961 return SCM_UNSPECIFIED
;
966 scm_string_fill_x (SCM str
, SCM chr
)
968 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
971 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
972 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
973 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
974 "mismatch index, depending upon whether @var{s1} is less than,\n"
975 "equal to, or greater than @var{s2}. The mismatch index is the\n"
976 "largest index @var{i} such that for every 0 <= @var{j} <\n"
977 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
978 "@var{i} is the first position that does not match.")
979 #define FUNC_NAME s_scm_string_compare
981 const char *cstr1
, *cstr2
;
982 size_t cstart1
, cend1
, cstart2
, cend2
;
985 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
988 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
991 SCM_VALIDATE_PROC (3, proc_lt
);
992 SCM_VALIDATE_PROC (4, proc_eq
);
993 SCM_VALIDATE_PROC (5, proc_gt
);
995 while (cstart1
< cend1
&& cstart2
< cend2
)
997 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1002 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1010 if (cstart1
< cend1
)
1012 else if (cstart2
< cend2
)
1018 scm_remember_upto_here_2 (s1
, s2
);
1019 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1024 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1025 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1026 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1027 "mismatch index, depending upon whether @var{s1} is less than,\n"
1028 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1029 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1030 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1031 "@var{i} is the first position that does not match. The\n"
1032 "character comparison is done case-insensitively.")
1033 #define FUNC_NAME s_scm_string_compare_ci
1035 const char *cstr1
, *cstr2
;
1036 size_t cstart1
, cend1
, cstart2
, cend2
;
1039 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1042 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1045 SCM_VALIDATE_PROC (3, proc_lt
);
1046 SCM_VALIDATE_PROC (4, proc_eq
);
1047 SCM_VALIDATE_PROC (5, proc_gt
);
1049 while (cstart1
< cend1
&& cstart2
< cend2
)
1051 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1056 else if (scm_c_downcase (cstr1
[cstart1
])
1057 > scm_c_downcase (cstr2
[cstart2
]))
1066 if (cstart1
< cend1
)
1068 else if (cstart2
< cend2
)
1074 scm_remember_upto_here (s1
, s2
);
1075 return scm_call_1 (proc
, scm_from_size_t (cstart1
));
1080 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1081 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1082 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1084 #define FUNC_NAME s_scm_string_eq
1086 const char *cstr1
, *cstr2
;
1087 size_t cstart1
, cend1
, cstart2
, cend2
;
1089 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1092 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1096 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1099 while (cstart1
< cend1
)
1101 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1103 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1109 scm_remember_upto_here_2 (s1
, s2
);
1110 return scm_from_size_t (cstart1
);
1113 scm_remember_upto_here_2 (s1
, s2
);
1119 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1120 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1121 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1123 #define FUNC_NAME s_scm_string_neq
1125 const char *cstr1
, *cstr2
;
1126 size_t cstart1
, cend1
, cstart2
, cend2
;
1128 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1131 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1135 while (cstart1
< cend1
&& cstart2
< cend2
)
1137 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1139 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1144 if (cstart1
< cend1
)
1146 else if (cstart2
< cend2
)
1152 scm_remember_upto_here_2 (s1
, s2
);
1153 return scm_from_size_t (cstart1
);
1156 scm_remember_upto_here_2 (s1
, s2
);
1162 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1163 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1164 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1165 "true value otherwise.")
1166 #define FUNC_NAME s_scm_string_lt
1168 const char *cstr1
, *cstr2
;
1169 size_t cstart1
, cend1
, cstart2
, cend2
;
1171 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1174 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1178 while (cstart1
< cend1
&& cstart2
< cend2
)
1180 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1182 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1187 if (cstart1
< cend1
)
1189 else if (cstart2
< cend2
)
1195 scm_remember_upto_here_2 (s1
, s2
);
1196 return scm_from_size_t (cstart1
);
1199 scm_remember_upto_here_2 (s1
, s2
);
1205 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1206 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1207 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1208 "true value otherwise.")
1209 #define FUNC_NAME s_scm_string_gt
1211 const char *cstr1
, *cstr2
;
1212 size_t cstart1
, cend1
, cstart2
, cend2
;
1214 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1217 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1221 while (cstart1
< cend1
&& cstart2
< cend2
)
1223 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1225 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1230 if (cstart1
< cend1
)
1232 else if (cstart2
< cend2
)
1238 scm_remember_upto_here_2 (s1
, s2
);
1239 return scm_from_size_t (cstart1
);
1242 scm_remember_upto_here_2 (s1
, s2
);
1248 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1249 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1250 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1252 #define FUNC_NAME s_scm_string_le
1254 const char *cstr1
, *cstr2
;
1255 size_t cstart1
, cend1
, cstart2
, cend2
;
1257 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1260 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1264 while (cstart1
< cend1
&& cstart2
< cend2
)
1266 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1268 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1273 if (cstart1
< cend1
)
1275 else if (cstart2
< cend2
)
1281 scm_remember_upto_here_2 (s1
, s2
);
1282 return scm_from_size_t (cstart1
);
1285 scm_remember_upto_here_2 (s1
, s2
);
1291 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1292 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1293 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1295 #define FUNC_NAME s_scm_string_ge
1297 const char *cstr1
, *cstr2
;
1298 size_t cstart1
, cend1
, cstart2
, cend2
;
1300 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1303 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1307 while (cstart1
< cend1
&& cstart2
< cend2
)
1309 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1311 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1316 if (cstart1
< cend1
)
1318 else if (cstart2
< cend2
)
1324 scm_remember_upto_here_2 (s1
, s2
);
1325 return scm_from_size_t (cstart1
);
1328 scm_remember_upto_here_2 (s1
, s2
);
1334 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1335 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1336 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1337 "value otherwise. The character comparison is done\n"
1338 "case-insensitively.")
1339 #define FUNC_NAME s_scm_string_ci_eq
1341 const char *cstr1
, *cstr2
;
1342 size_t cstart1
, cend1
, cstart2
, cend2
;
1344 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1347 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1351 while (cstart1
< cend1
&& cstart2
< cend2
)
1353 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1355 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1360 if (cstart1
< cend1
)
1362 else if (cstart2
< cend2
)
1368 scm_remember_upto_here_2 (s1
, s2
);
1369 return scm_from_size_t (cstart1
);
1372 scm_remember_upto_here_2 (s1
, s2
);
1378 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1379 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1380 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1381 "value otherwise. The character comparison is done\n"
1382 "case-insensitively.")
1383 #define FUNC_NAME s_scm_string_ci_neq
1385 const char *cstr1
, *cstr2
;
1386 size_t cstart1
, cend1
, cstart2
, cend2
;
1388 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1391 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1395 while (cstart1
< cend1
&& cstart2
< cend2
)
1397 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1399 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1404 if (cstart1
< cend1
)
1406 else if (cstart2
< cend2
)
1412 scm_remember_upto_here_2 (s1
, s2
);
1413 return scm_from_size_t (cstart1
);
1416 scm_remember_upto_here_2 (s1
, s2
);
1422 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1423 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1424 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1425 "true value otherwise. The character comparison is done\n"
1426 "case-insensitively.")
1427 #define FUNC_NAME s_scm_string_ci_lt
1429 const char *cstr1
, *cstr2
;
1430 size_t cstart1
, cend1
, cstart2
, cend2
;
1432 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1435 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1439 while (cstart1
< cend1
&& cstart2
< cend2
)
1441 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1443 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1448 if (cstart1
< cend1
)
1450 else if (cstart2
< cend2
)
1456 scm_remember_upto_here_2 (s1
, s2
);
1457 return scm_from_size_t (cstart1
);
1460 scm_remember_upto_here_2 (s1
, s2
);
1466 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1467 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1468 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1469 "true value otherwise. The character comparison is done\n"
1470 "case-insensitively.")
1471 #define FUNC_NAME s_scm_string_ci_gt
1473 const char *cstr1
, *cstr2
;
1474 size_t cstart1
, cend1
, cstart2
, cend2
;
1476 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1479 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1483 while (cstart1
< cend1
&& cstart2
< cend2
)
1485 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1487 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1492 if (cstart1
< cend1
)
1494 else if (cstart2
< cend2
)
1500 scm_remember_upto_here_2 (s1
, s2
);
1501 return scm_from_size_t (cstart1
);
1504 scm_remember_upto_here_2 (s1
, s2
);
1510 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1511 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1512 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1513 "value otherwise. The character comparison is done\n"
1514 "case-insensitively.")
1515 #define FUNC_NAME s_scm_string_ci_le
1517 const char *cstr1
, *cstr2
;
1518 size_t cstart1
, cend1
, cstart2
, cend2
;
1520 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1523 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1527 while (cstart1
< cend1
&& cstart2
< cend2
)
1529 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1531 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1536 if (cstart1
< cend1
)
1538 else if (cstart2
< cend2
)
1544 scm_remember_upto_here_2 (s1
, s2
);
1545 return scm_from_size_t (cstart1
);
1548 scm_remember_upto_here_2 (s1
, s2
);
1554 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1555 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1556 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1557 "otherwise. The character comparison is done\n"
1558 "case-insensitively.")
1559 #define FUNC_NAME s_scm_string_ci_ge
1561 const char *cstr1
, *cstr2
;
1562 size_t cstart1
, cend1
, cstart2
, cend2
;
1564 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1567 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1571 while (cstart1
< cend1
&& cstart2
< cend2
)
1573 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1575 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1580 if (cstart1
< cend1
)
1582 else if (cstart2
< cend2
)
1588 scm_remember_upto_here_2 (s1
, s2
);
1589 return scm_from_size_t (cstart1
);
1592 scm_remember_upto_here_2 (s1
, s2
);
1597 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1598 (SCM s
, SCM bound
, SCM start
, SCM end
),
1599 "Compute a hash value for @var{S}. the optional argument "
1600 "@var{bound} is a non-negative exact "
1601 "integer specifying the range of the hash function. "
1602 "A positive value restricts the return value to the "
1604 #define FUNC_NAME s_scm_substring_hash
1606 if (SCM_UNBNDP (bound
))
1607 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1608 if (SCM_UNBNDP (start
))
1610 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1614 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1615 (SCM s
, SCM bound
, SCM start
, SCM end
),
1616 "Compute a hash value for @var{S}. the optional argument "
1617 "@var{bound} is a non-negative exact "
1618 "integer specifying the range of the hash function. "
1619 "A positive value restricts the return value to the "
1621 #define FUNC_NAME s_scm_substring_hash_ci
1623 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1625 SCM_UNDEFINED
, SCM_UNDEFINED
);
1629 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1630 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1631 "Return the length of the longest common prefix of the two\n"
1633 #define FUNC_NAME s_scm_string_prefix_length
1635 const char *cstr1
, *cstr2
;
1636 size_t cstart1
, cend1
, cstart2
, cend2
;
1639 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1642 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1645 while (cstart1
< cend1
&& cstart2
< cend2
)
1647 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1655 scm_remember_upto_here_2 (s1
, s2
);
1656 return scm_from_size_t (len
);
1661 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1662 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1663 "Return the length of the longest common prefix of the two\n"
1664 "strings, ignoring character case.")
1665 #define FUNC_NAME s_scm_string_prefix_length_ci
1667 const char *cstr1
, *cstr2
;
1668 size_t cstart1
, cend1
, cstart2
, cend2
;
1671 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1674 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1677 while (cstart1
< cend1
&& cstart2
< cend2
)
1679 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1687 scm_remember_upto_here_2 (s1
, s2
);
1688 return scm_from_size_t (len
);
1693 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1694 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1695 "Return the length of the longest common suffix of the two\n"
1697 #define FUNC_NAME s_scm_string_suffix_length
1699 const char *cstr1
, *cstr2
;
1700 size_t cstart1
, cend1
, cstart2
, cend2
;
1703 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1706 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1709 while (cstart1
< cend1
&& cstart2
< cend2
)
1713 if (cstr1
[cend1
] != cstr2
[cend2
])
1719 scm_remember_upto_here_2 (s1
, s2
);
1720 return scm_from_size_t (len
);
1725 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1726 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1727 "Return the length of the longest common suffix of the two\n"
1728 "strings, ignoring character case.")
1729 #define FUNC_NAME s_scm_string_suffix_length_ci
1731 const char *cstr1
, *cstr2
;
1732 size_t cstart1
, cend1
, cstart2
, cend2
;
1735 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1738 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1741 while (cstart1
< cend1
&& cstart2
< cend2
)
1745 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1751 scm_remember_upto_here_2 (s1
, s2
);
1752 return scm_from_size_t (len
);
1757 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1758 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1759 "Is @var{s1} a prefix of @var{s2}?")
1760 #define FUNC_NAME s_scm_string_prefix_p
1762 const char *cstr1
, *cstr2
;
1763 size_t cstart1
, cend1
, cstart2
, cend2
;
1764 size_t len
= 0, len1
;
1766 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1769 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1772 len1
= cend1
- cstart1
;
1773 while (cstart1
< cend1
&& cstart2
< cend2
)
1775 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1783 scm_remember_upto_here_2 (s1
, s2
);
1784 return scm_from_bool (len
== len1
);
1789 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1790 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1791 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1792 #define FUNC_NAME s_scm_string_prefix_ci_p
1794 const char *cstr1
, *cstr2
;
1795 size_t cstart1
, cend1
, cstart2
, cend2
;
1796 size_t len
= 0, len1
;
1798 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1801 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1804 len1
= cend1
- cstart1
;
1805 while (cstart1
< cend1
&& cstart2
< cend2
)
1807 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1815 scm_remember_upto_here_2 (s1
, s2
);
1816 return scm_from_bool (len
== len1
);
1821 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1822 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1823 "Is @var{s1} a suffix of @var{s2}?")
1824 #define FUNC_NAME s_scm_string_suffix_p
1826 const char *cstr1
, *cstr2
;
1827 size_t cstart1
, cend1
, cstart2
, cend2
;
1828 size_t len
= 0, len1
;
1830 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1833 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1836 len1
= cend1
- cstart1
;
1837 while (cstart1
< cend1
&& cstart2
< cend2
)
1841 if (cstr1
[cend1
] != cstr2
[cend2
])
1847 scm_remember_upto_here_2 (s1
, s2
);
1848 return scm_from_bool (len
== len1
);
1853 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1854 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1855 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1856 #define FUNC_NAME s_scm_string_suffix_ci_p
1858 const char *cstr1
, *cstr2
;
1859 size_t cstart1
, cend1
, cstart2
, cend2
;
1860 size_t len
= 0, len1
;
1862 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1865 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1868 len1
= cend1
- cstart1
;
1869 while (cstart1
< cend1
&& cstart2
< cend2
)
1873 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1879 scm_remember_upto_here_2 (s1
, s2
);
1880 return scm_from_bool (len
== len1
);
1885 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1886 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1887 "Search through the string @var{s} from left to right, returning\n"
1888 "the index of the first occurence of a character which\n"
1890 "@itemize @bullet\n"
1892 "equals @var{char_pred}, if it is character,\n"
1895 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1898 "is in the set @var{char_pred}, if it is a character set.\n"
1900 #define FUNC_NAME s_scm_string_index
1903 size_t cstart
, cend
;
1905 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1908 if (SCM_CHARP (char_pred
))
1910 char cchr
= SCM_CHAR (char_pred
);
1911 while (cstart
< cend
)
1913 if (cchr
== cstr
[cstart
])
1918 else if (SCM_CHARSETP (char_pred
))
1920 while (cstart
< cend
)
1922 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1929 SCM_VALIDATE_PROC (2, char_pred
);
1930 while (cstart
< cend
)
1933 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1934 if (scm_is_true (res
))
1936 cstr
= scm_i_string_chars (s
);
1941 scm_remember_upto_here_1 (s
);
1945 scm_remember_upto_here_1 (s
);
1946 return scm_from_size_t (cstart
);
1950 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1951 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1952 "Search through the string @var{s} from right to left, returning\n"
1953 "the index of the last occurence of a character which\n"
1955 "@itemize @bullet\n"
1957 "equals @var{char_pred}, if it is character,\n"
1960 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1963 "is in the set if @var{char_pred} is a character set.\n"
1965 #define FUNC_NAME s_scm_string_index_right
1968 size_t cstart
, cend
;
1970 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1973 if (SCM_CHARP (char_pred
))
1975 char cchr
= SCM_CHAR (char_pred
);
1976 while (cstart
< cend
)
1979 if (cchr
== cstr
[cend
])
1983 else if (SCM_CHARSETP (char_pred
))
1985 while (cstart
< cend
)
1988 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1994 SCM_VALIDATE_PROC (2, char_pred
);
1995 while (cstart
< cend
)
1999 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2000 if (scm_is_true (res
))
2002 cstr
= scm_i_string_chars (s
);
2006 scm_remember_upto_here_1 (s
);
2010 scm_remember_upto_here_1 (s
);
2011 return scm_from_size_t (cend
);
2015 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
2016 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2017 "Search through the string @var{s} from right to left, returning\n"
2018 "the index of the last occurence of a character which\n"
2020 "@itemize @bullet\n"
2022 "equals @var{char_pred}, if it is character,\n"
2025 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
2028 "is in the set if @var{char_pred} is a character set.\n"
2030 #define FUNC_NAME s_scm_string_rindex
2032 return scm_string_index_right (s
, char_pred
, start
, end
);
2036 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
2037 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2038 "Search through the string @var{s} from left to right, returning\n"
2039 "the index of the first occurence of a character which\n"
2041 "@itemize @bullet\n"
2043 "does not equal @var{char_pred}, if it is character,\n"
2046 "does not satisify the predicate @var{char_pred}, if it is a\n"
2050 "is not in the set if @var{char_pred} is a character set.\n"
2052 #define FUNC_NAME s_scm_string_skip
2055 size_t cstart
, cend
;
2057 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2060 if (SCM_CHARP (char_pred
))
2062 char cchr
= SCM_CHAR (char_pred
);
2063 while (cstart
< cend
)
2065 if (cchr
!= cstr
[cstart
])
2070 else if (SCM_CHARSETP (char_pred
))
2072 while (cstart
< cend
)
2074 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2081 SCM_VALIDATE_PROC (2, char_pred
);
2082 while (cstart
< cend
)
2085 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2086 if (scm_is_false (res
))
2088 cstr
= scm_i_string_chars (s
);
2093 scm_remember_upto_here_1 (s
);
2097 scm_remember_upto_here_1 (s
);
2098 return scm_from_size_t (cstart
);
2103 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2104 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2105 "Search through the string @var{s} from right to left, returning\n"
2106 "the index of the last occurence of a character which\n"
2108 "@itemize @bullet\n"
2110 "does not equal @var{char_pred}, if it is character,\n"
2113 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2117 "is not in the set if @var{char_pred} is a character set.\n"
2119 #define FUNC_NAME s_scm_string_skip_right
2122 size_t cstart
, cend
;
2124 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2127 if (SCM_CHARP (char_pred
))
2129 char cchr
= SCM_CHAR (char_pred
);
2130 while (cstart
< cend
)
2133 if (cchr
!= cstr
[cend
])
2137 else if (SCM_CHARSETP (char_pred
))
2139 while (cstart
< cend
)
2142 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2148 SCM_VALIDATE_PROC (2, char_pred
);
2149 while (cstart
< cend
)
2153 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2154 if (scm_is_false (res
))
2156 cstr
= scm_i_string_chars (s
);
2160 scm_remember_upto_here_1 (s
);
2164 scm_remember_upto_here_1 (s
);
2165 return scm_from_size_t (cend
);
2171 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2172 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2173 "Return the count of the number of characters in the string\n"
2176 "@itemize @bullet\n"
2178 "equals @var{char_pred}, if it is character,\n"
2181 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2184 "is in the set @var{char_pred}, if it is a character set.\n"
2186 #define FUNC_NAME s_scm_string_count
2189 size_t cstart
, cend
;
2192 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2195 if (SCM_CHARP (char_pred
))
2197 char cchr
= SCM_CHAR (char_pred
);
2198 while (cstart
< cend
)
2200 if (cchr
== cstr
[cstart
])
2205 else if (SCM_CHARSETP (char_pred
))
2207 while (cstart
< cend
)
2209 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2216 SCM_VALIDATE_PROC (2, char_pred
);
2217 while (cstart
< cend
)
2220 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2221 if (scm_is_true (res
))
2223 cstr
= scm_i_string_chars (s
);
2228 scm_remember_upto_here_1 (s
);
2229 return scm_from_size_t (count
);
2234 /* FIXME::martin: This should definitely get implemented more
2235 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2237 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2238 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2239 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2240 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2241 "The optional start/end indices restrict the operation to the\n"
2242 "indicated substrings.")
2243 #define FUNC_NAME s_scm_string_contains
2245 const char *cs1
, * cs2
;
2246 size_t cstart1
, cend1
, cstart2
, cend2
;
2249 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2252 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2255 len2
= cend2
- cstart2
;
2256 if (cend1
- cstart1
>= len2
)
2257 while (cstart1
<= cend1
- len2
)
2261 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2268 scm_remember_upto_here_2 (s1
, s2
);
2269 return scm_from_size_t (cstart1
);
2274 scm_remember_upto_here_2 (s1
, s2
);
2280 /* FIXME::martin: This should definitely get implemented more
2281 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2283 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2284 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2285 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2286 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2287 "The optional start/end indices restrict the operation to the\n"
2288 "indicated substrings. Character comparison is done\n"
2289 "case-insensitively.")
2290 #define FUNC_NAME s_scm_string_contains_ci
2292 const char *cs1
, * cs2
;
2293 size_t cstart1
, cend1
, cstart2
, cend2
;
2296 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2299 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2302 len2
= cend2
- cstart2
;
2303 if (cend1
- cstart1
>= len2
)
2304 while (cstart1
<= cend1
- len2
)
2308 while (i
< cend1
&& j
< cend2
&&
2309 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2316 scm_remember_upto_here_2 (s1
, s2
);
2317 return scm_from_size_t (cstart1
);
2322 scm_remember_upto_here_2 (s1
, s2
);
2328 /* Helper function for the string uppercase conversion functions.
2329 * No argument checking is performed. */
2331 string_upcase_x (SCM v
, size_t start
, size_t end
)
2336 dst
= scm_i_string_writable_chars (v
);
2337 for (k
= start
; k
< end
; ++k
)
2338 dst
[k
] = scm_c_upcase (dst
[k
]);
2339 scm_i_string_stop_writing ();
2340 scm_remember_upto_here_1 (v
);
2345 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2346 (SCM str
, SCM start
, SCM end
),
2347 "Destructively upcase every character in @code{str}.\n"
2350 "(string-upcase! y)\n"
2351 "@result{} \"ARRDEFG\"\n"
2353 "@result{} \"ARRDEFG\"\n"
2355 #define FUNC_NAME s_scm_substring_upcase_x
2358 size_t cstart
, cend
;
2360 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2363 return string_upcase_x (str
, cstart
, cend
);
2368 scm_string_upcase_x (SCM str
)
2370 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2373 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2374 (SCM str
, SCM start
, SCM end
),
2375 "Upcase every character in @code{str}.")
2376 #define FUNC_NAME s_scm_substring_upcase
2379 size_t cstart
, cend
;
2381 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2384 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2389 scm_string_upcase (SCM str
)
2391 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2394 /* Helper function for the string lowercase conversion functions.
2395 * No argument checking is performed. */
2397 string_downcase_x (SCM v
, size_t start
, size_t end
)
2402 dst
= scm_i_string_writable_chars (v
);
2403 for (k
= start
; k
< end
; ++k
)
2404 dst
[k
] = scm_c_downcase (dst
[k
]);
2405 scm_i_string_stop_writing ();
2406 scm_remember_upto_here_1 (v
);
2411 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2412 (SCM str
, SCM start
, SCM end
),
2413 "Destructively downcase every character in @var{str}.\n"
2417 "@result{} \"ARRDEFG\"\n"
2418 "(string-downcase! y)\n"
2419 "@result{} \"arrdefg\"\n"
2421 "@result{} \"arrdefg\"\n"
2423 #define FUNC_NAME s_scm_substring_downcase_x
2426 size_t cstart
, cend
;
2428 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2431 return string_downcase_x (str
, cstart
, cend
);
2436 scm_string_downcase_x (SCM str
)
2438 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2441 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2442 (SCM str
, SCM start
, SCM end
),
2443 "Downcase every character in @var{str}.")
2444 #define FUNC_NAME s_scm_substring_downcase
2447 size_t cstart
, cend
;
2449 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2452 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2457 scm_string_downcase (SCM str
)
2459 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2462 /* Helper function for the string capitalization functions.
2463 * No argument checking is performed. */
2465 string_titlecase_x (SCM str
, size_t start
, size_t end
)
2471 sz
= scm_i_string_writable_chars (str
);
2472 for(i
= start
; i
< end
; i
++)
2474 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2478 sz
[i
] = scm_c_upcase(sz
[i
]);
2483 sz
[i
] = scm_c_downcase(sz
[i
]);
2489 scm_i_string_stop_writing ();
2490 scm_remember_upto_here_1 (str
);
2496 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2497 (SCM str
, SCM start
, SCM end
),
2498 "Destructively titlecase every first character in a word in\n"
2500 #define FUNC_NAME s_scm_string_titlecase_x
2503 size_t cstart
, cend
;
2505 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2508 return string_titlecase_x (str
, cstart
, cend
);
2513 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2514 (SCM str
, SCM start
, SCM end
),
2515 "Titlecase every first character in a word in @var{str}.")
2516 #define FUNC_NAME s_scm_string_titlecase
2519 size_t cstart
, cend
;
2521 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2524 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2528 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2530 "Upcase the first character of every word in @var{str}\n"
2531 "destructively and return @var{str}.\n"
2534 "y @result{} \"hello world\"\n"
2535 "(string-capitalize! y) @result{} \"Hello World\"\n"
2536 "y @result{} \"Hello World\"\n"
2538 #define FUNC_NAME s_scm_string_capitalize_x
2540 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2545 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2547 "Return a freshly allocated string with the characters in\n"
2548 "@var{str}, where the first character of every word is\n"
2550 #define FUNC_NAME s_scm_string_capitalize
2552 return scm_string_capitalize_x (scm_string_copy (str
));
2557 /* Reverse the portion of @var{str} between str[cstart] (including)
2558 and str[cend] excluding. */
2560 string_reverse_x (char * str
, size_t cstart
, size_t cend
)
2567 while (cstart
< cend
)
2570 str
[cstart
] = str
[cend
];
2579 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2580 (SCM str
, SCM start
, SCM end
),
2581 "Reverse the string @var{str}. The optional arguments\n"
2582 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2584 #define FUNC_NAME s_scm_string_reverse
2588 size_t cstart
, cend
;
2591 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2594 result
= scm_string_copy (str
);
2595 ctarget
= scm_i_string_writable_chars (result
);
2596 string_reverse_x (ctarget
, cstart
, cend
);
2597 scm_i_string_stop_writing ();
2598 scm_remember_upto_here_1 (str
);
2604 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2605 (SCM str
, SCM start
, SCM end
),
2606 "Reverse the string @var{str} in-place. The optional arguments\n"
2607 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2608 "operate on. The return value is unspecified.")
2609 #define FUNC_NAME s_scm_string_reverse_x
2612 size_t cstart
, cend
;
2614 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2618 cstr
= scm_i_string_writable_chars (str
);
2619 string_reverse_x (cstr
, cstart
, cend
);
2620 scm_i_string_stop_writing ();
2621 scm_remember_upto_here_1 (str
);
2622 return SCM_UNSPECIFIED
;
2627 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2629 "Like @code{string-append}, but the result may share memory\n"
2630 "with the argument strings.")
2631 #define FUNC_NAME s_scm_string_append_shared
2635 SCM_VALIDATE_REST_ARGUMENT (ls
);
2637 /* Optimize the one-argument case. */
2638 i
= scm_ilength (ls
);
2640 return SCM_CAR (ls
);
2642 return scm_string_append (ls
);
2647 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2649 "Append the elements of @var{ls} (which must be strings)\n"
2650 "together into a single string. Guaranteed to return a freshly\n"
2651 "allocated string.")
2652 #define FUNC_NAME s_scm_string_concatenate
2654 return scm_string_append (ls
);
2659 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2660 (SCM ls
, SCM final_string
, SCM end
),
2661 "Without optional arguments, this procedure is equivalent to\n"
2664 "(string-concatenate (reverse ls))\n"
2667 "If the optional argument @var{final_string} is specified, it is\n"
2668 "consed onto the beginning to @var{ls} before performing the\n"
2669 "list-reverse and string-concatenate operations. If @var{end}\n"
2670 "is given, only the characters of @var{final_string} up to index\n"
2671 "@var{end} are used.\n"
2673 "Guaranteed to return a freshly allocated string.")
2674 #define FUNC_NAME s_scm_string_concatenate_reverse
2676 if (!SCM_UNBNDP (end
))
2677 final_string
= scm_substring (final_string
, SCM_INUM0
, end
);
2679 if (!SCM_UNBNDP (final_string
))
2680 ls
= scm_cons (final_string
, ls
);
2682 return scm_string_concatenate (scm_reverse (ls
));
2687 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2689 "Like @code{string-concatenate}, but the result may share memory\n"
2690 "with the strings in the list @var{ls}.")
2691 #define FUNC_NAME s_scm_string_concatenate_shared
2693 return scm_string_append_shared (ls
);
2698 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2699 (SCM ls
, SCM final_string
, SCM end
),
2700 "Like @code{string-concatenate-reverse}, but the result may\n"
2701 "share memory with the the strings in the @var{ls} arguments.")
2702 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2704 /* Just call the non-sharing version. */
2705 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2710 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2711 (SCM proc
, SCM s
, SCM start
, SCM end
),
2712 "@var{proc} is a char->char procedure, it is mapped over\n"
2713 "@var{s}. The order in which the procedure is applied to the\n"
2714 "string elements is not specified.")
2715 #define FUNC_NAME s_scm_string_map
2718 size_t cstart
, cend
;
2721 SCM_VALIDATE_PROC (1, proc
);
2722 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2725 result
= scm_i_make_string (cend
- cstart
, &p
);
2726 while (cstart
< cend
)
2728 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2729 if (!SCM_CHARP (ch
))
2730 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2732 *p
++ = SCM_CHAR (ch
);
2739 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2740 (SCM proc
, SCM s
, SCM start
, SCM end
),
2741 "@var{proc} is a char->char procedure, it is mapped over\n"
2742 "@var{s}. The order in which the procedure is applied to the\n"
2743 "string elements is not specified. The string @var{s} is\n"
2744 "modified in-place, the return value is not specified.")
2745 #define FUNC_NAME s_scm_string_map_x
2747 size_t cstart
, cend
;
2749 SCM_VALIDATE_PROC (1, proc
);
2750 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2753 while (cstart
< cend
)
2755 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2756 if (!SCM_CHARP (ch
))
2757 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2758 scm_c_string_set_x (s
, cstart
, ch
);
2761 return SCM_UNSPECIFIED
;
2766 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2767 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2768 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2769 "as the terminating element, from left to right. @var{kons}\n"
2770 "must expect two arguments: The actual character and the last\n"
2771 "result of @var{kons}' application.")
2772 #define FUNC_NAME s_scm_string_fold
2775 size_t cstart
, cend
;
2778 SCM_VALIDATE_PROC (1, kons
);
2779 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2783 while (cstart
< cend
)
2785 unsigned int c
= (unsigned char) cstr
[cstart
];
2786 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2787 cstr
= scm_i_string_chars (s
);
2791 scm_remember_upto_here_1 (s
);
2797 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2798 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2799 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2800 "as the terminating element, from right to left. @var{kons}\n"
2801 "must expect two arguments: The actual character and the last\n"
2802 "result of @var{kons}' application.")
2803 #define FUNC_NAME s_scm_string_fold_right
2806 size_t cstart
, cend
;
2809 SCM_VALIDATE_PROC (1, kons
);
2810 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2814 while (cstart
< cend
)
2816 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2817 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2818 cstr
= scm_i_string_chars (s
);
2822 scm_remember_upto_here_1 (s
);
2828 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2829 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2830 "@itemize @bullet\n"
2831 "@item @var{g} is used to generate a series of @emph{seed}\n"
2832 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2833 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2835 "@item @var{p} tells us when to stop -- when it returns true\n"
2836 "when applied to one of these seed values.\n"
2837 "@item @var{f} maps each seed value to the corresponding\n"
2838 "character in the result string. These chars are assembled\n"
2839 "into the string in a left-to-right order.\n"
2840 "@item @var{base} is the optional initial/leftmost portion\n"
2841 "of the constructed string; it default to the empty\n"
2843 "@item @var{make_final} is applied to the terminal seed\n"
2844 "value (on which @var{p} returns true) to produce\n"
2845 "the final/rightmost portion of the constructed string.\n"
2846 "It defaults to @code{(lambda (x) "")}.\n"
2848 #define FUNC_NAME s_scm_string_unfold
2852 SCM_VALIDATE_PROC (1, p
);
2853 SCM_VALIDATE_PROC (2, f
);
2854 SCM_VALIDATE_PROC (3, g
);
2855 if (!SCM_UNBNDP (base
))
2857 SCM_VALIDATE_STRING (5, base
);
2861 ans
= scm_i_make_string (0, NULL
);
2862 if (!SCM_UNBNDP (make_final
))
2863 SCM_VALIDATE_PROC (6, make_final
);
2865 res
= scm_call_1 (p
, seed
);
2866 while (scm_is_false (res
))
2870 SCM ch
= scm_call_1 (f
, seed
);
2871 if (!SCM_CHARP (ch
))
2872 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2873 str
= scm_i_make_string (1, &ptr
);
2874 *ptr
= SCM_CHAR (ch
);
2876 ans
= scm_string_append (scm_list_2 (ans
, str
));
2877 seed
= scm_call_1 (g
, seed
);
2878 res
= scm_call_1 (p
, seed
);
2880 if (!SCM_UNBNDP (make_final
))
2882 res
= scm_call_1 (make_final
, seed
);
2883 return scm_string_append (scm_list_2 (ans
, res
));
2891 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2892 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2893 "@itemize @bullet\n"
2894 "@item @var{g} is used to generate a series of @emph{seed}\n"
2895 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2896 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2898 "@item @var{p} tells us when to stop -- when it returns true\n"
2899 "when applied to one of these seed values.\n"
2900 "@item @var{f} maps each seed value to the corresponding\n"
2901 "character in the result string. These chars are assembled\n"
2902 "into the string in a right-to-left order.\n"
2903 "@item @var{base} is the optional initial/rightmost portion\n"
2904 "of the constructed string; it default to the empty\n"
2906 "@item @var{make_final} is applied to the terminal seed\n"
2907 "value (on which @var{p} returns true) to produce\n"
2908 "the final/leftmost portion of the constructed string.\n"
2909 "It defaults to @code{(lambda (x) "")}.\n"
2911 #define FUNC_NAME s_scm_string_unfold_right
2915 SCM_VALIDATE_PROC (1, p
);
2916 SCM_VALIDATE_PROC (2, f
);
2917 SCM_VALIDATE_PROC (3, g
);
2918 if (!SCM_UNBNDP (base
))
2920 SCM_VALIDATE_STRING (5, base
);
2924 ans
= scm_i_make_string (0, NULL
);
2925 if (!SCM_UNBNDP (make_final
))
2926 SCM_VALIDATE_PROC (6, make_final
);
2928 res
= scm_call_1 (p
, seed
);
2929 while (scm_is_false (res
))
2933 SCM ch
= scm_call_1 (f
, seed
);
2934 if (!SCM_CHARP (ch
))
2935 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2936 str
= scm_i_make_string (1, &ptr
);
2937 *ptr
= SCM_CHAR (ch
);
2939 ans
= scm_string_append (scm_list_2 (str
, ans
));
2940 seed
= scm_call_1 (g
, seed
);
2941 res
= scm_call_1 (p
, seed
);
2943 if (!SCM_UNBNDP (make_final
))
2945 res
= scm_call_1 (make_final
, seed
);
2946 return scm_string_append (scm_list_2 (res
, ans
));
2954 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2955 (SCM proc
, SCM s
, SCM start
, SCM end
),
2956 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2957 "return value is not specified.")
2958 #define FUNC_NAME s_scm_string_for_each
2961 size_t cstart
, cend
;
2963 SCM_VALIDATE_PROC (1, proc
);
2964 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2967 while (cstart
< cend
)
2969 unsigned int c
= (unsigned char) cstr
[cstart
];
2970 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2971 cstr
= scm_i_string_chars (s
);
2975 scm_remember_upto_here_1 (s
);
2976 return SCM_UNSPECIFIED
;
2980 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2981 (SCM proc
, SCM s
, SCM start
, SCM end
),
2982 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2983 "return value is not specified.")
2984 #define FUNC_NAME s_scm_string_for_each_index
2986 size_t cstart
, cend
;
2988 SCM_VALIDATE_PROC (1, proc
);
2989 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2993 while (cstart
< cend
)
2995 scm_call_1 (proc
, scm_from_size_t (cstart
));
2999 scm_remember_upto_here_1 (s
);
3000 return SCM_UNSPECIFIED
;
3004 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
3005 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
3006 "This is the @emph{extended substring} procedure that implements\n"
3007 "replicated copying of a substring of some string.\n"
3009 "@var{s} is a string, @var{start} and @var{end} are optional\n"
3010 "arguments that demarcate a substring of @var{s}, defaulting to\n"
3011 "0 and the length of @var{s}. Replicate this substring up and\n"
3012 "down index space, in both the positive and negative directions.\n"
3013 "@code{xsubstring} returns the substring of this string\n"
3014 "beginning at index @var{from}, and ending at @var{to}, which\n"
3015 "defaults to @var{from} + (@var{end} - @var{start}).")
3016 #define FUNC_NAME s_scm_xsubstring
3020 size_t cstart
, cend
;
3024 MY_VALIDATE_SUBSTRING_SPEC (1, s
,
3028 cfrom
= scm_to_int (from
);
3029 if (SCM_UNBNDP (to
))
3030 cto
= cfrom
+ (cend
- cstart
);
3032 cto
= scm_to_int (to
);
3033 if (cstart
== cend
&& cfrom
!= cto
)
3034 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3036 result
= scm_i_make_string (cto
- cfrom
, &p
);
3038 cs
= scm_i_string_chars (s
);
3041 size_t t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
3043 *p
= cs
[(cend
- cstart
) - t
];
3050 scm_remember_upto_here_1 (s
);
3056 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3057 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3058 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3059 "is written into the string @var{target} starting at index\n"
3060 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3061 "@var{target} @var{s})} or these arguments share storage -- you\n"
3062 "cannot copy a string on top of itself.")
3063 #define FUNC_NAME s_scm_string_xcopy_x
3067 size_t ctstart
, cstart
, cend
;
3069 SCM dummy
= SCM_UNDEFINED
;
3072 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3075 MY_VALIDATE_SUBSTRING_SPEC (3, s
,
3078 csfrom
= scm_to_int (sfrom
);
3079 if (SCM_UNBNDP (sto
))
3080 csto
= csfrom
+ (cend
- cstart
);
3082 csto
= scm_to_int (sto
);
3083 if (cstart
== cend
&& csfrom
!= csto
)
3084 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3085 SCM_ASSERT_RANGE (1, tstart
,
3086 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3088 p
= scm_i_string_writable_chars (target
) + ctstart
;
3089 cs
= scm_i_string_chars (s
);
3090 while (csfrom
< csto
)
3092 size_t t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3094 *p
= cs
[(cend
- cstart
) - t
];
3100 scm_i_string_stop_writing ();
3102 scm_remember_upto_here_2 (target
, s
);
3103 return SCM_UNSPECIFIED
;
3108 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3109 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3110 "Return the string @var{s1}, but with the characters\n"
3111 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3112 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3113 #define FUNC_NAME s_scm_string_replace
3115 const char *cstr1
, *cstr2
;
3117 size_t cstart1
, cend1
, cstart2
, cend2
;
3120 MY_VALIDATE_SUBSTRING_SPEC (1, s1
,
3123 MY_VALIDATE_SUBSTRING_SPEC (2, s2
,
3126 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3127 scm_i_string_length (s1
) - cend1
, &p
);
3128 cstr1
= scm_i_string_chars (s1
);
3129 cstr2
= scm_i_string_chars (s2
);
3130 memmove (p
, cstr1
, cstart1
* sizeof (char));
3131 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3132 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3134 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3135 scm_remember_upto_here_2 (s1
, s2
);
3141 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3142 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3143 "Split the string @var{s} into a list of substrings, where each\n"
3144 "substring is a maximal non-empty contiguous sequence of\n"
3145 "characters from the character set @var{token_set}, which\n"
3146 "defaults to @code{char-set:graphic}.\n"
3147 "If @var{start} or @var{end} indices are provided, they restrict\n"
3148 "@code{string-tokenize} to operating on the indicated substring\n"
3150 #define FUNC_NAME s_scm_string_tokenize
3153 size_t cstart
, cend
;
3154 SCM result
= SCM_EOL
;
3156 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3160 if (SCM_UNBNDP (token_set
))
3161 token_set
= scm_char_set_graphic
;
3163 if (SCM_CHARSETP (token_set
))
3167 while (cstart
< cend
)
3169 while (cstart
< cend
)
3171 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3178 while (cstart
< cend
)
3180 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3184 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3185 cstr
= scm_i_string_chars (s
);
3189 SCM_WRONG_TYPE_ARG (2, token_set
);
3191 scm_remember_upto_here_1 (s
);
3196 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3198 "Split the string @var{str} into the a list of the substrings delimited\n"
3199 "by appearances of the character @var{chr}. Note that an empty substring\n"
3200 "between separator characters will result in an empty string in the\n"
3204 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3206 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3208 "(string-split \"::\" #\\:)\n"
3210 "(\"\" \"\" \"\")\n"
3212 "(string-split \"\" #\\:)\n"
3216 #define FUNC_NAME s_scm_string_split
3223 SCM_VALIDATE_STRING (1, str
);
3224 SCM_VALIDATE_CHAR (2, chr
);
3226 idx
= scm_i_string_length (str
);
3227 p
= scm_i_string_chars (str
);
3228 ch
= SCM_CHAR (chr
);
3232 while (idx
> 0 && p
[idx
- 1] != ch
)
3236 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3237 p
= scm_i_string_chars (str
);
3241 scm_remember_upto_here_1 (str
);
3247 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3248 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3249 "Filter the string @var{s}, retaining only those characters that\n"
3250 "satisfy the @var{char_pred} argument. If the argument is a\n"
3251 "procedure, it is applied to each character as a predicate, if\n"
3252 "it is a character, it is tested for equality and if it is a\n"
3253 "character set, it is tested for membership.")
3254 #define FUNC_NAME s_scm_string_filter
3257 size_t cstart
, cend
;
3261 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3264 if (SCM_CHARP (char_pred
))
3269 chr
= SCM_CHAR (char_pred
);
3273 if (cstr
[idx
] == chr
)
3274 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3275 cstr
= scm_i_string_chars (s
);
3278 result
= scm_reverse_list_to_string (ls
);
3280 else if (SCM_CHARSETP (char_pred
))
3287 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3288 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3289 cstr
= scm_i_string_chars (s
);
3292 result
= scm_reverse_list_to_string (ls
);
3298 SCM_VALIDATE_PROC (2, char_pred
);
3303 ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3304 res
= scm_call_1 (char_pred
, ch
);
3305 if (scm_is_true (res
))
3306 ls
= scm_cons (ch
, ls
);
3307 cstr
= scm_i_string_chars (s
);
3310 result
= scm_reverse_list_to_string (ls
);
3313 scm_remember_upto_here_1 (s
);
3319 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3320 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3321 "Filter the string @var{s}, retaining only those characters that\n"
3322 "do not satisfy the @var{char_pred} argument. If the argument\n"
3323 "is a procedure, it is applied to each character as a predicate,\n"
3324 "if it is a character, it is tested for equality and if it is a\n"
3325 "character set, it is tested for membership.")
3326 #define FUNC_NAME s_scm_string_delete
3329 size_t cstart
, cend
;
3333 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3336 if (SCM_CHARP (char_pred
))
3341 chr
= SCM_CHAR (char_pred
);
3345 if (cstr
[idx
] != chr
)
3346 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3347 cstr
= scm_i_string_chars (s
);
3350 result
= scm_reverse_list_to_string (ls
);
3352 else if (SCM_CHARSETP (char_pred
))
3359 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3360 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3361 cstr
= scm_i_string_chars (s
);
3364 result
= scm_reverse_list_to_string (ls
);
3370 SCM_VALIDATE_PROC (2, char_pred
);
3374 SCM res
, ch
= SCM_MAKE_CHAR (cstr
[idx
]);
3375 res
= scm_call_1 (char_pred
, ch
);
3376 if (scm_is_false (res
))
3377 ls
= scm_cons (ch
, ls
);
3378 cstr
= scm_i_string_chars (s
);
3381 result
= scm_reverse_list_to_string (ls
);
3384 scm_remember_upto_here_1 (s
);
3390 scm_init_srfi_13 (void)
3392 #include "libguile/srfi-13.x"
3395 /* End of srfi-13.c. */