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 /* Likewise for SCM_VALIDATE_STRING_COPY. */
56 #define MY_VALIDATE_STRING_COPY(pos, str, cvar) \
58 scm_validate_string (pos, str); \
59 cvar = scm_i_string_chars (str); \
63 SCM_DEFINE (scm_string_null_p
, "string-null?", 1, 0, 0,
65 "Return @code{#t} if @var{str}'s length is zero, and\n"
66 "@code{#f} otherwise.\n"
68 "(string-null? \"\") @result{} #t\n"
69 "y @result{} \"foo\"\n"
70 "(string-null? y) @result{} #f\n"
72 #define FUNC_NAME s_scm_string_null_p
74 SCM_VALIDATE_STRING (1, str
);
75 return scm_from_bool (scm_i_string_length (str
) == 0);
79 SCM_DEFINE (scm_string_any
, "string-any", 2, 2, 0,
80 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
81 "Check if the predicate @var{pred} is true for any character in\n"
82 "the string @var{s}.\n"
84 "Calls to @var{pred} are made from left to right across @var{s}.\n"
85 "When it returns true (ie.@: non-@code{#f}), that return value\n"
86 "is the return from @code{string-any}.\n"
88 "The SRFI-13 specification requires that the call to @var{pred}\n"
89 "on the last character of @var{s} (assuming that point is\n"
90 "reached) be a tail call, but currently in Guile this is not the\n"
92 #define FUNC_NAME s_scm_string_any
98 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
102 if (SCM_CHARP (char_pred
))
104 return (memchr (cstr
+cstart
, (int) SCM_CHAR (char_pred
),
106 ? SCM_BOOL_F
: SCM_BOOL_T
);
108 else if (SCM_CHARSETP (char_pred
))
111 for (i
= cstart
; i
< cend
; i
++)
112 if (SCM_CHARSET_GET (char_pred
, cstr
[i
]))
117 SCM_VALIDATE_PROC (1, char_pred
);
120 while (cstart
< cend
)
122 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (*cstr
));
123 if (scm_is_true (res
))
134 SCM_DEFINE (scm_string_every
, "string-every", 2, 2, 0,
135 (SCM char_pred
, SCM s
, SCM start
, SCM end
),
136 "Check if the predicate @var{pred} is true for every character\n"
137 "in the string @var{s}.\n"
139 "Calls to @var{pred} are made from left to right across @var{s}.\n"
140 "If the predicate is true for every character then the return\n"
141 "value from the last @var{pred} call is the return from\n"
142 "@code{string-every}.\n"
144 "If there are no characters in @var{s} (ie.@: @var{start} equals\n"
145 "@var{end}) then the return is @code{#t}.\n"
147 "The SRFI-13 specification requires that the call to @var{pred}\n"
148 "on the last character of @var{s} (assuming that point is\n"
149 "reached) be a tail call, but currently in Guile this is not the\n"
151 #define FUNC_NAME s_scm_string_every
157 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
160 if (SCM_CHARP (char_pred
))
162 char cchr
= SCM_CHAR (char_pred
);
164 for (i
= cstart
; i
< cend
; i
++)
169 else if (SCM_CHARSETP (char_pred
))
172 for (i
= cstart
; i
< cend
; i
++)
173 if (! SCM_CHARSET_GET (char_pred
, cstr
[i
]))
179 SCM_VALIDATE_PROC (1, char_pred
);
183 while (cstart
< cend
)
185 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (*cstr
));
186 if (scm_is_false (res
))
197 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
199 "@var{proc} is an integer->char procedure. Construct a string\n"
200 "of size @var{len} by applying @var{proc} to each index to\n"
201 "produce the corresponding string element. The order in which\n"
202 "@var{proc} is applied to the indices is not specified.")
203 #define FUNC_NAME s_scm_string_tabulate
210 SCM_VALIDATE_PROC (1, proc
);
211 clen
= scm_to_size_t (len
);
212 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
214 res
= scm_i_make_string (clen
, &p
);
218 /* The RES string remains untouched since nobody knows about it
219 yet. No need to refetch P.
221 ch
= scm_call_1 (proc
, scm_from_int (i
));
223 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
224 *p
++ = SCM_CHAR (ch
);
232 SCM_DEFINE (scm_substring_to_list
, "string->list", 1, 2, 0,
233 (SCM str
, SCM start
, SCM end
),
234 "Convert the string @var{str} into a list of characters.")
235 #define FUNC_NAME s_scm_substring_to_list
239 SCM result
= SCM_EOL
;
241 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
244 while (cstart
< cend
)
247 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
253 /* We export scm_substring_to_list as "string->list" since it is
254 compatible and more general. This function remains for the benefit
255 of C code that used it.
259 scm_string_to_list (SCM str
)
261 return scm_substring_to_list (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
264 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
266 "An efficient implementation of @code{(compose string->list\n"
270 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
272 #define FUNC_NAME s_scm_reverse_list_to_string
275 long i
= scm_ilength (chrs
);
279 SCM_WRONG_TYPE_ARG (1, chrs
);
280 result
= scm_i_make_string (i
, &data
);
285 while (!SCM_NULLP (chrs
))
287 SCM elt
= SCM_CAR (chrs
);
289 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
291 *data
= SCM_CHAR (elt
);
292 chrs
= SCM_CDR (chrs
);
300 SCM_SYMBOL (scm_sym_infix
, "infix");
301 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
302 SCM_SYMBOL (scm_sym_suffix
, "suffix");
303 SCM_SYMBOL (scm_sym_prefix
, "prefix");
305 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
306 (SCM ls
, SCM delimiter
, SCM grammar
),
307 "Append the string in the string list @var{ls}, using the string\n"
308 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
309 "@var{grammar} is a symbol which specifies how the delimiter is\n"
310 "placed between the strings, and defaults to the symbol\n"
315 "Insert the separator between list elements. An empty string\n"
316 "will produce an empty list.\n"
317 "@item string-infix\n"
318 "Like @code{infix}, but will raise an error if given the empty\n"
321 "Insert the separator after every list element.\n"
323 "Insert the separator before each list element.\n"
325 #define FUNC_NAME s_scm_string_join
328 #define GRAM_STRICT_INFIX 1
329 #define GRAM_SUFFIX 2
330 #define GRAM_PREFIX 3
333 int gram
= GRAM_INFIX
;
334 int del_len
= 0, extra_len
= 0;
337 long strings
= scm_ilength (ls
);
339 /* Validate the string list. */
341 SCM_WRONG_TYPE_ARG (1, ls
);
343 /* Validate the delimiter and record its length. */
344 if (SCM_UNBNDP (delimiter
))
346 delimiter
= scm_from_locale_string (" ");
351 SCM_VALIDATE_STRING (2, delimiter
);
352 del_len
= scm_i_string_length (delimiter
);
355 /* Validate the grammar symbol and remember the grammar. */
356 if (SCM_UNBNDP (grammar
))
358 else if (scm_is_eq (grammar
, scm_sym_infix
))
360 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
361 gram
= GRAM_STRICT_INFIX
;
362 else if (scm_is_eq (grammar
, scm_sym_suffix
))
364 else if (scm_is_eq (grammar
, scm_sym_prefix
))
367 SCM_WRONG_TYPE_ARG (3, grammar
);
369 /* Check grammar constraints and calculate the space required for
375 extra_len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
377 case GRAM_STRICT_INFIX
:
379 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
381 extra_len
= (strings
- 1) * del_len
;
384 extra_len
= strings
* del_len
;
389 while (SCM_CONSP (tmp
))
391 SCM elt
= SCM_CAR (tmp
);
392 SCM_VALIDATE_STRING (1, elt
);
393 len
+= scm_i_string_length (elt
);
397 result
= scm_i_make_string (len
+ extra_len
, &p
);
403 case GRAM_STRICT_INFIX
:
404 while (!SCM_NULLP (tmp
))
406 SCM elt
= SCM_CAR (tmp
);
407 memmove (p
, scm_i_string_chars (elt
),
408 scm_i_string_length (elt
));
409 p
+= scm_i_string_length (elt
);
410 if (!SCM_NULLP (SCM_CDR (tmp
)) && del_len
> 0)
412 memmove (p
, scm_i_string_chars (delimiter
), del_len
);
419 while (!SCM_NULLP (tmp
))
421 SCM elt
= SCM_CAR (tmp
);
422 memmove (p
, scm_i_string_chars (elt
),
423 scm_i_string_length (elt
));
424 p
+= scm_i_string_length (elt
);
427 memmove (p
, scm_i_string_chars (delimiter
), del_len
);
434 while (!SCM_NULLP (tmp
))
436 SCM elt
= SCM_CAR (tmp
);
439 memmove (p
, scm_i_string_chars (delimiter
), del_len
);
442 memmove (p
, scm_i_string_chars (elt
),
443 scm_i_string_length (elt
));
444 p
+= scm_i_string_length (elt
);
451 #undef GRAM_STRICT_INFIX
458 /* There are a number of functions to consider here for Scheme and C:
460 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
461 substring/copy STR start [end] ;; Guile variant of R5RS substring
463 scm_string_copy (str) ;; Old function from Guile
464 scm_substring_copy (str, [start, [end]])
465 ;; C version of SRFI-13 string-copy
466 ;; and C version of substring/copy
468 The C function underlying string-copy is not exported to C
469 programs. scm_substring_copy is defined in strings.c as the
470 underlying function of substring/copy and allows an optional START
474 SCM
scm_srfi13_substring_copy (SCM str
, SCM start
, SCM end
);
476 SCM_DEFINE (scm_srfi13_substring_copy
, "string-copy", 1, 2, 0,
477 (SCM str
, SCM start
, SCM end
),
478 "Return a freshly allocated copy of the string @var{str}. If\n"
479 "given, @var{start} and @var{end} delimit the portion of\n"
480 "@var{str} which is copied.")
481 #define FUNC_NAME s_scm_srfi13_substring_copy
486 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
489 return scm_c_substring_copy (str
, cstart
, cend
);
494 scm_string_copy (SCM str
)
496 return scm_c_substring (str
, 0, scm_c_string_length (str
));
499 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
500 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
501 "Copy the sequence of characters from index range [@var{start},\n"
502 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
503 "at index @var{tstart}. The characters are copied left-to-right\n"
504 "or right-to-left as needed -- the copy is guaranteed to work,\n"
505 "even if @var{target} and @var{s} are the same string. It is an\n"
506 "error if the copy operation runs off the end of the target\n"
508 #define FUNC_NAME s_scm_string_copy_x
512 size_t cstart
, cend
, ctstart
, dummy
, len
;
513 SCM sdummy
= SCM_UNDEFINED
;
515 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
518 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
522 SCM_ASSERT_RANGE (3, s
, len
<= scm_i_string_length (target
) - ctstart
);
524 ctarget
= scm_i_string_writable_chars (target
);
525 memmove (ctarget
+ ctstart
, cstr
+ cstart
, len
);
526 scm_i_string_stop_writing ();
528 return SCM_UNSPECIFIED
;
532 SCM_DEFINE (scm_substring_move_x
, "substring-move!", 5, 0, 0,
533 (SCM str1
, SCM start1
, SCM end1
, SCM str2
, SCM start2
),
534 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
535 "into @var{str2} beginning at position @var{start2}.\n"
536 "@var{str1} and @var{str2} can be the same string.")
537 #define FUNC_NAME s_scm_substring_move_x
539 return scm_string_copy_x (str2
, start2
, str1
, start1
, end1
);
543 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
545 "Return the @var{n} first characters of @var{s}.")
546 #define FUNC_NAME s_scm_string_take
548 return scm_substring (s
, SCM_INUM0
, n
);
553 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
555 "Return all but the first @var{n} characters of @var{s}.")
556 #define FUNC_NAME s_scm_string_drop
558 return scm_substring (s
, n
, SCM_UNDEFINED
);
563 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
565 "Return the @var{n} last characters of @var{s}.")
566 #define FUNC_NAME s_scm_string_take_right
568 return scm_substring (s
,
569 scm_difference (scm_string_length (s
), n
),
575 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
577 "Return all but the last @var{n} characters of @var{s}.")
578 #define FUNC_NAME s_scm_string_drop_right
580 return scm_substring (s
,
582 scm_difference (scm_string_length (s
), n
));
587 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
588 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
589 "Take that characters from @var{start} to @var{end} from the\n"
590 "string @var{s} and return a new string, right-padded by the\n"
591 "character @var{chr} to length @var{len}. If the resulting\n"
592 "string is longer than @var{len}, it is truncated on the right.")
593 #define FUNC_NAME s_scm_string_pad
597 size_t cstart
, cend
, clen
;
599 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
602 clen
= scm_to_size_t (len
);
604 if (SCM_UNBNDP (chr
))
608 SCM_VALIDATE_CHAR (3, chr
);
609 cchr
= SCM_CHAR (chr
);
611 if (clen
< (cend
- cstart
))
612 return scm_c_substring (s
, cend
- clen
, cend
);
618 result
= scm_i_make_string (clen
, &dst
);
619 memset (dst
, cchr
, (clen
- (cend
- cstart
)));
620 memmove (dst
+ clen
- (cend
- cstart
), cstr
+ cstart
, cend
- cstart
);
627 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
628 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
629 "Take that characters from @var{start} to @var{end} from the\n"
630 "string @var{s} and return a new string, left-padded by the\n"
631 "character @var{chr} to length @var{len}. If the resulting\n"
632 "string is longer than @var{len}, it is truncated on the left.")
633 #define FUNC_NAME s_scm_string_pad_right
637 size_t cstart
, cend
, clen
;
639 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
642 clen
= scm_to_size_t (len
);
644 if (SCM_UNBNDP (chr
))
648 SCM_VALIDATE_CHAR (3, chr
);
649 cchr
= SCM_CHAR (chr
);
651 if (clen
< (cend
- cstart
))
652 return scm_c_substring (s
, cstart
, cstart
+ clen
);
658 result
= scm_i_make_string (clen
, &dst
);
659 memset (dst
+ (cend
- cstart
), cchr
, clen
- (cend
- cstart
));
660 memmove (dst
, cstr
+ cstart
, cend
- cstart
);
667 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
668 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
669 "Trim @var{s} by skipping over all characters on the left\n"
670 "that satisfy the parameter @var{char_pred}:\n"
674 "if it is the character @var{ch}, characters equal to\n"
675 "@var{ch} are trimmed,\n"
678 "if it is a procedure @var{pred} characters that\n"
679 "satisfy @var{pred} are trimmed,\n"
682 "if it is a character set, characters in that set are trimmed.\n"
685 "If called without a @var{char_pred} argument, all whitespace is\n"
687 #define FUNC_NAME s_scm_string_trim
692 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
695 if (SCM_UNBNDP (char_pred
))
697 while (cstart
< cend
)
699 if (!isspace((int) (unsigned char) cstr
[cstart
]))
704 else if (SCM_CHARP (char_pred
))
706 char chr
= SCM_CHAR (char_pred
);
707 while (cstart
< cend
)
709 if (chr
!= cstr
[cstart
])
714 else if (SCM_CHARSETP (char_pred
))
716 while (cstart
< cend
)
718 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
725 SCM_VALIDATE_PROC (2, char_pred
);
726 while (cstart
< cend
)
730 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
731 if (scm_is_false (res
))
733 cstr
= scm_i_string_chars (s
);
737 return scm_c_substring (s
, cstart
, cend
);
742 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
743 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
744 "Trim @var{s} by skipping over all characters on the rightt\n"
745 "that satisfy the parameter @var{char_pred}:\n"
749 "if it is the character @var{ch}, characters equal to @var{ch}\n"
753 "if it is a procedure @var{pred} characters that satisfy\n"
754 "@var{pred} are trimmed,\n"
757 "if it is a character sets, all characters in that set are\n"
761 "If called without a @var{char_pred} argument, all whitespace is\n"
763 #define FUNC_NAME s_scm_string_trim_right
768 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
771 if (SCM_UNBNDP (char_pred
))
773 while (cstart
< cend
)
775 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
780 else if (SCM_CHARP (char_pred
))
782 char chr
= SCM_CHAR (char_pred
);
783 while (cstart
< cend
)
785 if (chr
!= cstr
[cend
- 1])
790 else if (SCM_CHARSETP (char_pred
))
792 while (cstart
< cend
)
794 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
801 SCM_VALIDATE_PROC (2, char_pred
);
802 while (cstart
< cend
)
806 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
807 if (scm_is_false (res
))
809 cstr
= scm_i_string_chars (s
);
813 return scm_c_substring (s
, cstart
, cend
);
818 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
819 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
820 "Trim @var{s} by skipping over all characters on both sides of\n"
821 "the string that satisfy the parameter @var{char_pred}:\n"
825 "if it is the character @var{ch}, characters equal to @var{ch}\n"
829 "if it is a procedure @var{pred} characters that satisfy\n"
830 "@var{pred} are trimmed,\n"
833 "if it is a character set, the characters in the set are\n"
837 "If called without a @var{char_pred} argument, all whitespace is\n"
839 #define FUNC_NAME s_scm_string_trim_both
844 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
847 if (SCM_UNBNDP (char_pred
))
849 while (cstart
< cend
)
851 if (!isspace((int) (unsigned char) cstr
[cstart
]))
855 while (cstart
< cend
)
857 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
862 else if (SCM_CHARP (char_pred
))
864 char chr
= SCM_CHAR (char_pred
);
865 while (cstart
< cend
)
867 if (chr
!= cstr
[cstart
])
871 while (cstart
< cend
)
873 if (chr
!= cstr
[cend
- 1])
878 else if (SCM_CHARSETP (char_pred
))
880 while (cstart
< cend
)
882 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
886 while (cstart
< cend
)
888 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
895 SCM_VALIDATE_PROC (2, char_pred
);
896 while (cstart
< cend
)
900 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
901 if (scm_is_false (res
))
903 cstr
= scm_i_string_chars (s
);
906 while (cstart
< cend
)
910 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
911 if (scm_is_false (res
))
913 cstr
= scm_i_string_chars (s
);
917 return scm_c_substring (s
, cstart
, cend
);
922 SCM_DEFINE (scm_substring_fill_x
, "string-fill!", 2, 2, 0,
923 (SCM str
, SCM chr
, SCM start
, SCM end
),
924 "Stores @var{chr} in every element of the given @var{str} and\n"
925 "returns an unspecified value.")
926 #define FUNC_NAME s_scm_substring_fill_x
933 /* Older versions of Guile provided the function
934 scm_substring_fill_x with the following order of arguments:
938 We accomodate this here by detecting such a usage and reordering
949 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
952 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
954 cstr
= scm_i_string_writable_chars (str
);
955 for (k
= cstart
; k
< cend
; k
++)
957 scm_i_string_stop_writing ();
958 return SCM_UNSPECIFIED
;
963 scm_string_fill_x (SCM str
, SCM chr
)
965 return scm_substring_fill_x (str
, chr
, SCM_UNDEFINED
, SCM_UNDEFINED
);
968 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
969 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
970 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
971 "mismatch index, depending upon whether @var{s1} is less than,\n"
972 "equal to, or greater than @var{s2}. The mismatch index is the\n"
973 "largest index @var{i} such that for every 0 <= @var{j} <\n"
974 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
975 "@var{i} is the first position that does not match.")
976 #define FUNC_NAME s_scm_string_compare
978 const char *cstr1
, *cstr2
;
979 size_t cstart1
, cend1
, cstart2
, cend2
;
981 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
984 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
987 SCM_VALIDATE_PROC (3, proc_lt
);
988 SCM_VALIDATE_PROC (4, proc_eq
);
989 SCM_VALIDATE_PROC (5, proc_gt
);
991 while (cstart1
< cend1
&& cstart2
< cend2
)
993 if (cstr1
[cstart1
] < cstr2
[cstart2
])
994 return scm_call_1 (proc_lt
, scm_from_size_t (cstart1
));
995 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
996 return scm_call_1 (proc_gt
, scm_from_size_t (cstart1
));
1000 if (cstart1
< cend1
)
1001 return scm_call_1 (proc_gt
, scm_from_size_t (cstart1
));
1002 else if (cstart2
< cend2
)
1003 return scm_call_1 (proc_lt
, scm_from_size_t (cstart1
));
1005 return scm_call_1 (proc_eq
, scm_from_size_t (cstart1
));
1010 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
1011 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1012 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1013 "mismatch index, depending upon whether @var{s1} is less than,\n"
1014 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1015 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1016 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1017 "@var{i} is the first position that does not match. The\n"
1018 "character comparison is done case-insensitively.")
1019 #define FUNC_NAME s_scm_string_compare_ci
1021 const char *cstr1
, *cstr2
;
1022 size_t cstart1
, cend1
, cstart2
, cend2
;
1024 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1027 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1030 SCM_VALIDATE_PROC (3, proc_lt
);
1031 SCM_VALIDATE_PROC (4, proc_eq
);
1032 SCM_VALIDATE_PROC (5, proc_gt
);
1034 while (cstart1
< cend1
&& cstart2
< cend2
)
1036 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1037 return scm_call_1 (proc_lt
, scm_from_size_t (cstart1
));
1038 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1039 return scm_call_1 (proc_gt
, scm_from_size_t (cstart1
));
1043 if (cstart1
< cend1
)
1044 return scm_call_1 (proc_gt
, scm_from_size_t (cstart1
));
1045 else if (cstart2
< cend2
)
1046 return scm_call_1 (proc_lt
, scm_from_size_t (cstart1
));
1048 return scm_call_1 (proc_eq
, scm_from_size_t (cstart1
));
1053 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
1054 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1055 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1057 #define FUNC_NAME s_scm_string_eq
1059 const char *cstr1
, *cstr2
;
1060 size_t cstart1
, cend1
, cstart2
, cend2
;
1062 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1065 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1069 if ((cend1
- cstart1
) != (cend2
- cstart2
))
1072 while (cstart1
< cend1
)
1074 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1076 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1082 scm_remember_upto_here_2 (s1
, s2
);
1083 return scm_from_size_t (cstart1
);
1086 scm_remember_upto_here_2 (s1
, s2
);
1092 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
1093 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1094 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1096 #define FUNC_NAME s_scm_string_neq
1098 const char *cstr1
, *cstr2
;
1099 size_t cstart1
, cend1
, cstart2
, cend2
;
1101 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1104 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1108 while (cstart1
< cend1
&& cstart2
< cend2
)
1110 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1112 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1117 if (cstart1
< cend1
)
1119 else if (cstart2
< cend2
)
1125 scm_remember_upto_here_2 (s1
, s2
);
1126 return scm_from_size_t (cstart1
);
1129 scm_remember_upto_here_2 (s1
, s2
);
1135 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1136 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1137 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1138 "true value otherwise.")
1139 #define FUNC_NAME s_scm_string_lt
1141 const char *cstr1
, *cstr2
;
1142 size_t cstart1
, cend1
, cstart2
, cend2
;
1144 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1147 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1151 while (cstart1
< cend1
&& cstart2
< cend2
)
1153 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1155 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1160 if (cstart1
< cend1
)
1162 else if (cstart2
< cend2
)
1168 scm_remember_upto_here_2 (s1
, s2
);
1169 return scm_from_size_t (cstart1
);
1172 scm_remember_upto_here_2 (s1
, s2
);
1178 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1179 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1180 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1181 "true value otherwise.")
1182 #define FUNC_NAME s_scm_string_gt
1184 const char *cstr1
, *cstr2
;
1185 size_t cstart1
, cend1
, cstart2
, cend2
;
1187 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1190 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1194 while (cstart1
< cend1
&& cstart2
< cend2
)
1196 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1198 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1203 if (cstart1
< cend1
)
1205 else if (cstart2
< cend2
)
1211 scm_remember_upto_here_2 (s1
, s2
);
1212 return scm_from_size_t (cstart1
);
1215 scm_remember_upto_here_2 (s1
, s2
);
1221 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1222 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1223 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1225 #define FUNC_NAME s_scm_string_le
1227 const char *cstr1
, *cstr2
;
1228 size_t cstart1
, cend1
, cstart2
, cend2
;
1230 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1233 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1237 while (cstart1
< cend1
&& cstart2
< cend2
)
1239 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1241 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1246 if (cstart1
< cend1
)
1248 else if (cstart2
< cend2
)
1254 scm_remember_upto_here_2 (s1
, s2
);
1255 return scm_from_size_t (cstart1
);
1258 scm_remember_upto_here_2 (s1
, s2
);
1264 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1265 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1266 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1268 #define FUNC_NAME s_scm_string_ge
1270 const char *cstr1
, *cstr2
;
1271 size_t cstart1
, cend1
, cstart2
, cend2
;
1273 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1276 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1280 while (cstart1
< cend1
&& cstart2
< cend2
)
1282 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1284 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1289 if (cstart1
< cend1
)
1291 else if (cstart2
< cend2
)
1297 scm_remember_upto_here_2 (s1
, s2
);
1298 return scm_from_size_t (cstart1
);
1301 scm_remember_upto_here_2 (s1
, s2
);
1307 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1308 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1309 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1310 "value otherwise. The character comparison is done\n"
1311 "case-insensitively.")
1312 #define FUNC_NAME s_scm_string_ci_eq
1314 const char *cstr1
, *cstr2
;
1315 size_t cstart1
, cend1
, cstart2
, cend2
;
1317 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1320 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1324 while (cstart1
< cend1
&& cstart2
< cend2
)
1326 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1328 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1333 if (cstart1
< cend1
)
1335 else if (cstart2
< cend2
)
1341 scm_remember_upto_here_2 (s1
, s2
);
1342 return scm_from_size_t (cstart1
);
1345 scm_remember_upto_here_2 (s1
, s2
);
1351 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1352 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1353 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1354 "value otherwise. The character comparison is done\n"
1355 "case-insensitively.")
1356 #define FUNC_NAME s_scm_string_ci_neq
1358 const char *cstr1
, *cstr2
;
1359 size_t cstart1
, cend1
, cstart2
, cend2
;
1361 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1364 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1368 while (cstart1
< cend1
&& cstart2
< cend2
)
1370 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1372 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1377 if (cstart1
< cend1
)
1379 else if (cstart2
< cend2
)
1385 scm_remember_upto_here_2 (s1
, s2
);
1386 return scm_from_size_t (cstart1
);
1389 scm_remember_upto_here_2 (s1
, s2
);
1395 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1396 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1397 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1398 "true value otherwise. The character comparison is done\n"
1399 "case-insensitively.")
1400 #define FUNC_NAME s_scm_string_ci_lt
1402 const char *cstr1
, *cstr2
;
1403 size_t cstart1
, cend1
, cstart2
, cend2
;
1405 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1408 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1412 while (cstart1
< cend1
&& cstart2
< cend2
)
1414 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1416 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1421 if (cstart1
< cend1
)
1423 else if (cstart2
< cend2
)
1429 scm_remember_upto_here_2 (s1
, s2
);
1430 return scm_from_size_t (cstart1
);
1433 scm_remember_upto_here_2 (s1
, s2
);
1439 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1440 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1441 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1442 "true value otherwise. The character comparison is done\n"
1443 "case-insensitively.")
1444 #define FUNC_NAME s_scm_string_ci_gt
1446 const char *cstr1
, *cstr2
;
1447 size_t cstart1
, cend1
, cstart2
, cend2
;
1449 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1452 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1456 while (cstart1
< cend1
&& cstart2
< cend2
)
1458 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1460 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1465 if (cstart1
< cend1
)
1467 else if (cstart2
< cend2
)
1473 scm_remember_upto_here_2 (s1
, s2
);
1474 return scm_from_size_t (cstart1
);
1477 scm_remember_upto_here_2 (s1
, s2
);
1483 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1484 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1485 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1486 "value otherwise. The character comparison is done\n"
1487 "case-insensitively.")
1488 #define FUNC_NAME s_scm_string_ci_le
1490 const char *cstr1
, *cstr2
;
1491 size_t cstart1
, cend1
, cstart2
, cend2
;
1493 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1496 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1500 while (cstart1
< cend1
&& cstart2
< cend2
)
1502 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1504 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1509 if (cstart1
< cend1
)
1511 else if (cstart2
< cend2
)
1517 scm_remember_upto_here_2 (s1
, s2
);
1518 return scm_from_size_t (cstart1
);
1521 scm_remember_upto_here_2 (s1
, s2
);
1527 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1528 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1529 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1530 "otherwise. The character comparison is done\n"
1531 "case-insensitively.")
1532 #define FUNC_NAME s_scm_string_ci_ge
1534 const char *cstr1
, *cstr2
;
1535 size_t cstart1
, cend1
, cstart2
, cend2
;
1537 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1540 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1544 while (cstart1
< cend1
&& cstart2
< cend2
)
1546 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1548 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1553 if (cstart1
< cend1
)
1555 else if (cstart2
< cend2
)
1561 scm_remember_upto_here_2 (s1
, s2
);
1562 return scm_from_size_t (cstart1
);
1565 scm_remember_upto_here_2 (s1
, s2
);
1570 SCM_DEFINE (scm_substring_hash
, "string-hash", 1, 3, 0,
1571 (SCM s
, SCM bound
, SCM start
, SCM end
),
1572 "Compute a hash value for @var{S}. the optional argument "
1573 "@var{bound} is a non-negative exact "
1574 "integer specifying the range of the hash function. "
1575 "A positive value restricts the return value to the "
1577 #define FUNC_NAME s_scm_substring_hash
1579 if (SCM_UNBNDP (bound
))
1580 bound
= scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM
);
1581 if (SCM_UNBNDP (start
))
1583 return scm_hash (scm_substring_shared (s
, start
, end
), bound
);
1587 SCM_DEFINE (scm_substring_hash_ci
, "string-hash-ci", 1, 3, 0,
1588 (SCM s
, SCM bound
, SCM start
, SCM end
),
1589 "Compute a hash value for @var{S}. the optional argument "
1590 "@var{bound} is a non-negative exact "
1591 "integer specifying the range of the hash function. "
1592 "A positive value restricts the return value to the "
1594 #define FUNC_NAME s_scm_substring_hash_ci
1596 return scm_substring_hash (scm_substring_downcase (s
, start
, end
),
1598 SCM_UNDEFINED
, SCM_UNDEFINED
);
1602 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1603 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1604 "Return the length of the longest common prefix of the two\n"
1606 #define FUNC_NAME s_scm_string_prefix_length
1608 const char *cstr1
, *cstr2
;
1609 size_t cstart1
, cend1
, cstart2
, cend2
;
1612 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1615 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1618 while (cstart1
< cend1
&& cstart2
< cend2
)
1620 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1621 return scm_from_size_t (len
);
1626 return scm_from_size_t (len
);
1631 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1632 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1633 "Return the length of the longest common prefix of the two\n"
1634 "strings, ignoring character case.")
1635 #define FUNC_NAME s_scm_string_prefix_length_ci
1637 const char *cstr1
, *cstr2
;
1638 size_t cstart1
, cend1
, cstart2
, cend2
;
1641 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1644 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1647 while (cstart1
< cend1
&& cstart2
< cend2
)
1649 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1650 return scm_from_size_t (len
);
1655 return scm_from_size_t (len
);
1660 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1661 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1662 "Return the length of the longest common suffix of the two\n"
1664 #define FUNC_NAME s_scm_string_suffix_length
1666 const char *cstr1
, *cstr2
;
1667 size_t cstart1
, cend1
, cstart2
, cend2
;
1670 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1673 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1676 while (cstart1
< cend1
&& cstart2
< cend2
)
1680 if (cstr1
[cend1
] != cstr2
[cend2
])
1681 return scm_from_size_t (len
);
1684 return scm_from_size_t (len
);
1689 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1690 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1691 "Return the length of the longest common suffix of the two\n"
1692 "strings, ignoring character case.")
1693 #define FUNC_NAME s_scm_string_suffix_length_ci
1695 const char *cstr1
, *cstr2
;
1696 size_t cstart1
, cend1
, cstart2
, cend2
;
1699 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1702 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1705 while (cstart1
< cend1
&& cstart2
< cend2
)
1709 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1710 return scm_from_size_t (len
);
1713 return scm_from_size_t (len
);
1718 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1719 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1720 "Is @var{s1} a prefix of @var{s2}?")
1721 #define FUNC_NAME s_scm_string_prefix_p
1723 const char *cstr1
, *cstr2
;
1724 size_t cstart1
, cend1
, cstart2
, cend2
;
1725 size_t len
= 0, len1
;
1727 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1730 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1733 len1
= cend1
- cstart1
;
1734 while (cstart1
< cend1
&& cstart2
< cend2
)
1736 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1737 return scm_from_bool (len
== len1
);
1742 return scm_from_bool (len
== len1
);
1747 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1748 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1749 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1750 #define FUNC_NAME s_scm_string_prefix_ci_p
1752 const char *cstr1
, *cstr2
;
1753 size_t cstart1
, cend1
, cstart2
, cend2
;
1754 size_t len
= 0, len1
;
1756 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1759 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1762 len1
= cend1
- cstart1
;
1763 while (cstart1
< cend1
&& cstart2
< cend2
)
1765 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1766 return scm_from_bool (len
== len1
);
1771 return scm_from_bool (len
== len1
);
1776 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1777 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1778 "Is @var{s1} a suffix of @var{s2}?")
1779 #define FUNC_NAME s_scm_string_suffix_p
1781 const char *cstr1
, *cstr2
;
1782 size_t cstart1
, cend1
, cstart2
, cend2
;
1783 size_t len
= 0, len1
;
1785 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1788 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1791 len1
= cend1
- cstart1
;
1792 while (cstart1
< cend1
&& cstart2
< cend2
)
1796 if (cstr1
[cend1
] != cstr2
[cend2
])
1797 return scm_from_bool (len
== len1
);
1800 return scm_from_bool (len
== len1
);
1805 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1806 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1807 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1808 #define FUNC_NAME s_scm_string_suffix_ci_p
1810 const char *cstr1
, *cstr2
;
1811 size_t cstart1
, cend1
, cstart2
, cend2
;
1812 size_t len
= 0, len1
;
1814 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1817 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1820 len1
= cend1
- cstart1
;
1821 while (cstart1
< cend1
&& cstart2
< cend2
)
1825 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1826 return scm_from_bool (len
== len1
);
1829 return scm_from_bool (len
== len1
);
1834 SCM_DEFINE (scm_string_index
, "string-index", 2, 2, 0,
1835 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1836 "Search through the string @var{s} from left to right, returning\n"
1837 "the index of the first occurence of a character which\n"
1839 "@itemize @bullet\n"
1841 "equals @var{char_pred}, if it is character,\n"
1844 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1847 "is in the set @var{char_pred}, if it is a character set.\n"
1849 #define FUNC_NAME s_scm_string_index
1852 size_t cstart
, cend
;
1854 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1857 if (SCM_CHARP (char_pred
))
1859 char cchr
= SCM_CHAR (char_pred
);
1860 while (cstart
< cend
)
1862 if (cchr
== cstr
[cstart
])
1863 return scm_from_size_t (cstart
);
1867 else if (SCM_CHARSETP (char_pred
))
1869 while (cstart
< cend
)
1871 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1872 return scm_from_size_t (cstart
);
1878 SCM_VALIDATE_PROC (2, char_pred
);
1879 while (cstart
< cend
)
1882 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1883 if (scm_is_true (res
))
1884 return scm_from_size_t (cstart
);
1885 cstr
= scm_i_string_chars (s
);
1893 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1894 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1895 "Search through the string @var{s} from right to left, returning\n"
1896 "the index of the last occurence of a character which\n"
1898 "@itemize @bullet\n"
1900 "equals @var{char_pred}, if it is character,\n"
1903 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1906 "is in the set if @var{char_pred} is a character set.\n"
1908 #define FUNC_NAME s_scm_string_index_right
1911 size_t cstart
, cend
;
1913 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1916 if (SCM_CHARP (char_pred
))
1918 char cchr
= SCM_CHAR (char_pred
);
1919 while (cstart
< cend
)
1922 if (cchr
== cstr
[cend
])
1923 return scm_from_size_t (cend
);
1926 else if (SCM_CHARSETP (char_pred
))
1928 while (cstart
< cend
)
1931 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1932 return scm_from_size_t (cend
);
1937 SCM_VALIDATE_PROC (2, char_pred
);
1938 while (cstart
< cend
)
1942 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1943 if (scm_is_true (res
))
1944 return scm_from_size_t (cend
);
1945 cstr
= scm_i_string_chars (s
);
1952 SCM_DEFINE (scm_string_rindex
, "string-rindex", 2, 2, 0,
1953 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1954 "Search through the string @var{s} from right to left, returning\n"
1955 "the index of the last occurence of a character which\n"
1957 "@itemize @bullet\n"
1959 "equals @var{char_pred}, if it is character,\n"
1962 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1965 "is in the set if @var{char_pred} is a character set.\n"
1968 return scm_string_index_right (s
, char_pred
, start
, end
);
1971 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1972 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1973 "Search through the string @var{s} from left to right, returning\n"
1974 "the index of the first occurence of a character which\n"
1976 "@itemize @bullet\n"
1978 "does not equal @var{char_pred}, if it is character,\n"
1981 "does not satisify the predicate @var{char_pred}, if it is a\n"
1985 "is not in the set if @var{char_pred} is a character set.\n"
1987 #define FUNC_NAME s_scm_string_skip
1990 size_t cstart
, cend
;
1992 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1995 if (SCM_CHARP (char_pred
))
1997 char cchr
= SCM_CHAR (char_pred
);
1998 while (cstart
< cend
)
2000 if (cchr
!= cstr
[cstart
])
2001 return scm_from_size_t (cstart
);
2005 else if (SCM_CHARSETP (char_pred
))
2007 while (cstart
< cend
)
2009 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2010 return scm_from_size_t (cstart
);
2016 SCM_VALIDATE_PROC (2, char_pred
);
2017 while (cstart
< cend
)
2020 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2021 if (scm_is_false (res
))
2022 return scm_from_size_t (cstart
);
2023 cstr
= scm_i_string_chars (s
);
2032 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2033 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2034 "Search through the string @var{s} from right to left, returning\n"
2035 "the index of the last occurence of a character which\n"
2037 "@itemize @bullet\n"
2039 "does not equal @var{char_pred}, if it is character,\n"
2042 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2046 "is not in the set if @var{char_pred} is a character set.\n"
2048 #define FUNC_NAME s_scm_string_skip_right
2051 size_t cstart
, cend
;
2053 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2056 if (SCM_CHARP (char_pred
))
2058 char cchr
= SCM_CHAR (char_pred
);
2059 while (cstart
< cend
)
2062 if (cchr
!= cstr
[cend
])
2063 return scm_from_size_t (cend
);
2066 else if (SCM_CHARSETP (char_pred
))
2068 while (cstart
< cend
)
2071 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2072 return scm_from_size_t (cend
);
2077 SCM_VALIDATE_PROC (2, char_pred
);
2078 while (cstart
< cend
)
2082 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2083 if (scm_is_false (res
))
2084 return scm_from_size_t (cend
);
2085 cstr
= scm_i_string_chars (s
);
2093 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2094 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2095 "Return the count of the number of characters in the string\n"
2098 "@itemize @bullet\n"
2100 "equals @var{char_pred}, if it is character,\n"
2103 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2106 "is in the set @var{char_pred}, if it is a character set.\n"
2108 #define FUNC_NAME s_scm_string_count
2111 size_t cstart
, cend
;
2114 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2117 if (SCM_CHARP (char_pred
))
2119 char cchr
= SCM_CHAR (char_pred
);
2120 while (cstart
< cend
)
2122 if (cchr
== cstr
[cstart
])
2127 else if (SCM_CHARSETP (char_pred
))
2129 while (cstart
< cend
)
2131 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2138 SCM_VALIDATE_PROC (2, char_pred
);
2139 while (cstart
< cend
)
2142 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2143 if (scm_is_true (res
))
2145 cstr
= scm_i_string_chars (s
);
2149 return scm_from_size_t (count
);
2154 /* FIXME::martin: This should definitely get implemented more
2155 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2157 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2158 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2159 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2160 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2161 "The optional start/end indices restrict the operation to the\n"
2162 "indicated substrings.")
2163 #define FUNC_NAME s_scm_string_contains
2165 const char *cs1
, * cs2
;
2166 size_t cstart1
, cend1
, cstart2
, cend2
;
2169 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2172 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2175 len2
= cend2
- cstart2
;
2176 while (cstart1
<= cend1
- len2
)
2180 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2186 return scm_from_size_t (cstart1
);
2194 /* FIXME::martin: This should definitely get implemented more
2195 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2197 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2198 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2199 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2200 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2201 "The optional start/end indices restrict the operation to the\n"
2202 "indicated substrings. Character comparison is done\n"
2203 "case-insensitively.")
2204 #define FUNC_NAME s_scm_string_contains_ci
2206 const char *cs1
, * cs2
;
2207 size_t cstart1
, cend1
, cstart2
, cend2
;
2210 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2213 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2216 len2
= cend2
- cstart2
;
2217 while (cstart1
<= cend1
- len2
)
2221 while (i
< cend1
&& j
< cend2
&&
2222 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2228 return scm_from_size_t (cstart1
);
2236 /* Helper function for the string uppercase conversion functions.
2237 * No argument checking is performed. */
2239 string_upcase_x (SCM v
, int start
, int end
)
2244 dst
= scm_i_string_writable_chars (v
);
2245 for (k
= start
; k
< end
; ++k
)
2246 dst
[k
] = scm_c_upcase (dst
[k
]);
2247 scm_i_string_stop_writing ();
2252 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2253 (SCM str
, SCM start
, SCM end
),
2254 "Destructively upcase every character in @code{str}.\n"
2257 "(string-upcase! y)\n"
2258 "@result{} \"ARRDEFG\"\n"
2260 "@result{} \"ARRDEFG\"\n"
2262 #define FUNC_NAME s_scm_substring_upcase_x
2265 size_t cstart
, cend
;
2267 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2270 return string_upcase_x (str
, cstart
, cend
);
2275 scm_string_upcase_x (SCM str
)
2277 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2280 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2281 (SCM str
, SCM start
, SCM end
),
2282 "Upcase every character in @code{str}.")
2283 #define FUNC_NAME s_scm_substring_upcase
2286 size_t cstart
, cend
;
2288 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2291 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2296 scm_string_upcase (SCM str
)
2298 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2301 /* Helper function for the string lowercase conversion functions.
2302 * No argument checking is performed. */
2304 string_downcase_x (SCM v
, int start
, int end
)
2309 dst
= scm_i_string_writable_chars (v
);
2310 for (k
= start
; k
< end
; ++k
)
2311 dst
[k
] = scm_c_downcase (dst
[k
]);
2312 scm_i_string_stop_writing ();
2317 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2318 (SCM str
, SCM start
, SCM end
),
2319 "Destructively downcase every character in @var{str}.\n"
2323 "@result{} \"ARRDEFG\"\n"
2324 "(string-downcase! y)\n"
2325 "@result{} \"arrdefg\"\n"
2327 "@result{} \"arrdefg\"\n"
2329 #define FUNC_NAME s_scm_substring_downcase_x
2332 size_t cstart
, cend
;
2334 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2337 return string_downcase_x (str
, cstart
, cend
);
2342 scm_string_downcase_x (SCM str
)
2344 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2347 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2348 (SCM str
, SCM start
, SCM end
),
2349 "Downcase every character in @var{str}.")
2350 #define FUNC_NAME s_scm_substring_downcase
2353 size_t cstart
, cend
;
2355 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2358 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2363 scm_string_downcase (SCM str
)
2365 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2368 /* Helper function for the string capitalization functions.
2369 * No argument checking is performed. */
2371 string_titlecase_x (SCM str
, int start
, int end
)
2377 sz
= scm_i_string_writable_chars (str
);
2378 for(i
= start
; i
< end
; i
++)
2380 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2384 sz
[i
] = scm_c_upcase(sz
[i
]);
2389 sz
[i
] = scm_c_downcase(sz
[i
]);
2395 scm_i_string_stop_writing ();
2401 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2402 (SCM str
, SCM start
, SCM end
),
2403 "Destructively titlecase every first character in a word in\n"
2405 #define FUNC_NAME s_scm_string_titlecase_x
2408 size_t cstart
, cend
;
2410 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2413 return string_titlecase_x (str
, cstart
, cend
);
2418 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2419 (SCM str
, SCM start
, SCM end
),
2420 "Titlecase every first character in a word in @var{str}.")
2421 #define FUNC_NAME s_scm_string_titlecase
2424 size_t cstart
, cend
;
2426 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2429 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2433 /* Old names, the functions.
2436 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2438 "Upcase the first character of every word in @var{str}\n"
2439 "destructively and return @var{str}.\n"
2442 "y @result{} \"hello world\"\n"
2443 "(string-capitalize! y) @result{} \"Hello World\"\n"
2444 "y @result{} \"Hello World\"\n"
2446 #define FUNC_NAME s_scm_string_capitalize_x
2448 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2453 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2455 "Return a freshly allocated string with the characters in\n"
2456 "@var{str}, where the first character of every word is\n"
2458 #define FUNC_NAME s_scm_string_capitalize
2460 return scm_string_capitalize_x (scm_string_copy (str
));
2465 /* Reverse the portion of @var{str} between str[cstart] (including)
2466 and str[cend] excluding. */
2468 string_reverse_x (char * str
, int cstart
, int cend
)
2473 while (cstart
< cend
)
2476 str
[cstart
] = str
[cend
];
2484 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2485 (SCM str
, SCM start
, SCM end
),
2486 "Reverse the string @var{str}. The optional arguments\n"
2487 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2489 #define FUNC_NAME s_scm_string_reverse
2493 size_t cstart
, cend
;
2496 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2499 result
= scm_string_copy (str
);
2500 ctarget
= scm_i_string_writable_chars (result
);
2501 string_reverse_x (ctarget
, cstart
, cend
);
2502 scm_i_string_stop_writing ();
2508 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2509 (SCM str
, SCM start
, SCM end
),
2510 "Reverse the string @var{str} in-place. The optional arguments\n"
2511 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2512 "operate on. The return value is unspecified.")
2513 #define FUNC_NAME s_scm_string_reverse_x
2516 size_t cstart
, cend
;
2518 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2522 cstr
= scm_i_string_writable_chars (str
);
2523 string_reverse_x (cstr
, cstart
, cend
);
2524 scm_i_string_stop_writing ();
2526 scm_remember_upto_here_1 (str
);
2527 return SCM_UNSPECIFIED
;
2532 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2534 "Like @code{string-append}, but the result may share memory\n"
2535 "with the argument strings.")
2536 #define FUNC_NAME s_scm_string_append_shared
2540 SCM_VALIDATE_REST_ARGUMENT (ls
);
2542 /* Optimize the one-argument case. */
2543 i
= scm_ilength (ls
);
2545 return SCM_CAR (ls
);
2547 return scm_string_append (ls
);
2552 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2554 "Append the elements of @var{ls} (which must be strings)\n"
2555 "together into a single string. Guaranteed to return a freshly\n"
2556 "allocated string.")
2557 #define FUNC_NAME s_scm_string_concatenate
2559 return scm_string_append (ls
);
2564 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2565 (SCM ls
, SCM final_string
, SCM end
),
2566 "Without optional arguments, this procedure is equivalent to\n"
2569 "(string-concatenate (reverse ls))\n"
2572 "If the optional argument @var{final_string} is specified, it is\n"
2573 "consed onto the beginning to @var{ls} before performing the\n"
2574 "list-reverse and string-concatenate operations. If @var{end}\n"
2575 "is given, only the characters of @var{final_string} up to index\n"
2576 "@var{end} are used.\n"
2578 "Guaranteed to return a freshly allocated string.")
2579 #define FUNC_NAME s_scm_string_concatenate_reverse
2587 /* Check the optional arguments and calculate the additional length
2588 of the result string. */
2589 if (!SCM_UNBNDP (final_string
))
2591 SCM_VALIDATE_STRING (2, final_string
);
2592 if (!SCM_UNBNDP (end
))
2594 cend
= scm_to_unsigned_integer (end
,
2596 scm_i_string_length (final_string
));
2600 cend
= scm_i_string_length (final_string
);
2604 strings
= scm_ilength (ls
);
2605 /* Validate the string list. */
2607 SCM_WRONG_TYPE_ARG (1, ls
);
2609 /* Calculate the length of the result string. */
2611 while (!SCM_NULLP (tmp
))
2613 SCM elt
= SCM_CAR (tmp
);
2614 SCM_VALIDATE_STRING (1, elt
);
2615 len
+= scm_i_string_length (elt
);
2616 tmp
= SCM_CDR (tmp
);
2619 result
= scm_i_make_string (len
, &p
);
2623 /* Construct the result string, possibly by using the optional final
2625 if (!SCM_UNBNDP (final_string
))
2628 memmove (p
, scm_i_string_chars (final_string
), cend
);
2631 while (!SCM_NULLP (tmp
))
2633 SCM elt
= SCM_CAR (tmp
);
2634 p
-= scm_i_string_length (elt
);
2635 memmove (p
, scm_i_string_chars (elt
),
2636 scm_i_string_length (elt
));
2637 tmp
= SCM_CDR (tmp
);
2644 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2646 "Like @code{string-concatenate}, but the result may share memory\n"
2647 "with the strings in the list @var{ls}.")
2648 #define FUNC_NAME s_scm_string_concatenate_shared
2650 return scm_string_append_shared (ls
);
2655 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2656 (SCM ls
, SCM final_string
, SCM end
),
2657 "Like @code{string-concatenate-reverse}, but the result may\n"
2658 "share memory with the the strings in the @var{ls} arguments.")
2659 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2661 /* Just call the non-sharing version. */
2662 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2667 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2668 (SCM proc
, SCM s
, SCM start
, SCM end
),
2669 "@var{proc} is a char->char procedure, it is mapped over\n"
2670 "@var{s}. The order in which the procedure is applied to the\n"
2671 "string elements is not specified.")
2672 #define FUNC_NAME s_scm_string_map
2676 size_t cstart
, cend
;
2679 SCM_VALIDATE_PROC (1, proc
);
2680 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2683 result
= scm_i_make_string (cend
- cstart
, &p
);
2684 while (cstart
< cend
)
2686 unsigned int c
= (unsigned char) cstr
[cstart
];
2687 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2688 if (!SCM_CHARP (ch
))
2689 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2690 cstr
= scm_i_string_chars (s
);
2692 *p
++ = SCM_CHAR (ch
);
2699 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2700 (SCM proc
, SCM s
, SCM start
, SCM end
),
2701 "@var{proc} is a char->char procedure, it is mapped over\n"
2702 "@var{s}. The order in which the procedure is applied to the\n"
2703 "string elements is not specified. The string @var{s} is\n"
2704 "modified in-place, the return value is not specified.")
2705 #define FUNC_NAME s_scm_string_map_x
2707 size_t cstart
, cend
;
2709 SCM_VALIDATE_PROC (1, proc
);
2710 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2713 while (cstart
< cend
)
2715 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2716 if (!SCM_CHARP (ch
))
2717 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2718 scm_c_string_set_x (s
, cstart
, ch
);
2721 return SCM_UNSPECIFIED
;
2726 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2727 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2728 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2729 "as the terminating element, from left to right. @var{kons}\n"
2730 "must expect two arguments: The actual character and the last\n"
2731 "result of @var{kons}' application.")
2732 #define FUNC_NAME s_scm_string_fold
2735 size_t cstart
, cend
;
2738 SCM_VALIDATE_PROC (1, kons
);
2739 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2743 while (cstart
< cend
)
2745 unsigned int c
= (unsigned char) cstr
[cstart
];
2746 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2747 cstr
= scm_i_string_chars (s
);
2755 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2756 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2757 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2758 "as the terminating element, from right to left. @var{kons}\n"
2759 "must expect two arguments: The actual character and the last\n"
2760 "result of @var{kons}' application.")
2761 #define FUNC_NAME s_scm_string_fold_right
2764 size_t cstart
, cend
;
2767 SCM_VALIDATE_PROC (1, kons
);
2768 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2772 while (cstart
< cend
)
2774 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2775 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2776 cstr
= scm_i_string_chars (s
);
2784 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2785 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2786 "@itemize @bullet\n"
2787 "@item @var{g} is used to generate a series of @emph{seed}\n"
2788 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2789 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2791 "@item @var{p} tells us when to stop -- when it returns true\n"
2792 "when applied to one of these seed values.\n"
2793 "@item @var{f} maps each seed value to the corresponding\n"
2794 "character in the result string. These chars are assembled\n"
2795 "into the string in a left-to-right order.\n"
2796 "@item @var{base} is the optional initial/leftmost portion\n"
2797 "of the constructed string; it default to the empty\n"
2799 "@item @var{make_final} is applied to the terminal seed\n"
2800 "value (on which @var{p} returns true) to produce\n"
2801 "the final/rightmost portion of the constructed string.\n"
2802 "It defaults to @code{(lambda (x) "")}.\n"
2804 #define FUNC_NAME s_scm_string_unfold
2808 SCM_VALIDATE_PROC (1, p
);
2809 SCM_VALIDATE_PROC (2, f
);
2810 SCM_VALIDATE_PROC (3, g
);
2811 if (!SCM_UNBNDP (base
))
2813 SCM_VALIDATE_STRING (5, base
);
2817 ans
= scm_i_make_string (0, NULL
);
2818 if (!SCM_UNBNDP (make_final
))
2819 SCM_VALIDATE_PROC (6, make_final
);
2821 res
= scm_call_1 (p
, seed
);
2822 while (scm_is_false (res
))
2826 SCM ch
= scm_call_1 (f
, seed
);
2827 if (!SCM_CHARP (ch
))
2828 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2829 str
= scm_i_make_string (1, &ptr
);
2830 *ptr
= SCM_CHAR (ch
);
2832 ans
= scm_string_append (scm_list_2 (ans
, str
));
2833 seed
= scm_call_1 (g
, seed
);
2834 res
= scm_call_1 (p
, seed
);
2836 if (!SCM_UNBNDP (make_final
))
2838 res
= scm_call_1 (make_final
, seed
);
2839 return scm_string_append (scm_list_2 (ans
, res
));
2847 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2848 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2849 "@itemize @bullet\n"
2850 "@item @var{g} is used to generate a series of @emph{seed}\n"
2851 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2852 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2854 "@item @var{p} tells us when to stop -- when it returns true\n"
2855 "when applied to one of these seed values.\n"
2856 "@item @var{f} maps each seed value to the corresponding\n"
2857 "character in the result string. These chars are assembled\n"
2858 "into the string in a right-to-left order.\n"
2859 "@item @var{base} is the optional initial/rightmost portion\n"
2860 "of the constructed string; it default to the empty\n"
2862 "@item @var{make_final} is applied to the terminal seed\n"
2863 "value (on which @var{p} returns true) to produce\n"
2864 "the final/leftmost portion of the constructed string.\n"
2865 "It defaults to @code{(lambda (x) "")}.\n"
2867 #define FUNC_NAME s_scm_string_unfold_right
2871 SCM_VALIDATE_PROC (1, p
);
2872 SCM_VALIDATE_PROC (2, f
);
2873 SCM_VALIDATE_PROC (3, g
);
2874 if (!SCM_UNBNDP (base
))
2876 SCM_VALIDATE_STRING (5, base
);
2880 ans
= scm_i_make_string (0, NULL
);
2881 if (!SCM_UNBNDP (make_final
))
2882 SCM_VALIDATE_PROC (6, make_final
);
2884 res
= scm_call_1 (p
, seed
);
2885 while (scm_is_false (res
))
2889 SCM ch
= scm_call_1 (f
, seed
);
2890 if (!SCM_CHARP (ch
))
2891 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2892 str
= scm_i_make_string (1, &ptr
);
2893 *ptr
= SCM_CHAR (ch
);
2895 ans
= scm_string_append (scm_list_2 (str
, ans
));
2896 seed
= scm_call_1 (g
, seed
);
2897 res
= scm_call_1 (p
, seed
);
2899 if (!SCM_UNBNDP (make_final
))
2901 res
= scm_call_1 (make_final
, seed
);
2902 return scm_string_append (scm_list_2 (res
, ans
));
2910 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2911 (SCM proc
, SCM s
, SCM start
, SCM end
),
2912 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2913 "return value is not specified.")
2914 #define FUNC_NAME s_scm_string_for_each
2917 size_t cstart
, cend
;
2919 SCM_VALIDATE_PROC (1, proc
);
2920 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2923 while (cstart
< cend
)
2925 unsigned int c
= (unsigned char) cstr
[cstart
];
2926 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2927 cstr
= scm_i_string_chars (s
);
2930 return SCM_UNSPECIFIED
;
2934 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2935 (SCM proc
, SCM s
, SCM start
, SCM end
),
2936 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2937 "return value is not specified.")
2938 #define FUNC_NAME s_scm_string_for_each_index
2941 size_t cstart
, cend
;
2943 SCM_VALIDATE_PROC (1, proc
);
2944 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2947 while (cstart
< cend
)
2949 scm_call_1 (proc
, scm_from_size_t (cstart
));
2952 return SCM_UNSPECIFIED
;
2956 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2957 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2958 "This is the @emph{extended substring} procedure that implements\n"
2959 "replicated copying of a substring of some string.\n"
2961 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2962 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2963 "0 and the length of @var{s}. Replicate this substring up and\n"
2964 "down index space, in both the positive and negative directions.\n"
2965 "@code{xsubstring} returns the substring of this string\n"
2966 "beginning at index @var{from}, and ending at @var{to}, which\n"
2967 "defaults to @var{from} + (@var{end} - @var{start}).")
2968 #define FUNC_NAME s_scm_xsubstring
2972 size_t cstart
, cend
, cfrom
, cto
;
2975 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2978 cfrom
= scm_to_size_t (from
);
2979 if (SCM_UNBNDP (to
))
2980 cto
= cfrom
+ (cend
- cstart
);
2982 cto
= scm_to_size_t (to
);
2983 if (cstart
== cend
&& cfrom
!= cto
)
2984 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2986 result
= scm_i_make_string (cto
- cfrom
, &p
);
2990 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2992 *p
= cs
[(cend
- cstart
) - t
];
2998 scm_remember_upto_here_1 (s
);
3004 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
3005 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
3006 "Exactly the same as @code{xsubstring}, but the extracted text\n"
3007 "is written into the string @var{target} starting at index\n"
3008 "@var{tstart}. The operation is not defined if @code{(eq?\n"
3009 "@var{target} @var{s})} or these arguments share storage -- you\n"
3010 "cannot copy a string on top of itself.")
3011 #define FUNC_NAME s_scm_string_xcopy_x
3015 size_t ctstart
, csfrom
, csto
, cstart
, cend
;
3016 SCM dummy
= SCM_UNDEFINED
;
3019 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3022 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
3025 csfrom
= scm_to_size_t (sfrom
);
3026 if (SCM_UNBNDP (sto
))
3027 csto
= csfrom
+ (cend
- cstart
);
3029 csto
= scm_to_size_t (sto
);
3030 if (cstart
== cend
&& csfrom
!= csto
)
3031 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3032 SCM_ASSERT_RANGE (1, tstart
,
3033 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3035 p
= scm_i_string_writable_chars (target
) + ctstart
;
3036 while (csfrom
< csto
)
3038 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3040 *p
= cs
[(cend
- cstart
) - t
];
3046 scm_i_string_stop_writing ();
3048 scm_remember_upto_here_2 (target
, s
);
3049 return SCM_UNSPECIFIED
;
3054 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3055 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3056 "Return the string @var{s1}, but with the characters\n"
3057 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3058 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3059 #define FUNC_NAME s_scm_string_replace
3061 const char *cstr1
, *cstr2
;
3063 size_t cstart1
, cend1
, cstart2
, cend2
;
3066 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
3069 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
3072 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3073 scm_i_string_length (s1
) - cend1
, &p
);
3074 memmove (p
, cstr1
, cstart1
* sizeof (char));
3075 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3076 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3078 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3079 scm_remember_upto_here_2 (s1
, s2
);
3085 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3086 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3087 "Split the string @var{s} into a list of substrings, where each\n"
3088 "substring is a maximal non-empty contiguous sequence of\n"
3089 "characters from the character set @var{token_set}, which\n"
3090 "defaults to @code{char-set:graphic}.\n"
3091 "If @var{start} or @var{end} indices are provided, they restrict\n"
3092 "@code{string-tokenize} to operating on the indicated substring\n"
3094 #define FUNC_NAME s_scm_string_tokenize
3097 size_t cstart
, cend
;
3098 SCM result
= SCM_EOL
;
3100 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3104 if (SCM_UNBNDP (token_set
))
3105 token_set
= scm_char_set_graphic
;
3107 if (SCM_CHARSETP (token_set
))
3111 while (cstart
< cend
)
3113 while (cstart
< cend
)
3115 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3122 while (cstart
< cend
)
3124 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3128 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3129 cstr
= scm_i_string_chars (s
);
3132 else SCM_WRONG_TYPE_ARG (2, token_set
);
3133 scm_remember_upto_here_1 (s
);
3138 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3140 "Split the string @var{str} into the a list of the substrings delimited\n"
3141 "by appearances of the character @var{chr}. Note that an empty substring\n"
3142 "between separator characters will result in an empty string in the\n"
3146 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3148 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3150 "(string-split \"::\" #\\:)\n"
3152 "(\"\" \"\" \"\")\n"
3154 "(string-split \"\" #\\:)\n"
3158 #define FUNC_NAME s_scm_string_split
3165 SCM_VALIDATE_STRING (1, str
);
3166 SCM_VALIDATE_CHAR (2, chr
);
3168 idx
= scm_i_string_length (str
);
3169 p
= scm_i_string_chars (str
);
3170 ch
= SCM_CHAR (chr
);
3174 while (idx
> 0 && p
[idx
- 1] != ch
)
3178 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3179 p
= scm_i_string_chars (str
);
3183 scm_remember_upto_here_1 (str
);
3189 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3190 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3191 "Filter the string @var{s}, retaining only those characters that\n"
3192 "satisfy the @var{char_pred} argument. If the argument is a\n"
3193 "procedure, it is applied to each character as a predicate, if\n"
3194 "it is a character, it is tested for equality and if it is a\n"
3195 "character set, it is tested for membership.")
3196 #define FUNC_NAME s_scm_string_filter
3199 size_t cstart
, cend
;
3203 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3206 if (SCM_CHARP (char_pred
))
3211 chr
= SCM_CHAR (char_pred
);
3215 if (cstr
[idx
] == chr
)
3216 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3217 cstr
= scm_i_string_chars (s
);
3220 result
= scm_reverse_list_to_string (ls
);
3222 else if (SCM_CHARSETP (char_pred
))
3229 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3230 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3231 cstr
= scm_i_string_chars (s
);
3234 result
= scm_reverse_list_to_string (ls
);
3240 SCM_VALIDATE_PROC (2, char_pred
);
3245 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
3246 if (scm_is_true (res
))
3247 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3248 cstr
= scm_i_string_chars (s
);
3251 result
= scm_reverse_list_to_string (ls
);
3253 scm_remember_upto_here_1 (s
);
3259 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3260 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3261 "Filter the string @var{s}, retaining only those characters that\n"
3262 "do not satisfy the @var{char_pred} argument. If the argument\n"
3263 "is a procedure, it is applied to each character as a predicate,\n"
3264 "if it is a character, it is tested for equality and if it is a\n"
3265 "character set, it is tested for membership.")
3266 #define FUNC_NAME s_scm_string_delete
3269 size_t cstart
, cend
;
3273 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3276 if (SCM_CHARP (char_pred
))
3281 chr
= SCM_CHAR (char_pred
);
3285 if (cstr
[idx
] != chr
)
3286 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3287 cstr
= scm_i_string_chars (s
);
3290 result
= scm_reverse_list_to_string (ls
);
3292 else if (SCM_CHARSETP (char_pred
))
3299 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3300 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3301 cstr
= scm_i_string_chars (s
);
3304 result
= scm_reverse_list_to_string (ls
);
3310 SCM_VALIDATE_PROC (2, char_pred
);
3315 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
3316 if (scm_is_false (res
))
3317 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3318 cstr
= scm_i_string_chars (s
);
3321 result
= scm_reverse_list_to_string (ls
);
3328 /* Initialize the SRFI-13 module. This function will be called by the
3329 loading Scheme module. */
3331 scm_init_srfi_13 (void)
3333 #include "libguile/srfi-13.x"
3336 /* End of srfi-13.c. */