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
);
1953 scm_string_rindex (SCM str
, SCM chr
, SCM frm
, SCM to
)
1955 return scm_string_index_right (str
, chr
, frm
, to
);
1958 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1959 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1960 "Search through the string @var{s} from left to right, returning\n"
1961 "the index of the first occurence of a character which\n"
1963 "@itemize @bullet\n"
1965 "does not equal @var{char_pred}, if it is character,\n"
1968 "does not satisify the predicate @var{char_pred}, if it is a\n"
1972 "is not in the set if @var{char_pred} is a character set.\n"
1974 #define FUNC_NAME s_scm_string_skip
1977 size_t cstart
, cend
;
1979 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1982 if (SCM_CHARP (char_pred
))
1984 char cchr
= SCM_CHAR (char_pred
);
1985 while (cstart
< cend
)
1987 if (cchr
!= cstr
[cstart
])
1988 return scm_from_size_t (cstart
);
1992 else if (SCM_CHARSETP (char_pred
))
1994 while (cstart
< cend
)
1996 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1997 return scm_from_size_t (cstart
);
2003 SCM_VALIDATE_PROC (2, char_pred
);
2004 while (cstart
< cend
)
2007 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2008 if (scm_is_false (res
))
2009 return scm_from_size_t (cstart
);
2010 cstr
= scm_i_string_chars (s
);
2019 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
2020 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2021 "Search through the string @var{s} from right to left, returning\n"
2022 "the index of the last occurence of a character which\n"
2024 "@itemize @bullet\n"
2026 "does not equal @var{char_pred}, if it is character,\n"
2029 "does not satisfy the predicate @var{char_pred}, if it is a\n"
2033 "is not in the set if @var{char_pred} is a character set.\n"
2035 #define FUNC_NAME s_scm_string_skip_right
2038 size_t cstart
, cend
;
2040 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2043 if (SCM_CHARP (char_pred
))
2045 char cchr
= SCM_CHAR (char_pred
);
2046 while (cstart
< cend
)
2049 if (cchr
!= cstr
[cend
])
2050 return scm_from_size_t (cend
);
2053 else if (SCM_CHARSETP (char_pred
))
2055 while (cstart
< cend
)
2058 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
2059 return scm_from_size_t (cend
);
2064 SCM_VALIDATE_PROC (2, char_pred
);
2065 while (cstart
< cend
)
2069 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
2070 if (scm_is_false (res
))
2071 return scm_from_size_t (cend
);
2072 cstr
= scm_i_string_chars (s
);
2080 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
2081 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2082 "Return the count of the number of characters in the string\n"
2085 "@itemize @bullet\n"
2087 "equals @var{char_pred}, if it is character,\n"
2090 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
2093 "is in the set @var{char_pred}, if it is a character set.\n"
2095 #define FUNC_NAME s_scm_string_count
2098 size_t cstart
, cend
;
2101 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2104 if (SCM_CHARP (char_pred
))
2106 char cchr
= SCM_CHAR (char_pred
);
2107 while (cstart
< cend
)
2109 if (cchr
== cstr
[cstart
])
2114 else if (SCM_CHARSETP (char_pred
))
2116 while (cstart
< cend
)
2118 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
2125 SCM_VALIDATE_PROC (2, char_pred
);
2126 while (cstart
< cend
)
2129 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
2130 if (scm_is_true (res
))
2132 cstr
= scm_i_string_chars (s
);
2136 return scm_from_size_t (count
);
2141 /* FIXME::martin: This should definitely get implemented more
2142 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2144 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
2145 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2146 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2147 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2148 "The optional start/end indices restrict the operation to the\n"
2149 "indicated substrings.")
2150 #define FUNC_NAME s_scm_string_contains
2152 const char *cs1
, * cs2
;
2153 size_t cstart1
, cend1
, cstart2
, cend2
;
2156 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2159 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2162 len2
= cend2
- cstart2
;
2163 while (cstart1
<= cend1
- len2
)
2167 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
2173 return scm_from_size_t (cstart1
);
2181 /* FIXME::martin: This should definitely get implemented more
2182 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2184 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
2185 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2186 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2187 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2188 "The optional start/end indices restrict the operation to the\n"
2189 "indicated substrings. Character comparison is done\n"
2190 "case-insensitively.")
2191 #define FUNC_NAME s_scm_string_contains_ci
2193 const char *cs1
, * cs2
;
2194 size_t cstart1
, cend1
, cstart2
, cend2
;
2197 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
2200 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
2203 len2
= cend2
- cstart2
;
2204 while (cstart1
<= cend1
- len2
)
2208 while (i
< cend1
&& j
< cend2
&&
2209 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
2215 return scm_from_size_t (cstart1
);
2223 /* Helper function for the string uppercase conversion functions.
2224 * No argument checking is performed. */
2226 string_upcase_x (SCM v
, int start
, int end
)
2231 dst
= scm_i_string_writable_chars (v
);
2232 for (k
= start
; k
< end
; ++k
)
2233 dst
[k
] = scm_c_upcase (dst
[k
]);
2234 scm_i_string_stop_writing ();
2239 SCM_DEFINE (scm_substring_upcase_x
, "string-upcase!", 1, 2, 0,
2240 (SCM str
, SCM start
, SCM end
),
2241 "Destructively upcase every character in @code{str}.\n"
2244 "(string-upcase! y)\n"
2245 "@result{} \"ARRDEFG\"\n"
2247 "@result{} \"ARRDEFG\"\n"
2249 #define FUNC_NAME s_scm_substring_upcase_x
2252 size_t cstart
, cend
;
2254 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2257 return string_upcase_x (str
, cstart
, cend
);
2262 scm_string_upcase_x (SCM str
)
2264 return scm_substring_upcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2267 SCM_DEFINE (scm_substring_upcase
, "string-upcase", 1, 2, 0,
2268 (SCM str
, SCM start
, SCM end
),
2269 "Upcase every character in @code{str}.")
2270 #define FUNC_NAME s_scm_substring_upcase
2273 size_t cstart
, cend
;
2275 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2278 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2283 scm_string_upcase (SCM str
)
2285 return scm_substring_upcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2288 /* Helper function for the string lowercase conversion functions.
2289 * No argument checking is performed. */
2291 string_downcase_x (SCM v
, int start
, int end
)
2296 dst
= scm_i_string_writable_chars (v
);
2297 for (k
= start
; k
< end
; ++k
)
2298 dst
[k
] = scm_c_downcase (dst
[k
]);
2299 scm_i_string_stop_writing ();
2304 SCM_DEFINE (scm_substring_downcase_x
, "string-downcase!", 1, 2, 0,
2305 (SCM str
, SCM start
, SCM end
),
2306 "Destructively downcase every character in @var{str}.\n"
2310 "@result{} \"ARRDEFG\"\n"
2311 "(string-downcase! y)\n"
2312 "@result{} \"arrdefg\"\n"
2314 "@result{} \"arrdefg\"\n"
2316 #define FUNC_NAME s_scm_substring_downcase_x
2319 size_t cstart
, cend
;
2321 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2324 return string_downcase_x (str
, cstart
, cend
);
2329 scm_string_downcase_x (SCM str
)
2331 return scm_substring_downcase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2334 SCM_DEFINE (scm_substring_downcase
, "string-downcase", 1, 2, 0,
2335 (SCM str
, SCM start
, SCM end
),
2336 "Downcase every character in @var{str}.")
2337 #define FUNC_NAME s_scm_substring_downcase
2340 size_t cstart
, cend
;
2342 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2345 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2350 scm_string_downcase (SCM str
)
2352 return scm_substring_downcase (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2355 /* Helper function for the string capitalization functions.
2356 * No argument checking is performed. */
2358 string_titlecase_x (SCM str
, int start
, int end
)
2364 sz
= scm_i_string_writable_chars (str
);
2365 for(i
= start
; i
< end
; i
++)
2367 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2371 sz
[i
] = scm_c_upcase(sz
[i
]);
2376 sz
[i
] = scm_c_downcase(sz
[i
]);
2382 scm_i_string_stop_writing ();
2388 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2389 (SCM str
, SCM start
, SCM end
),
2390 "Destructively titlecase every first character in a word in\n"
2392 #define FUNC_NAME s_scm_string_titlecase_x
2395 size_t cstart
, cend
;
2397 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2400 return string_titlecase_x (str
, cstart
, cend
);
2405 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2406 (SCM str
, SCM start
, SCM end
),
2407 "Titlecase every first character in a word in @var{str}.")
2408 #define FUNC_NAME s_scm_string_titlecase
2411 size_t cstart
, cend
;
2413 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2416 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2420 /* Old names, the functions.
2423 SCM_DEFINE (scm_string_capitalize_x
, "string-capitalize!", 1, 0, 0,
2425 "Upcase the first character of every word in @var{str}\n"
2426 "destructively and return @var{str}.\n"
2429 "y @result{} \"hello world\"\n"
2430 "(string-capitalize! y) @result{} \"Hello World\"\n"
2431 "y @result{} \"Hello World\"\n"
2433 #define FUNC_NAME s_scm_string_capitalize_x
2435 return scm_string_titlecase_x (str
, SCM_UNDEFINED
, SCM_UNDEFINED
);
2440 SCM_DEFINE (scm_string_capitalize
, "string-capitalize", 1, 0, 0,
2442 "Return a freshly allocated string with the characters in\n"
2443 "@var{str}, where the first character of every word is\n"
2445 #define FUNC_NAME s_scm_string_capitalize
2447 return scm_string_capitalize_x (scm_string_copy (str
));
2452 /* Reverse the portion of @var{str} between str[cstart] (including)
2453 and str[cend] excluding. */
2455 string_reverse_x (char * str
, int cstart
, int cend
)
2460 while (cstart
< cend
)
2463 str
[cstart
] = str
[cend
];
2471 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2472 (SCM str
, SCM start
, SCM end
),
2473 "Reverse the string @var{str}. The optional arguments\n"
2474 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2476 #define FUNC_NAME s_scm_string_reverse
2480 size_t cstart
, cend
;
2483 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2486 result
= scm_string_copy (str
);
2487 ctarget
= scm_i_string_writable_chars (result
);
2488 string_reverse_x (ctarget
, cstart
, cend
);
2489 scm_i_string_stop_writing ();
2495 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2496 (SCM str
, SCM start
, SCM end
),
2497 "Reverse the string @var{str} in-place. The optional arguments\n"
2498 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2499 "operate on. The return value is unspecified.")
2500 #define FUNC_NAME s_scm_string_reverse_x
2503 size_t cstart
, cend
;
2505 MY_VALIDATE_SUBSTRING_SPEC (1, str
,
2509 cstr
= scm_i_string_writable_chars (str
);
2510 string_reverse_x (cstr
, cstart
, cend
);
2511 scm_i_string_stop_writing ();
2513 scm_remember_upto_here_1 (str
);
2514 return SCM_UNSPECIFIED
;
2519 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2521 "Like @code{string-append}, but the result may share memory\n"
2522 "with the argument strings.")
2523 #define FUNC_NAME s_scm_string_append_shared
2527 SCM_VALIDATE_REST_ARGUMENT (ls
);
2529 /* Optimize the one-argument case. */
2530 i
= scm_ilength (ls
);
2532 return SCM_CAR (ls
);
2534 return scm_string_append (ls
);
2539 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2541 "Append the elements of @var{ls} (which must be strings)\n"
2542 "together into a single string. Guaranteed to return a freshly\n"
2543 "allocated string.")
2544 #define FUNC_NAME s_scm_string_concatenate
2546 return scm_string_append (ls
);
2551 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2552 (SCM ls
, SCM final_string
, SCM end
),
2553 "Without optional arguments, this procedure is equivalent to\n"
2556 "(string-concatenate (reverse ls))\n"
2559 "If the optional argument @var{final_string} is specified, it is\n"
2560 "consed onto the beginning to @var{ls} before performing the\n"
2561 "list-reverse and string-concatenate operations. If @var{end}\n"
2562 "is given, only the characters of @var{final_string} up to index\n"
2563 "@var{end} are used.\n"
2565 "Guaranteed to return a freshly allocated string.")
2566 #define FUNC_NAME s_scm_string_concatenate_reverse
2574 /* Check the optional arguments and calculate the additional length
2575 of the result string. */
2576 if (!SCM_UNBNDP (final_string
))
2578 SCM_VALIDATE_STRING (2, final_string
);
2579 if (!SCM_UNBNDP (end
))
2581 cend
= scm_to_unsigned_integer (end
,
2583 scm_i_string_length (final_string
));
2587 cend
= scm_i_string_length (final_string
);
2591 strings
= scm_ilength (ls
);
2592 /* Validate the string list. */
2594 SCM_WRONG_TYPE_ARG (1, ls
);
2596 /* Calculate the length of the result string. */
2598 while (!SCM_NULLP (tmp
))
2600 SCM elt
= SCM_CAR (tmp
);
2601 SCM_VALIDATE_STRING (1, elt
);
2602 len
+= scm_i_string_length (elt
);
2603 tmp
= SCM_CDR (tmp
);
2606 result
= scm_i_make_string (len
, &p
);
2610 /* Construct the result string, possibly by using the optional final
2612 if (!SCM_UNBNDP (final_string
))
2615 memmove (p
, scm_i_string_chars (final_string
), cend
);
2618 while (!SCM_NULLP (tmp
))
2620 SCM elt
= SCM_CAR (tmp
);
2621 p
-= scm_i_string_length (elt
);
2622 memmove (p
, scm_i_string_chars (elt
),
2623 scm_i_string_length (elt
));
2624 tmp
= SCM_CDR (tmp
);
2631 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2633 "Like @code{string-concatenate}, but the result may share memory\n"
2634 "with the strings in the list @var{ls}.")
2635 #define FUNC_NAME s_scm_string_concatenate_shared
2637 return scm_string_append_shared (ls
);
2642 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2643 (SCM ls
, SCM final_string
, SCM end
),
2644 "Like @code{string-concatenate-reverse}, but the result may\n"
2645 "share memory with the the strings in the @var{ls} arguments.")
2646 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2648 /* Just call the non-sharing version. */
2649 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2654 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2655 (SCM proc
, SCM s
, SCM start
, SCM end
),
2656 "@var{proc} is a char->char procedure, it is mapped over\n"
2657 "@var{s}. The order in which the procedure is applied to the\n"
2658 "string elements is not specified.")
2659 #define FUNC_NAME s_scm_string_map
2663 size_t cstart
, cend
;
2666 SCM_VALIDATE_PROC (1, proc
);
2667 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2670 result
= scm_i_make_string (cend
- cstart
, &p
);
2671 while (cstart
< cend
)
2673 unsigned int c
= (unsigned char) cstr
[cstart
];
2674 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2675 if (!SCM_CHARP (ch
))
2676 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2677 cstr
= scm_i_string_chars (s
);
2679 *p
++ = SCM_CHAR (ch
);
2686 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2687 (SCM proc
, SCM s
, SCM start
, SCM end
),
2688 "@var{proc} is a char->char procedure, it is mapped over\n"
2689 "@var{s}. The order in which the procedure is applied to the\n"
2690 "string elements is not specified. The string @var{s} is\n"
2691 "modified in-place, the return value is not specified.")
2692 #define FUNC_NAME s_scm_string_map_x
2694 size_t cstart
, cend
;
2696 SCM_VALIDATE_PROC (1, proc
);
2697 MY_VALIDATE_SUBSTRING_SPEC (2, s
,
2700 while (cstart
< cend
)
2702 SCM ch
= scm_call_1 (proc
, scm_c_string_ref (s
, cstart
));
2703 if (!SCM_CHARP (ch
))
2704 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2705 scm_c_string_set_x (s
, cstart
, ch
);
2708 return SCM_UNSPECIFIED
;
2713 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2714 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2715 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2716 "as the terminating element, from left to right. @var{kons}\n"
2717 "must expect two arguments: The actual character and the last\n"
2718 "result of @var{kons}' application.")
2719 #define FUNC_NAME s_scm_string_fold
2722 size_t cstart
, cend
;
2725 SCM_VALIDATE_PROC (1, kons
);
2726 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2730 while (cstart
< cend
)
2732 unsigned int c
= (unsigned char) cstr
[cstart
];
2733 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2734 cstr
= scm_i_string_chars (s
);
2742 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2743 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2744 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2745 "as the terminating element, from right to left. @var{kons}\n"
2746 "must expect two arguments: The actual character and the last\n"
2747 "result of @var{kons}' application.")
2748 #define FUNC_NAME s_scm_string_fold_right
2751 size_t cstart
, cend
;
2754 SCM_VALIDATE_PROC (1, kons
);
2755 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2759 while (cstart
< cend
)
2761 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2762 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2763 cstr
= scm_i_string_chars (s
);
2771 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2772 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2773 "@itemize @bullet\n"
2774 "@item @var{g} is used to generate a series of @emph{seed}\n"
2775 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2776 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2778 "@item @var{p} tells us when to stop -- when it returns true\n"
2779 "when applied to one of these seed values.\n"
2780 "@item @var{f} maps each seed value to the corresponding\n"
2781 "character in the result string. These chars are assembled\n"
2782 "into the string in a left-to-right order.\n"
2783 "@item @var{base} is the optional initial/leftmost portion\n"
2784 "of the constructed string; it default to the empty\n"
2786 "@item @var{make_final} is applied to the terminal seed\n"
2787 "value (on which @var{p} returns true) to produce\n"
2788 "the final/rightmost portion of the constructed string.\n"
2789 "It defaults to @code{(lambda (x) "")}.\n"
2791 #define FUNC_NAME s_scm_string_unfold
2795 SCM_VALIDATE_PROC (1, p
);
2796 SCM_VALIDATE_PROC (2, f
);
2797 SCM_VALIDATE_PROC (3, g
);
2798 if (!SCM_UNBNDP (base
))
2800 SCM_VALIDATE_STRING (5, base
);
2804 ans
= scm_i_make_string (0, NULL
);
2805 if (!SCM_UNBNDP (make_final
))
2806 SCM_VALIDATE_PROC (6, make_final
);
2808 res
= scm_call_1 (p
, seed
);
2809 while (scm_is_false (res
))
2813 SCM ch
= scm_call_1 (f
, seed
);
2814 if (!SCM_CHARP (ch
))
2815 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2816 str
= scm_i_make_string (1, &ptr
);
2817 *ptr
= SCM_CHAR (ch
);
2819 ans
= scm_string_append (scm_list_2 (ans
, str
));
2820 seed
= scm_call_1 (g
, seed
);
2821 res
= scm_call_1 (p
, seed
);
2823 if (!SCM_UNBNDP (make_final
))
2825 res
= scm_call_1 (make_final
, seed
);
2826 return scm_string_append (scm_list_2 (ans
, res
));
2834 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2835 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2836 "@itemize @bullet\n"
2837 "@item @var{g} is used to generate a series of @emph{seed}\n"
2838 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2839 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2841 "@item @var{p} tells us when to stop -- when it returns true\n"
2842 "when applied to one of these seed values.\n"
2843 "@item @var{f} maps each seed value to the corresponding\n"
2844 "character in the result string. These chars are assembled\n"
2845 "into the string in a right-to-left order.\n"
2846 "@item @var{base} is the optional initial/rightmost portion\n"
2847 "of the constructed string; it default to the empty\n"
2849 "@item @var{make_final} is applied to the terminal seed\n"
2850 "value (on which @var{p} returns true) to produce\n"
2851 "the final/leftmost portion of the constructed string.\n"
2852 "It defaults to @code{(lambda (x) "")}.\n"
2854 #define FUNC_NAME s_scm_string_unfold_right
2858 SCM_VALIDATE_PROC (1, p
);
2859 SCM_VALIDATE_PROC (2, f
);
2860 SCM_VALIDATE_PROC (3, g
);
2861 if (!SCM_UNBNDP (base
))
2863 SCM_VALIDATE_STRING (5, base
);
2867 ans
= scm_i_make_string (0, NULL
);
2868 if (!SCM_UNBNDP (make_final
))
2869 SCM_VALIDATE_PROC (6, make_final
);
2871 res
= scm_call_1 (p
, seed
);
2872 while (scm_is_false (res
))
2876 SCM ch
= scm_call_1 (f
, seed
);
2877 if (!SCM_CHARP (ch
))
2878 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2879 str
= scm_i_make_string (1, &ptr
);
2880 *ptr
= SCM_CHAR (ch
);
2882 ans
= scm_string_append (scm_list_2 (str
, ans
));
2883 seed
= scm_call_1 (g
, seed
);
2884 res
= scm_call_1 (p
, seed
);
2886 if (!SCM_UNBNDP (make_final
))
2888 res
= scm_call_1 (make_final
, seed
);
2889 return scm_string_append (scm_list_2 (res
, ans
));
2897 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2898 (SCM proc
, SCM s
, SCM start
, SCM end
),
2899 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2900 "return value is not specified.")
2901 #define FUNC_NAME s_scm_string_for_each
2904 size_t cstart
, cend
;
2906 SCM_VALIDATE_PROC (1, proc
);
2907 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2910 while (cstart
< cend
)
2912 unsigned int c
= (unsigned char) cstr
[cstart
];
2913 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2914 cstr
= scm_i_string_chars (s
);
2917 return SCM_UNSPECIFIED
;
2921 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2922 (SCM proc
, SCM s
, SCM start
, SCM end
),
2923 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2924 "return value is not specified.")
2925 #define FUNC_NAME s_scm_string_for_each_index
2928 size_t cstart
, cend
;
2930 SCM_VALIDATE_PROC (1, proc
);
2931 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2934 while (cstart
< cend
)
2936 scm_call_1 (proc
, scm_from_size_t (cstart
));
2939 return SCM_UNSPECIFIED
;
2943 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2944 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2945 "This is the @emph{extended substring} procedure that implements\n"
2946 "replicated copying of a substring of some string.\n"
2948 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2949 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2950 "0 and the length of @var{s}. Replicate this substring up and\n"
2951 "down index space, in both the positive and negative directions.\n"
2952 "@code{xsubstring} returns the substring of this string\n"
2953 "beginning at index @var{from}, and ending at @var{to}, which\n"
2954 "defaults to @var{from} + (@var{end} - @var{start}).")
2955 #define FUNC_NAME s_scm_xsubstring
2959 size_t cstart
, cend
, cfrom
, cto
;
2962 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2965 cfrom
= scm_to_size_t (from
);
2966 if (SCM_UNBNDP (to
))
2967 cto
= cfrom
+ (cend
- cstart
);
2969 cto
= scm_to_size_t (to
);
2970 if (cstart
== cend
&& cfrom
!= cto
)
2971 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2973 result
= scm_i_make_string (cto
- cfrom
, &p
);
2977 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2979 *p
= cs
[(cend
- cstart
) - t
];
2985 scm_remember_upto_here_1 (s
);
2991 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2992 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2993 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2994 "is written into the string @var{target} starting at index\n"
2995 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2996 "@var{target} @var{s})} or these arguments share storage -- you\n"
2997 "cannot copy a string on top of itself.")
2998 #define FUNC_NAME s_scm_string_xcopy_x
3002 size_t ctstart
, csfrom
, csto
, cstart
, cend
;
3003 SCM dummy
= SCM_UNDEFINED
;
3006 MY_VALIDATE_SUBSTRING_SPEC (1, target
,
3009 MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
3012 csfrom
= scm_to_size_t (sfrom
);
3013 if (SCM_UNBNDP (sto
))
3014 csto
= csfrom
+ (cend
- cstart
);
3016 csto
= scm_to_size_t (sto
);
3017 if (cstart
== cend
&& csfrom
!= csto
)
3018 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
3019 SCM_ASSERT_RANGE (1, tstart
,
3020 ctstart
+ (csto
- csfrom
) <= scm_i_string_length (target
));
3022 p
= scm_i_string_writable_chars (target
) + ctstart
;
3023 while (csfrom
< csto
)
3025 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
3027 *p
= cs
[(cend
- cstart
) - t
];
3033 scm_i_string_stop_writing ();
3035 scm_remember_upto_here_2 (target
, s
);
3036 return SCM_UNSPECIFIED
;
3041 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
3042 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
3043 "Return the string @var{s1}, but with the characters\n"
3044 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
3045 "@var{start2} @dots{} @var{end2} from @var{s2}.")
3046 #define FUNC_NAME s_scm_string_replace
3048 const char *cstr1
, *cstr2
;
3050 size_t cstart1
, cend1
, cstart2
, cend2
;
3053 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
3056 MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
3059 result
= scm_i_make_string (cstart1
+ (cend2
- cstart2
) +
3060 scm_i_string_length (s1
) - cend1
, &p
);
3061 memmove (p
, cstr1
, cstart1
* sizeof (char));
3062 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
3063 memmove (p
+ cstart1
+ (cend2
- cstart2
),
3065 (scm_i_string_length (s1
) - cend1
) * sizeof (char));
3066 scm_remember_upto_here_2 (s1
, s2
);
3072 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
3073 (SCM s
, SCM token_set
, SCM start
, SCM end
),
3074 "Split the string @var{s} into a list of substrings, where each\n"
3075 "substring is a maximal non-empty contiguous sequence of\n"
3076 "characters from the character set @var{token_set}, which\n"
3077 "defaults to @code{char-set:graphic}.\n"
3078 "If @var{start} or @var{end} indices are provided, they restrict\n"
3079 "@code{string-tokenize} to operating on the indicated substring\n"
3081 #define FUNC_NAME s_scm_string_tokenize
3084 size_t cstart
, cend
;
3085 SCM result
= SCM_EOL
;
3087 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3091 if (SCM_UNBNDP (token_set
))
3092 token_set
= scm_char_set_graphic
;
3094 if (SCM_CHARSETP (token_set
))
3098 while (cstart
< cend
)
3100 while (cstart
< cend
)
3102 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3109 while (cstart
< cend
)
3111 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
3115 result
= scm_cons (scm_c_substring (s
, cend
, idx
), result
);
3116 cstr
= scm_i_string_chars (s
);
3119 else SCM_WRONG_TYPE_ARG (2, token_set
);
3120 scm_remember_upto_here_1 (s
);
3125 SCM_DEFINE (scm_string_split
, "string-split", 2, 0, 0,
3127 "Split the string @var{str} into the a list of the substrings delimited\n"
3128 "by appearances of the character @var{chr}. Note that an empty substring\n"
3129 "between separator characters will result in an empty string in the\n"
3133 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3135 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3137 "(string-split \"::\" #\\:)\n"
3139 "(\"\" \"\" \"\")\n"
3141 "(string-split \"\" #\\:)\n"
3145 #define FUNC_NAME s_scm_string_split
3152 SCM_VALIDATE_STRING (1, str
);
3153 SCM_VALIDATE_CHAR (2, chr
);
3155 idx
= scm_i_string_length (str
);
3156 p
= scm_i_string_chars (str
);
3157 ch
= SCM_CHAR (chr
);
3161 while (idx
> 0 && p
[idx
- 1] != ch
)
3165 res
= scm_cons (scm_c_substring (str
, idx
, last_idx
), res
);
3166 p
= scm_i_string_chars (str
);
3170 scm_remember_upto_here_1 (str
);
3176 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
3177 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3178 "Filter the string @var{s}, retaining only those characters that\n"
3179 "satisfy the @var{char_pred} argument. If the argument is a\n"
3180 "procedure, it is applied to each character as a predicate, if\n"
3181 "it is a character, it is tested for equality and if it is a\n"
3182 "character set, it is tested for membership.")
3183 #define FUNC_NAME s_scm_string_filter
3186 size_t cstart
, cend
;
3190 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3193 if (SCM_CHARP (char_pred
))
3198 chr
= SCM_CHAR (char_pred
);
3202 if (cstr
[idx
] == chr
)
3203 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3204 cstr
= scm_i_string_chars (s
);
3207 result
= scm_reverse_list_to_string (ls
);
3209 else if (SCM_CHARSETP (char_pred
))
3216 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3217 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3218 cstr
= scm_i_string_chars (s
);
3221 result
= scm_reverse_list_to_string (ls
);
3227 SCM_VALIDATE_PROC (2, char_pred
);
3232 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
3233 if (scm_is_true (res
))
3234 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3235 cstr
= scm_i_string_chars (s
);
3238 result
= scm_reverse_list_to_string (ls
);
3240 scm_remember_upto_here_1 (s
);
3246 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
3247 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
3248 "Filter the string @var{s}, retaining only those characters that\n"
3249 "do not satisfy the @var{char_pred} argument. If the argument\n"
3250 "is a procedure, it is applied to each character as a predicate,\n"
3251 "if it is a character, it is tested for equality and if it is a\n"
3252 "character set, it is tested for membership.")
3253 #define FUNC_NAME s_scm_string_delete
3256 size_t cstart
, cend
;
3260 MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
3263 if (SCM_CHARP (char_pred
))
3268 chr
= SCM_CHAR (char_pred
);
3272 if (cstr
[idx
] != chr
)
3273 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3274 cstr
= scm_i_string_chars (s
);
3277 result
= scm_reverse_list_to_string (ls
);
3279 else if (SCM_CHARSETP (char_pred
))
3286 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
3287 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3288 cstr
= scm_i_string_chars (s
);
3291 result
= scm_reverse_list_to_string (ls
);
3297 SCM_VALIDATE_PROC (2, char_pred
);
3302 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
3303 if (scm_is_false (res
))
3304 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3305 cstr
= scm_i_string_chars (s
);
3308 result
= scm_reverse_list_to_string (ls
);
3315 /* Initialize the SRFI-13 module. This function will be called by the
3316 loading Scheme module. */
3318 scm_init_srfi_13 (void)
3320 #include "libguile/srfi-13.x"
3323 /* End of srfi-13.c. */