1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001 Free Software Foundation, Inc.
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License as
7 * published by the Free Software Foundation; either version 2, or (at
8 * your option) any later version.
10 * This program is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this software; see the file COPYING. If not, write to
17 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 * Boston, MA 02111-1307 USA
20 * As a special exception, the Free Software Foundation gives
21 * permission for additional uses of the text contained in its release
24 * The exception is that, if you link the GUILE library with other
25 * files to produce an executable, this does not by itself cause the
26 * resulting executable to be covered by the GNU General Public
27 * License. Your use of that executable is in no way restricted on
28 * account of linking the GUILE library code into it.
30 * This exception does not however invalidate any other reasons why
31 * the executable file might be covered by the GNU General Public
34 * This exception applies only to the code released by the Free
35 * Software Foundation under the name GUILE. If you copy code from
36 * other Free Software Foundation releases into a copy of GUILE, as
37 * the General Public License permits, the exception does not apply to
38 * the code that you add in this way. To avoid misleading anyone as
39 * to the status of such modified files, you must delete this
40 * exception notice from them.
42 * If you write modifications of your own for GUILE, it is your choice
43 * whether to permit this exception to apply to your modifications.
44 * If you do not wish that, delete this exception notice. */
54 SCM_DEFINE (scm_string_any
, "string-any", 2, 2, 0,
55 (SCM pred
, SCM s
, SCM start
, SCM end
),
56 "Check if the predicate @var{pred} is true for any character in\n"
57 "the string @var{s}, proceeding from left (index @var{start}) to\n"
58 "right (index @var{end}). If @code{string-any} returns true,\n"
59 "the returned true value is the one produced by the first\n"
60 "successful application of @var{pred}.")
61 #define FUNC_NAME s_scm_string_any
67 SCM_VALIDATE_PROC (1, pred
);
68 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
74 res
= scm_apply (pred
, SCM_MAKE_CHAR (*cstr
), scm_listofnull
);
75 if (!SCM_FALSEP (res
))
85 SCM_DEFINE (scm_string_every
, "string-every", 2, 2, 0,
86 (SCM pred
, SCM s
, SCM start
, SCM end
),
87 "Check if the predicate @var{pred} is true for every character\n"
88 "in the string @var{s}, proceeding from left (index @var{start})\n"
89 "to right (index @var{end}). If @code{string-every} returns\n"
90 "true, the returned true value is the one produced by the final\n"
91 "application of @var{pred} to the last character of @var{s}.")
92 #define FUNC_NAME s_scm_string_every
98 SCM_VALIDATE_PROC (1, pred
);
99 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
104 while (cstart
< cend
)
106 res
= scm_apply (pred
, SCM_MAKE_CHAR (*cstr
), scm_listofnull
);
107 if (SCM_FALSEP (res
))
117 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
119 "@var{proc} is an integer->char procedure. Construct a string\n"
120 "of size @var{len} by applying @var{proc} to each index to\n"
121 "produce the corresponding string element. The order in which\n"
122 "@var{proc} is applied to the indices is not specified.")
123 #define FUNC_NAME s_scm_string_tabulate
130 SCM_VALIDATE_PROC (1, proc
);
131 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
132 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
134 res
= scm_allocate_string (clen
);
135 p
= SCM_STRING_CHARS (res
);
139 ch
= scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
);
141 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
142 *p
++ = SCM_CHAR (ch
);
150 SCM_DEFINE (scm_string_to_listS
, "string->list", 1, 2, 0,
151 (SCM str
, SCM start
, SCM end
),
152 "Convert the string @var{str} into a list of characters.")
153 #define FUNC_NAME s_scm_string_to_listS
157 SCM result
= SCM_EOL
;
159 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
162 while (cstart
< cend
)
165 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
171 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
173 "An efficient implementation of @code{(compose string->list\n"
177 "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n"
179 #define FUNC_NAME s_scm_reverse_list_to_string
182 long i
= scm_ilength (chrs
);
185 SCM_WRONG_TYPE_ARG (1, chrs
);
186 result
= scm_allocate_string (i
);
189 unsigned char *data
= SCM_STRING_UCHARS (result
) + i
;
191 while (SCM_NNULLP (chrs
))
193 SCM elt
= SCM_CAR (chrs
);
195 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
197 *data
= SCM_CHAR (elt
);
198 chrs
= SCM_CDR (chrs
);
206 SCM_SYMBOL (scm_sym_infix
, "infix");
207 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
208 SCM_SYMBOL (scm_sym_suffix
, "suffix");
209 SCM_SYMBOL (scm_sym_prefix
, "prefix");
211 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
212 (SCM ls
, SCM delimiter
, SCM grammar
),
213 "Append the string in the string list @var{ls}, using the string\n"
214 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
215 "@var{grammar} is a symbol which specifies how the delimiter is\n"
216 "placed between the strings, and defaults to the symbol\n"
221 "Insert the separator between list elements. An empty string\n"
222 "will produce an empty list.\n"
223 "@item string-infix\n"
224 "Like @code{infix}, but will raise an error if given the empty\n"
227 "Insert the separator after every list element.\n"
229 "Insert the separator before each list element.\n"
231 #define FUNC_NAME s_scm_string_join
234 #define GRAM_STRICT_INFIX 1
235 #define GRAM_SUFFIX 2
236 #define GRAM_PREFIX 3
239 int gram
= GRAM_INFIX
;
240 int del_len
= 0, extra_len
= 0;
243 long strings
= scm_ilength (ls
);
245 /* Validate the string list. */
247 SCM_WRONG_TYPE_ARG (1, ls
);
249 /* Validate the delimiter and record its length. */
250 if (SCM_UNBNDP (delimiter
))
252 delimiter
= scm_makfrom0str (" ");
257 SCM_VALIDATE_STRING (2, delimiter
);
258 del_len
= SCM_STRING_LENGTH (delimiter
);
261 /* Validate the grammar symbol and remember the grammar. */
262 if (SCM_UNBNDP (grammar
))
264 else if (SCM_EQ_P (grammar
, scm_sym_infix
))
266 else if (SCM_EQ_P (grammar
, scm_sym_strict_infix
))
267 gram
= GRAM_STRICT_INFIX
;
268 else if (SCM_EQ_P (grammar
, scm_sym_suffix
))
270 else if (SCM_EQ_P (grammar
, scm_sym_prefix
))
273 SCM_WRONG_TYPE_ARG (3, grammar
);
275 /* Check grammar constraints and calculate the space required for
281 extra_len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
283 case GRAM_STRICT_INFIX
:
285 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
287 extra_len
= (strings
- 1) * del_len
;
290 extra_len
= strings
* del_len
;
295 while (SCM_CONSP (tmp
))
297 SCM elt
= SCM_CAR (tmp
);
298 SCM_VALIDATE_STRING (1, elt
);
299 len
+= SCM_STRING_LENGTH (elt
);
303 result
= scm_allocate_string (len
+ extra_len
);
304 p
= SCM_STRING_CHARS (result
);
310 case GRAM_STRICT_INFIX
:
311 while (!SCM_NULLP (tmp
))
313 SCM elt
= SCM_CAR (tmp
);
314 memmove (p
, SCM_STRING_CHARS (elt
),
315 SCM_STRING_LENGTH (elt
) * sizeof (char));
316 p
+= SCM_STRING_LENGTH (elt
);
317 if (!SCM_NULLP (SCM_CDR (tmp
)) && del_len
> 0)
319 memmove (p
, SCM_STRING_CHARS (delimiter
),
320 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
327 while (!SCM_NULLP (tmp
))
329 SCM elt
= SCM_CAR (tmp
);
330 memmove (p
, SCM_STRING_CHARS (elt
),
331 SCM_STRING_LENGTH (elt
) * sizeof (char));
332 p
+= SCM_STRING_LENGTH (elt
);
335 memmove (p
, SCM_STRING_CHARS (delimiter
),
336 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
343 while (!SCM_NULLP (tmp
))
345 SCM elt
= SCM_CAR (tmp
);
348 memmove (p
, SCM_STRING_CHARS (delimiter
),
349 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
352 memmove (p
, SCM_STRING_CHARS (elt
),
353 SCM_STRING_LENGTH (elt
) * sizeof (char));
354 p
+= SCM_STRING_LENGTH (elt
);
361 #undef GRAM_STRICT_INFIX
368 SCM_DEFINE (scm_string_copyS
, "string-copy", 1, 2, 0,
369 (SCM str
, SCM start
, SCM end
),
370 "Return a freshly allocated copy of the string @var{str}. If\n"
371 "given, @var{start} and @var{end} delimit the portion of\n"
372 "@var{str} which is copied.")
373 #define FUNC_NAME s_scm_string_copyS
378 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
381 return scm_makfromstr (cstr
+ start
, cend
- cstart
, 0);
387 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
388 (SCM str
, SCM start
, SCM end
),
389 "Like @code{substring}, but the result may share memory with the\n"
390 "argument @var{str}.")
391 #define FUNC_NAME s_scm_substring_shared
393 SCM_VALIDATE_STRING (1, str
);
394 SCM_VALIDATE_INUM (2, start
);
395 if (SCM_UNBNDP (end
))
396 end
= SCM_MAKINUM (SCM_STRING_LENGTH (str
));
398 SCM_VALIDATE_INUM (3, end
);
399 if (SCM_INUM (start
) == 0 &&
400 SCM_INUM (end
) == SCM_STRING_LENGTH (str
))
402 return scm_substring (str
, start
, end
);
407 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
408 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
409 "Copy the sequence of characters from index range [@var{start},\n"
410 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
411 "at index @var{tstart}. The characters are copied left-to-right\n"
412 "or right-to-left as needed -- the copy is guaranteed to work,\n"
413 "even if @var{target} and @var{s} are the same string. It is an\n"
414 "error if the copy operation runs off the end of the target\n"
416 #define FUNC_NAME s_scm_string_copy_x
418 char * cstr
, * ctarget
;
419 int cstart
, cend
, ctstart
, dummy
;
421 SCM sdummy
= SCM_UNDEFINED
;
423 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
426 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
430 SCM_ASSERT_RANGE (3, s
, len
<= SCM_STRING_LENGTH (target
) - ctstart
);
432 memmove (SCM_STRING_CHARS (target
) + ctstart
,
433 SCM_STRING_CHARS (s
) + cstart
,
434 len
* sizeof (char));
435 return SCM_UNSPECIFIED
;
440 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
442 "Return the @var{n} first characters of @var{s}.")
443 #define FUNC_NAME s_scm_string_take
448 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
449 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
450 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
452 return scm_makfromstr (cstr
, cn
, 0);
457 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
459 "Return all but the first @var{n} characters of @var{s}.")
460 #define FUNC_NAME s_scm_string_drop
465 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
466 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
467 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
469 return scm_makfromstr (cstr
+ cn
, SCM_STRING_LENGTH (s
) - cn
, 0);
474 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
476 "Return the @var{n} last characters of @var{s}.")
477 #define FUNC_NAME s_scm_string_take_right
482 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
483 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
484 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
486 return scm_makfromstr (cstr
+ SCM_STRING_LENGTH (s
) - cn
, cn
, 0);
491 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
493 "Return all but the last @var{n} characters of @var{s}.")
494 #define FUNC_NAME s_scm_string_drop_right
499 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
500 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
501 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
503 return scm_makfromstr (cstr
, SCM_STRING_LENGTH (s
) - cn
, 0);
508 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
509 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
510 "Take that characters from @var{start} to @var{end} from the\n"
511 "string @var{s} and return a new string, right-padded by the\n"
512 "character @var{chr} to length @var{len}. If the resulting\n"
513 "string is longer than @var{len}, it is truncated on the right.")
514 #define FUNC_NAME s_scm_string_pad
518 int cstart
, cend
, clen
;
521 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
524 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
525 if (SCM_UNBNDP (chr
))
529 SCM_VALIDATE_CHAR (3, chr
);
530 cchr
= SCM_CHAR (chr
);
532 result
= scm_allocate_string (clen
);
533 if (clen
< (cend
- cstart
))
534 memmove (SCM_STRING_CHARS (result
),
536 clen
* sizeof (char));
539 memset (SCM_STRING_CHARS (result
), cchr
,
540 (clen
- (cend
- cstart
)) * sizeof (char));
541 memmove (SCM_STRING_CHARS (result
) + (clen
- (cend
- cstart
)),
543 (cend
- cstart
) * sizeof (char));
550 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
551 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
552 "Take that characters from @var{start} to @var{end} from the\n"
553 "string @var{s} and return a new string, left-padded by the\n"
554 "character @var{chr} to length @var{len}. If the resulting\n"
555 "string is longer than @var{len}, it is truncated on the left.")
556 #define FUNC_NAME s_scm_string_pad_right
560 int cstart
, cend
, clen
;
563 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
566 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
567 if (SCM_UNBNDP (chr
))
571 SCM_VALIDATE_CHAR (3, chr
);
572 cchr
= SCM_CHAR (chr
);
574 result
= scm_allocate_string (clen
);
575 if (clen
< (cend
- cstart
))
576 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
, clen
* sizeof (char));
579 memset (SCM_STRING_CHARS (result
) + (cend
- cstart
),
580 cchr
, (clen
- (cend
- cstart
)) * sizeof (char));
581 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
,
582 (cend
- cstart
) * sizeof (char));
589 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
590 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
591 "Trim @var{s} by skipping over all characters on the left\n"
592 "that satisfy the parameter @var{char_pred}:\n"
596 "if it is the character @var{ch}, characters equal to\n"
597 "@var{ch} are trimmed,\n"
600 "if it is a procedure @var{pred} characters that\n"
601 "satisfy @var{pred} are trimmed,\n"
604 "if it is a character set, characters in that set are trimmed.\n"
607 "If called without a @var{char_pred} argument, all whitespace is\n"
609 #define FUNC_NAME s_scm_string_trim
614 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
617 if (SCM_UNBNDP (char_pred
))
619 while (cstart
< cend
)
621 if (!isspace(cstr
[cstart
]))
626 else if (SCM_CHARP (char_pred
))
628 char chr
= SCM_CHAR (char_pred
);
629 while (cstart
< cend
)
631 if (chr
!= cstr
[cstart
])
636 else if (SCM_CHARSETP (char_pred
))
638 while (cstart
< cend
)
640 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
647 SCM_VALIDATE_PROC (2, char_pred
);
648 while (cstart
< cend
)
652 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
654 if (SCM_FALSEP (res
))
659 return scm_makfromstr (cstr
+ cstart
, cend
- cstart
, 0);
664 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
665 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
666 "Trim @var{s} by skipping over all characters on the rightt\n"
667 "that satisfy the parameter @var{char_pred}:\n"
671 "if it is the character @var{ch}, characters equal to @var{ch}\n"
675 "if it is a procedure @var{pred} characters that satisfy\n"
676 "@var{pred} are trimmed,\n"
679 "if it is a character sets, all characters in that set are\n"
683 "If called without a @var{char_pred} argument, all whitespace is\n"
685 #define FUNC_NAME s_scm_string_trim_right
690 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
693 if (SCM_UNBNDP (char_pred
))
695 while (cstart
< cend
)
697 if (!isspace(cstr
[cend
- 1]))
702 else if (SCM_CHARP (char_pred
))
704 char chr
= SCM_CHAR (char_pred
);
705 while (cstart
< cend
)
707 if (chr
!= cstr
[cend
- 1])
712 else if (SCM_CHARSETP (char_pred
))
714 while (cstart
< cend
)
716 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
723 SCM_VALIDATE_PROC (2, char_pred
);
724 while (cstart
< cend
)
728 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]),
730 if (SCM_FALSEP (res
))
735 return scm_makfromstr (cstr
+ cstart
, cend
- cstart
, 0);
740 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
741 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
742 "Trim @var{s} by skipping over all characters on both sides of\n"
743 "the string that satisfy the parameter @var{char_pred}:\n"
747 "if it is the character @var{ch}, characters equal to @var{ch}\n"
751 "if it is a procedure @var{pred} characters that satisfy\n"
752 "@var{pred} are trimmed,\n"
755 "if it is a character set, the characters in the set are\n"
759 "If called without a @var{char_pred} argument, all whitespace is\n"
761 #define FUNC_NAME s_scm_string_trim_both
766 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
769 if (SCM_UNBNDP (char_pred
))
771 while (cstart
< cend
)
773 if (!isspace(cstr
[cstart
]))
777 while (cstart
< cend
)
779 if (!isspace(cstr
[cend
- 1]))
784 else if (SCM_CHARP (char_pred
))
786 char chr
= SCM_CHAR (char_pred
);
787 while (cstart
< cend
)
789 if (chr
!= cstr
[cstart
])
793 while (cstart
< cend
)
795 if (chr
!= cstr
[cend
- 1])
800 else if (SCM_CHARSETP (char_pred
))
802 while (cstart
< cend
)
804 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
808 while (cstart
< cend
)
810 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
817 SCM_VALIDATE_PROC (2, char_pred
);
818 while (cstart
< cend
)
822 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
824 if (SCM_FALSEP (res
))
828 while (cstart
< cend
)
832 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]),
834 if (SCM_FALSEP (res
))
839 return scm_makfromstr (cstr
+ cstart
, cend
- cstart
, 0);
844 SCM_DEFINE (scm_string_fill_xS
, "string-fill!", 2, 2, 0,
845 (SCM str
, SCM chr
, SCM start
, SCM end
),
846 "Stores @var{chr} in every element of the given @var{str} and\n"
847 "returns an unspecified value.")
848 #define FUNC_NAME s_scm_string_fill_xS
855 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
858 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
859 for (k
= cstart
; k
< cend
; k
++)
861 return SCM_UNSPECIFIED
;
866 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
867 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
868 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
869 "mismatch index, depending upon whether @var{s1} is less than,\n"
870 "equal to, or greater than @var{s2}. The mismatch index is the\n"
871 "largest index @var{i} such that for every 0 <= @var{j} <\n"
872 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
873 "@var{i} is the first position that does not match.")
874 #define FUNC_NAME s_scm_string_compare
876 char * cstr1
, * cstr2
;
877 int cstart1
, cend1
, cstart2
, cend2
;
879 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
882 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
885 SCM_VALIDATE_PROC (3, proc_lt
);
886 SCM_VALIDATE_PROC (4, proc_eq
);
887 SCM_VALIDATE_PROC (5, proc_gt
);
889 while (cstart1
< cend1
&& cstart2
< cend2
)
891 if (cstr1
[cstart1
] < cstr2
[cstart2
])
892 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
893 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
894 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
899 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
900 else if (cstart2
< cend2
)
901 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
903 return scm_apply (proc_eq
, SCM_MAKINUM (cstart1
), scm_listofnull
);
908 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
909 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
910 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
911 "mismatch index, depending upon whether @var{s1} is less than,\n"
912 "equal to, or greater than @var{s2}. The mismatch index is the\n"
913 "largest index @var{i} such that for every 0 <= @var{j} <\n"
914 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
915 "@var{i} is the first position that does not match. The\n"
916 "character comparison is done case-insensitively.")
917 #define FUNC_NAME s_scm_string_compare_ci
919 char * cstr1
, * cstr2
;
920 int cstart1
, cend1
, cstart2
, cend2
;
922 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
925 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
928 SCM_VALIDATE_PROC (3, proc_lt
);
929 SCM_VALIDATE_PROC (4, proc_eq
);
930 SCM_VALIDATE_PROC (5, proc_gt
);
932 while (cstart1
< cend1
&& cstart2
< cend2
)
934 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
935 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
936 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
937 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
942 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
943 else if (cstart2
< cend2
)
944 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
946 return scm_apply (proc_eq
, SCM_MAKINUM (cstart1
), scm_listofnull
);
951 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
952 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
953 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
955 #define FUNC_NAME s_scm_string_eq
957 char * cstr1
, * cstr2
;
958 int cstart1
, cend1
, cstart2
, cend2
;
960 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
963 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
967 while (cstart1
< cend1
&& cstart2
< cend2
)
969 if (cstr1
[cstart1
] < cstr2
[cstart2
])
971 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
978 else if (cstart2
< cend2
)
981 return SCM_MAKINUM (cstart1
);
986 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
987 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
988 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
990 #define FUNC_NAME s_scm_string_neq
992 char * cstr1
, * cstr2
;
993 int cstart1
, cend1
, cstart2
, cend2
;
995 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
998 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1002 while (cstart1
< cend1
&& cstart2
< cend2
)
1004 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1005 return SCM_MAKINUM (cstart1
);
1006 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1007 return SCM_MAKINUM (cstart1
);
1011 if (cstart1
< cend1
)
1012 return SCM_MAKINUM (cstart1
);
1013 else if (cstart2
< cend2
)
1014 return SCM_MAKINUM (cstart1
);
1021 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1022 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1023 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1024 "true value otherwise.")
1025 #define FUNC_NAME s_scm_string_lt
1027 char * cstr1
, * cstr2
;
1028 int cstart1
, cend1
, cstart2
, cend2
;
1030 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1033 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1037 while (cstart1
< cend1
&& cstart2
< cend2
)
1039 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1040 return SCM_MAKINUM (cstart1
);
1041 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1046 if (cstart1
< cend1
)
1048 else if (cstart2
< cend2
)
1049 return SCM_MAKINUM (cstart1
);
1056 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1057 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1058 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1059 "true value otherwise.")
1060 #define FUNC_NAME s_scm_string_gt
1062 char * cstr1
, * cstr2
;
1063 int cstart1
, cend1
, cstart2
, cend2
;
1065 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1068 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1072 while (cstart1
< cend1
&& cstart2
< cend2
)
1074 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1076 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1077 return SCM_MAKINUM (cstart1
);
1081 if (cstart1
< cend1
)
1082 return SCM_MAKINUM (cstart1
);
1083 else if (cstart2
< cend2
)
1091 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1092 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1093 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1095 #define FUNC_NAME s_scm_string_le
1097 char * cstr1
, * cstr2
;
1098 int cstart1
, cend1
, cstart2
, cend2
;
1100 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1103 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1107 while (cstart1
< cend1
&& cstart2
< cend2
)
1109 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1110 return SCM_MAKINUM (cstart1
);
1111 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1116 if (cstart1
< cend1
)
1118 else if (cstart2
< cend2
)
1119 return SCM_MAKINUM (cstart1
);
1121 return SCM_MAKINUM (cstart1
);
1126 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1127 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1128 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1130 #define FUNC_NAME s_scm_string_ge
1132 char * cstr1
, * cstr2
;
1133 int cstart1
, cend1
, cstart2
, cend2
;
1135 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1138 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1142 while (cstart1
< cend1
&& cstart2
< cend2
)
1144 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1146 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1147 return SCM_MAKINUM (cstart1
);
1151 if (cstart1
< cend1
)
1152 return SCM_MAKINUM (cstart1
);
1153 else if (cstart2
< cend2
)
1156 return SCM_MAKINUM (cstart1
);
1161 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1162 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1163 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1164 "value otherwise. The character comparison is done\n"
1165 "case-insensitively.")
1166 #define FUNC_NAME s_scm_string_ci_eq
1168 char * cstr1
, * cstr2
;
1169 int cstart1
, cend1
, cstart2
, cend2
;
1171 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1174 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1178 while (cstart1
< cend1
&& cstart2
< cend2
)
1180 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1182 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1187 if (cstart1
< cend1
)
1189 else if (cstart2
< cend2
)
1192 return SCM_MAKINUM (cstart1
);
1197 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1198 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1199 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1200 "value otherwise. The character comparison is done\n"
1201 "case-insensitively.")
1202 #define FUNC_NAME s_scm_string_ci_neq
1204 char * cstr1
, * cstr2
;
1205 int cstart1
, cend1
, cstart2
, cend2
;
1207 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1210 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1214 while (cstart1
< cend1
&& cstart2
< cend2
)
1216 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1217 return SCM_MAKINUM (cstart1
);
1218 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1219 return SCM_MAKINUM (cstart1
);
1223 if (cstart1
< cend1
)
1224 return SCM_MAKINUM (cstart1
);
1225 else if (cstart2
< cend2
)
1226 return SCM_MAKINUM (cstart1
);
1233 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1234 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1235 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1236 "true value otherwise. The character comparison is done\n"
1237 "case-insensitively.")
1238 #define FUNC_NAME s_scm_string_ci_lt
1240 char * cstr1
, * cstr2
;
1241 int cstart1
, cend1
, cstart2
, cend2
;
1243 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1246 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1250 while (cstart1
< cend1
&& cstart2
< cend2
)
1252 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1253 return SCM_MAKINUM (cstart1
);
1254 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1259 if (cstart1
< cend1
)
1261 else if (cstart2
< cend2
)
1262 return SCM_MAKINUM (cstart1
);
1269 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1270 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1271 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1272 "true value otherwise. The character comparison is done\n"
1273 "case-insensitively.")
1274 #define FUNC_NAME s_scm_string_ci_gt
1276 char * cstr1
, * cstr2
;
1277 int cstart1
, cend1
, cstart2
, cend2
;
1279 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1282 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1286 while (cstart1
< cend1
&& cstart2
< cend2
)
1288 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1290 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1291 return SCM_MAKINUM (cstart1
);
1295 if (cstart1
< cend1
)
1296 return SCM_MAKINUM (cstart1
);
1297 else if (cstart2
< cend2
)
1305 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1306 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1307 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1308 "value otherwise. The character comparison is done\n"
1309 "case-insensitively.")
1310 #define FUNC_NAME s_scm_string_ci_le
1312 char * cstr1
, * cstr2
;
1313 int cstart1
, cend1
, cstart2
, cend2
;
1315 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1318 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1322 while (cstart1
< cend1
&& cstart2
< cend2
)
1324 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1325 return SCM_MAKINUM (cstart1
);
1326 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1331 if (cstart1
< cend1
)
1333 else if (cstart2
< cend2
)
1334 return SCM_MAKINUM (cstart1
);
1336 return SCM_MAKINUM (cstart1
);
1341 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1342 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1343 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1344 "otherwise. The character comparison is done\n"
1345 "case-insensitively.")
1346 #define FUNC_NAME s_scm_string_ci_ge
1348 char * cstr1
, * cstr2
;
1349 int cstart1
, cend1
, cstart2
, cend2
;
1351 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1354 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1358 while (cstart1
< cend1
&& cstart2
< cend2
)
1360 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1362 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1363 return SCM_MAKINUM (cstart1
);
1367 if (cstart1
< cend1
)
1368 return SCM_MAKINUM (cstart1
);
1369 else if (cstart2
< cend2
)
1372 return SCM_MAKINUM (cstart1
);
1377 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1378 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1379 "Return the length of the longest common prefix of the two\n"
1381 #define FUNC_NAME s_scm_string_prefix_length
1383 char * cstr1
, * cstr2
;
1384 int cstart1
, cend1
, cstart2
, cend2
;
1387 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1390 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1393 while (cstart1
< cend1
&& cstart2
< cend2
)
1395 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1396 return SCM_MAKINUM (len
);
1401 return SCM_MAKINUM (len
);
1406 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1407 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1408 "Return the length of the longest common prefix of the two\n"
1409 "strings, ignoring character case.")
1410 #define FUNC_NAME s_scm_string_prefix_length_ci
1412 char * cstr1
, * cstr2
;
1413 int cstart1
, cend1
, cstart2
, cend2
;
1416 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1419 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1422 while (cstart1
< cend1
&& cstart2
< cend2
)
1424 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1425 return SCM_MAKINUM (len
);
1430 return SCM_MAKINUM (len
);
1435 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1436 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1437 "Return the length of the longest common suffix of the two\n"
1439 #define FUNC_NAME s_scm_string_suffix_length
1441 char * cstr1
, * cstr2
;
1442 int cstart1
, cend1
, cstart2
, cend2
;
1445 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1448 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1451 while (cstart1
< cend1
&& cstart2
< cend2
)
1455 if (cstr1
[cend1
] != cstr2
[cend2
])
1456 return SCM_MAKINUM (len
);
1459 return SCM_MAKINUM (len
);
1464 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1465 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1466 "Return the length of the longest common suffix of the two\n"
1467 "strings, ignoring character case.")
1468 #define FUNC_NAME s_scm_string_suffix_length_ci
1470 char * cstr1
, * cstr2
;
1471 int cstart1
, cend1
, cstart2
, cend2
;
1474 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1477 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1480 while (cstart1
< cend1
&& cstart2
< cend2
)
1484 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1485 return SCM_MAKINUM (len
);
1488 return SCM_MAKINUM (len
);
1493 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1494 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1495 "Is @var{s1} a prefix of @var{s2}?")
1496 #define FUNC_NAME s_scm_string_prefix_p
1498 char * cstr1
, * cstr2
;
1499 int cstart1
, cend1
, cstart2
, cend2
;
1502 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1505 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1508 len1
= cend1
- cstart1
;
1509 while (cstart1
< cend1
&& cstart2
< cend2
)
1511 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1512 return SCM_BOOL (len
== len1
);
1517 return SCM_BOOL (len
== len1
);
1522 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1523 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1524 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1525 #define FUNC_NAME s_scm_string_prefix_ci_p
1527 char * cstr1
, * cstr2
;
1528 int cstart1
, cend1
, cstart2
, cend2
;
1531 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1534 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1537 len1
= cend1
- cstart1
;
1538 while (cstart1
< cend1
&& cstart2
< cend2
)
1540 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1541 return SCM_BOOL (len
== len1
);
1546 return SCM_BOOL (len
== len1
);
1551 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1552 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1553 "Is @var{s1} a suffix of @var{s2}?")
1554 #define FUNC_NAME s_scm_string_suffix_p
1556 char * cstr1
, * cstr2
;
1557 int cstart1
, cend1
, cstart2
, cend2
;
1560 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1563 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1566 len1
= cend1
- cstart1
;
1567 while (cstart1
< cend1
&& cstart2
< cend2
)
1571 if (cstr1
[cend1
] != cstr2
[cend2
])
1572 return SCM_BOOL (len
== len1
);
1575 return SCM_BOOL (len
== len1
);
1580 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1581 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1582 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1583 #define FUNC_NAME s_scm_string_suffix_ci_p
1585 char * cstr1
, * cstr2
;
1586 int cstart1
, cend1
, cstart2
, cend2
;
1589 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1592 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1595 len1
= cend1
- cstart1
;
1596 while (cstart1
< cend1
&& cstart2
< cend2
)
1600 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1601 return SCM_BOOL (len
== len1
);
1604 return SCM_BOOL (len
== len1
);
1609 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1610 in the core, which does not accept a predicate. */
1611 SCM_DEFINE (scm_string_indexS
, "string-index", 2, 2, 0,
1612 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1613 "Search through the string @var{s} from left to right, returning\n"
1614 "the index of the first occurence of a character which\n"
1618 "equals @var{char_pred}, if it is character,\n"
1621 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1624 "is in the set @var{char_pred}, if it is a character set.\n"
1626 #define FUNC_NAME s_scm_string_indexS
1631 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1634 if (SCM_CHARP (char_pred
))
1636 char cchr
= SCM_CHAR (char_pred
);
1637 while (cstart
< cend
)
1639 if (cchr
== cstr
[cstart
])
1640 return SCM_MAKINUM (cstart
);
1644 else if (SCM_CHARSETP (char_pred
))
1646 while (cstart
< cend
)
1648 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1649 return SCM_MAKINUM (cstart
);
1655 SCM_VALIDATE_PROC (2, char_pred
);
1656 while (cstart
< cend
)
1659 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1661 if (!SCM_FALSEP (res
))
1662 return SCM_MAKINUM (cstart
);
1671 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1672 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1673 "Search through the string @var{s} from right to left, returning\n"
1674 "the index of the last occurence of a character which\n"
1676 "@itemize @bullet\n"
1678 "equals @var{char_pred}, if it is character,\n"
1681 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1684 "is in the set if @var{char_pred} is a character set.\n"
1686 #define FUNC_NAME s_scm_string_index_right
1691 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1694 if (SCM_CHARP (char_pred
))
1696 char cchr
= SCM_CHAR (char_pred
);
1697 while (cstart
< cend
)
1700 if (cchr
== cstr
[cend
])
1701 return SCM_MAKINUM (cend
);
1704 else if (SCM_CHARSETP (char_pred
))
1706 while (cstart
< cend
)
1709 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1710 return SCM_MAKINUM (cend
);
1715 SCM_VALIDATE_PROC (2, char_pred
);
1716 while (cstart
< cend
)
1720 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]),
1722 if (!SCM_FALSEP (res
))
1723 return SCM_MAKINUM (cend
);
1731 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1732 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1733 "Search through the string @var{s} from left to right, returning\n"
1734 "the index of the first occurence of a character which\n"
1736 "@itemize @bullet\n"
1738 "does not equal @var{char_pred}, if it is character,\n"
1741 "does not satisify the predicate @var{char_pred}, if it is a\n"
1745 "is not in the set if @var{char_pred} is a character set.\n"
1747 #define FUNC_NAME s_scm_string_skip
1752 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1755 if (SCM_CHARP (char_pred
))
1757 char cchr
= SCM_CHAR (char_pred
);
1758 while (cstart
< cend
)
1760 if (cchr
!= cstr
[cstart
])
1761 return SCM_MAKINUM (cstart
);
1765 else if (SCM_CHARSETP (char_pred
))
1767 while (cstart
< cend
)
1769 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1770 return SCM_MAKINUM (cstart
);
1776 SCM_VALIDATE_PROC (2, char_pred
);
1777 while (cstart
< cend
)
1780 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1782 if (SCM_FALSEP (res
))
1783 return SCM_MAKINUM (cstart
);
1792 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1793 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1794 "Search through the string @var{s} from right to left, returning\n"
1795 "the index of the last occurence of a character which\n"
1797 "@itemize @bullet\n"
1799 "does not equal @var{char_pred}, if it is character,\n"
1802 "does not satisifie the predicate @var{char_pred}, if it is a\n"
1806 "is not in the set if @var{char_pred} is a character set.\n"
1808 #define FUNC_NAME s_scm_string_skip_right
1813 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1816 if (SCM_CHARP (char_pred
))
1818 char cchr
= SCM_CHAR (char_pred
);
1819 while (cstart
< cend
)
1822 if (cchr
!= cstr
[cend
])
1823 return SCM_MAKINUM (cend
);
1826 else if (SCM_CHARSETP (char_pred
))
1828 while (cstart
< cend
)
1831 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1832 return SCM_MAKINUM (cend
);
1837 SCM_VALIDATE_PROC (2, char_pred
);
1838 while (cstart
< cend
)
1842 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]),
1844 if (SCM_FALSEP (res
))
1845 return SCM_MAKINUM (cend
);
1853 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1854 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1855 "Return the count of the number of characters in the string\n"
1858 "@itemize @bullet\n"
1860 "equals @var{char_pred}, if it is character,\n"
1863 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1866 "is in the set @var{char_pred}, if it is a character set.\n"
1868 #define FUNC_NAME s_scm_string_count
1874 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1877 if (SCM_CHARP (char_pred
))
1879 char cchr
= SCM_CHAR (char_pred
);
1880 while (cstart
< cend
)
1882 if (cchr
== cstr
[cstart
])
1887 else if (SCM_CHARSETP (char_pred
))
1889 while (cstart
< cend
)
1891 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1898 SCM_VALIDATE_PROC (2, char_pred
);
1899 while (cstart
< cend
)
1902 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1904 if (!SCM_FALSEP (res
))
1909 return SCM_MAKINUM (count
);
1914 /* FIXME::martin: This should definitely get implemented more
1915 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1917 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1918 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1919 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1920 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1921 "The optional start/end indices restrict the operation to the\n"
1922 "indicated substrings.")
1923 #define FUNC_NAME s_scm_string_contains
1926 int cstart1
, cend1
, cstart2
, cend2
;
1929 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1932 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1935 len2
= cend2
- cstart2
;
1936 while (cstart1
<= cend1
- len2
)
1940 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
1946 return SCM_MAKINUM (cstart1
);
1954 /* FIXME::martin: This should definitely get implemented more
1955 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1957 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
1958 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1959 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1960 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1961 "The optional start/end indices restrict the operation to the\n"
1962 "indicated substrings. Character comparison is done\n"
1963 "case-insensitively.")
1964 #define FUNC_NAME s_scm_string_contains_ci
1967 int cstart1
, cend1
, cstart2
, cend2
;
1970 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1973 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1976 len2
= cend2
- cstart2
;
1977 while (cstart1
<= cend1
- len2
)
1981 while (i
< cend1
&& j
< cend2
&&
1982 scm_downcase (cs1
[i
]) == scm_downcase (cs2
[j
]))
1988 return SCM_MAKINUM (cstart1
);
1996 /* Helper function for the string uppercase conversion functions.
1997 * No argument checking is performed. */
1999 string_upcase_x (SCM v
, int start
, int end
)
2003 for (k
= start
; k
< end
; ++k
)
2004 SCM_STRING_UCHARS (v
) [k
] = scm_upcase (SCM_STRING_UCHARS (v
) [k
]);
2010 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2011 in the core, which does not accept start/end indices */
2012 SCM_DEFINE (scm_string_upcase_xS
, "string-upcase!", 1, 2, 0,
2013 (SCM str
, SCM start
, SCM end
),
2014 "Destructively upcase every character in @code{str}.\n"
2017 "(string-upcase! y)\n"
2018 "@result{} \"ARRDEFG\"\n"
2020 "@result{} \"ARRDEFG\"\n"
2022 #define FUNC_NAME s_scm_string_upcase_xS
2027 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2030 return string_upcase_x (str
, cstart
, cend
);
2035 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2036 in the core, which does not accept start/end indices */
2037 SCM_DEFINE (scm_string_upcaseS
, "string-upcase", 1, 2, 0,
2038 (SCM str
, SCM start
, SCM end
),
2039 "Upcase every character in @code{str}.")
2040 #define FUNC_NAME s_scm_string_upcaseS
2045 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2048 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2053 /* Helper function for the string lowercase conversion functions.
2054 * No argument checking is performed. */
2056 string_downcase_x (SCM v
, int start
, int end
)
2060 for (k
= start
; k
< end
; ++k
)
2061 SCM_STRING_UCHARS (v
) [k
] = scm_downcase (SCM_STRING_UCHARS (v
) [k
]);
2067 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2068 in the core, which does not accept start/end indices */
2069 SCM_DEFINE (scm_string_downcase_xS
, "string-downcase!", 1, 2, 0,
2070 (SCM str
, SCM start
, SCM end
),
2071 "Destructively downcase every character in @var{str}.\n"
2075 "@result{} \"ARRDEFG\"\n"
2076 "(string-downcase! y)\n"
2077 "@result{} \"arrdefg\"\n"
2079 "@result{} \"arrdefg\"\n"
2081 #define FUNC_NAME s_scm_string_downcase_xS
2086 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2089 return string_downcase_x (str
, cstart
, cend
);
2094 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2095 in the core, which does not accept start/end indices */
2096 SCM_DEFINE (scm_string_downcaseS
, "string-downcase", 1, 2, 0,
2097 (SCM str
, SCM start
, SCM end
),
2098 "Downcase every character in @var{str}.")
2099 #define FUNC_NAME s_scm_string_downcaseS
2104 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2107 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2112 /* Helper function for the string capitalization functions.
2113 * No argument checking is performed. */
2115 string_titlecase_x (SCM str
, int start
, int end
)
2120 sz
= SCM_STRING_CHARS (str
);
2121 for(i
= start
; i
< end
; i
++)
2123 if(SCM_NFALSEP(scm_char_alphabetic_p(SCM_MAKE_CHAR(sz
[i
]))))
2127 sz
[i
] = scm_upcase(sz
[i
]);
2132 sz
[i
] = scm_downcase(sz
[i
]);
2142 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2143 (SCM str
, SCM start
, SCM end
),
2144 "Destructively titlecase every first character in a word in\n"
2146 #define FUNC_NAME s_scm_string_titlecase_x
2151 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2154 return string_titlecase_x (str
, cstart
, cend
);
2159 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2160 (SCM str
, SCM start
, SCM end
),
2161 "Titlecase every first character in a word in @var{str}.")
2162 #define FUNC_NAME s_scm_string_titlecase
2167 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2170 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2175 /* Reverse the portion of @var{str} between str[cstart] (including)
2176 and str[cend] excluding. */
2178 string_reverse_x (char * str
, int cstart
, int cend
)
2183 while (cstart
< cend
)
2186 str
[cstart
] = str
[cend
];
2194 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2195 (SCM str
, SCM start
, SCM end
),
2196 "Reverse the string @var{str}. The optional arguments\n"
2197 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2199 #define FUNC_NAME s_scm_string_reverse
2206 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2209 result
= scm_string_copy (str
);
2210 string_reverse_x (SCM_STRING_CHARS (result
), cstart
, cend
);
2216 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2217 (SCM str
, SCM start
, SCM end
),
2218 "Reverse the string @var{str} in-place. The optional arguments\n"
2219 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2220 "operate on. The return value is unspecified.")
2221 #define FUNC_NAME s_scm_string_reverse_x
2227 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2230 string_reverse_x (SCM_STRING_CHARS (str
), cstart
, cend
);
2231 return SCM_UNSPECIFIED
;
2236 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2238 "Like @code{string-append}, but the result may share memory\n"
2239 "with the argument strings.")
2240 #define FUNC_NAME s_scm_string_append_shared
2244 SCM_VALIDATE_REST_ARGUMENT (ls
);
2246 /* Optimize the one-argument case. */
2247 i
= scm_ilength (ls
);
2249 return SCM_CAR (ls
);
2251 return scm_string_append (ls
);
2256 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2258 "Append the elements of @var{ls} (which must be strings)\n"
2259 "together into a single string. Guaranteed to return a freshly\n"
2260 "allocated string.")
2261 #define FUNC_NAME s_scm_string_concatenate
2263 long strings
= scm_ilength (ls
);
2268 /* Validate the string list. */
2270 SCM_WRONG_TYPE_ARG (1, ls
);
2272 /* Calculate the size of the result string. */
2274 while (!SCM_NULLP (tmp
))
2276 SCM elt
= SCM_CAR (tmp
);
2277 SCM_VALIDATE_STRING (1, elt
);
2278 len
+= SCM_STRING_LENGTH (elt
);
2279 tmp
= SCM_CDR (tmp
);
2281 result
= scm_allocate_string (len
);
2283 /* Copy the list elements into the result. */
2284 p
= SCM_STRING_CHARS (result
);
2286 while (!SCM_NULLP (tmp
))
2288 SCM elt
= SCM_CAR (tmp
);
2289 memmove (p
, SCM_STRING_CHARS (elt
),
2290 SCM_STRING_LENGTH (elt
) * sizeof (char));
2291 p
+= SCM_STRING_LENGTH (elt
);
2292 tmp
= SCM_CDR (tmp
);
2299 SCM_DEFINE (scm_reverse_string_concatenate
, "reverse-string-concatenate", 1, 2, 0,
2300 (SCM ls
, SCM final_string
, SCM end
),
2301 "Without optional arguments, this procedure is equivalent to\n"
2304 "(string-concatenate (reverse ls))\n"
2307 "If the optional argument @var{final_string} is specified, it is\n"
2308 "consed onto the beginning to @var{ls} before performing the\n"
2309 "list-reverse and string-concatenate operations.\n"
2311 "Guaranteed to return a freshly allocated string.")
2312 #define FUNC_NAME s_scm_reverse_string_concatenate
2320 /* Check the optional arguments and calculate the additional length
2321 of the result string. */
2322 if (!SCM_UNBNDP (final_string
))
2324 SCM_VALIDATE_STRING (2, final_string
);
2325 if (!SCM_UNBNDP (end
))
2327 SCM_VALIDATE_INUM_COPY (3, end
, cend
);
2328 SCM_ASSERT_RANGE (3, end
,
2330 (cend
<= SCM_STRING_LENGTH (final_string
)));
2334 cend
= SCM_STRING_LENGTH (final_string
);
2338 strings
= scm_ilength (ls
);
2339 /* Validate the string list. */
2341 SCM_WRONG_TYPE_ARG (1, ls
);
2343 /* Calculate the length of the result string. */
2345 while (!SCM_NULLP (tmp
))
2347 SCM elt
= SCM_CAR (tmp
);
2348 SCM_VALIDATE_STRING (1, elt
);
2349 len
+= SCM_STRING_LENGTH (elt
);
2350 tmp
= SCM_CDR (tmp
);
2353 result
= scm_allocate_string (len
);
2355 p
= SCM_STRING_CHARS (result
) + len
;
2357 /* Construct the result string, possibly by using the optional final
2359 if (!SCM_UNBNDP (final_string
))
2362 memmove (p
, SCM_STRING_CHARS (final_string
), cend
* sizeof (char));
2365 while (!SCM_NULLP (tmp
))
2367 SCM elt
= SCM_CAR (tmp
);
2368 p
-= SCM_STRING_LENGTH (elt
);
2369 memmove (p
, SCM_STRING_CHARS (elt
),
2370 SCM_STRING_LENGTH (elt
) * sizeof (char));
2371 tmp
= SCM_CDR (tmp
);
2378 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2380 "Like @code{string-concatenate}, but the result may share memory\n"
2381 "with the strings in the list @var{ls}.")
2382 #define FUNC_NAME s_scm_string_concatenate_shared
2384 /* Optimize the one-string case. */
2385 long i
= scm_ilength (ls
);
2388 SCM_VALIDATE_STRING (1, SCM_CAR (ls
));
2389 return SCM_CAR (ls
);
2391 return scm_string_concatenate (ls
);
2396 SCM_DEFINE (scm_reverse_string_concatenate_shared
, "reverse-string-concatenate/shared", 1, 2, 0,
2397 (SCM ls
, SCM final_string
, SCM end
),
2398 "Like @code{reverse-string-concatenate}, but the result may\n"
2399 "share memory with the the strings in the @var{ls} arguments.")
2400 #define FUNC_NAME s_scm_reverse_string_concatenate_shared
2402 /* Just call the non-sharing version. */
2403 return scm_reverse_string_concatenate (ls
, final_string
, end
);
2408 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2409 (SCM s
, SCM proc
, SCM start
, SCM end
),
2410 "@var{proc} is a char->char procedure, it is mapped over\n"
2411 "@var{s}. The order in which the procedure is applied to the\n"
2412 "string elements is not specified.")
2413 #define FUNC_NAME s_scm_string_map
2419 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2422 SCM_VALIDATE_PROC (2, proc
);
2423 result
= scm_allocate_string (cend
- cstart
);
2424 p
= SCM_STRING_CHARS (result
);
2425 while (cstart
< cend
)
2427 SCM ch
= scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]),
2429 if (!SCM_CHARP (ch
))
2430 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
2432 *p
++ = SCM_CHAR (ch
);
2439 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2440 (SCM s
, SCM proc
, SCM start
, SCM end
),
2441 "@var{proc} is a char->char procedure, it is mapped over\n"
2442 "@var{s}. The order in which the procedure is applied to the\n"
2443 "string elements is not specified. The string @var{s} is\n"
2444 "modified in-place, the return value is not specified.")
2445 #define FUNC_NAME s_scm_string_map_x
2450 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2453 SCM_VALIDATE_PROC (2, proc
);
2454 p
= SCM_STRING_CHARS (s
) + cstart
;
2455 while (cstart
< cend
)
2457 SCM ch
= scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]),
2459 if (!SCM_CHARP (ch
))
2460 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
2462 *p
++ = SCM_CHAR (ch
);
2464 return SCM_UNSPECIFIED
;
2469 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2470 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2471 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2472 "as the terminating element, from left to right. @var{kons}\n"
2473 "must expect two arguments: The actual character and the last\n"
2474 "result of @var{kons}' application.")
2475 #define FUNC_NAME s_scm_string_fold
2481 SCM_VALIDATE_PROC (1, kons
);
2482 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2486 while (cstart
< cend
)
2488 result
= scm_apply (kons
, SCM_LIST2 (SCM_MAKE_CHAR (cstr
[cstart
]),
2497 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2498 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2499 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2500 "as the terminating element, from right to left. @var{kons}\n"
2501 "must expect two arguments: The actual character and the last\n"
2502 "result of @var{kons}' application.")
2503 #define FUNC_NAME s_scm_string_fold_right
2509 SCM_VALIDATE_PROC (1, kons
);
2510 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2514 while (cstart
< cend
)
2516 result
= scm_apply (kons
, SCM_LIST2 (SCM_MAKE_CHAR (cstr
[cend
- 1]),
2525 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2526 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2528 "@item @var{g} is used to generate a series of @emph{seed}\n"
2529 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2530 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2532 "@item @var{p} tells us when to stop -- when it returns true\n"
2533 "when applied to one of these seed values.\n"
2534 "@item @var{f} maps each seed value to the corresponding \n"
2535 "character in the result string. These chars are assembled\n"
2536 "into the string in a left-to-right order.\n"
2537 "@item @var{base} is the optional initial/leftmost portion\n"
2538 "of the constructed string; it default to the empty\n"
2540 "@item @var{make_final} is applied to the terminal seed\n"
2541 "value (on which @var{p} returns true) to produce\n"
2542 "the final/rightmost portion of the constructed string.\n"
2543 "It defaults to @code{(lambda (x) "")}.\n"
2545 #define FUNC_NAME s_scm_string_unfold
2549 SCM_VALIDATE_PROC (1, p
);
2550 SCM_VALIDATE_PROC (2, f
);
2551 SCM_VALIDATE_PROC (3, g
);
2552 if (!SCM_UNBNDP (base
))
2554 SCM_VALIDATE_STRING (5, base
);
2558 ans
= scm_allocate_string (0);
2559 if (!SCM_UNBNDP (make_final
))
2560 SCM_VALIDATE_PROC (6, make_final
);
2562 res
= scm_apply (p
, seed
, scm_listofnull
);
2563 while (SCM_FALSEP (res
))
2566 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
2567 if (!SCM_CHARP (ch
))
2568 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
2569 str
= scm_allocate_string (1);
2570 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2572 ans
= scm_string_append (SCM_LIST2 (ans
, str
));
2573 seed
= scm_apply (g
, seed
, scm_listofnull
);
2574 res
= scm_apply (p
, seed
, scm_listofnull
);
2576 if (!SCM_UNBNDP (make_final
))
2578 res
= scm_apply (make_final
, seed
, scm_listofnull
);
2579 return scm_string_append (SCM_LIST2 (ans
, res
));
2587 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2588 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2590 "@item @var{g} is used to generate a series of @emph{seed}\n"
2591 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2592 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2594 "@item @var{p} tells us when to stop -- when it returns true\n"
2595 "when applied to one of these seed values.\n"
2596 "@item @var{f} maps each seed value to the corresponding \n"
2597 "character in the result string. These chars are assembled\n"
2598 "into the string in a right-to-left order.\n"
2599 "@item @var{base} is the optional initial/rightmost portion\n"
2600 "of the constructed string; it default to the empty\n"
2602 "@item @var{make_final} is applied to the terminal seed\n"
2603 "value (on which @var{p} returns true) to produce\n"
2604 "the final/leftmost portion of the constructed string.\n"
2605 "It defaults to @code{(lambda (x) "")}.\n"
2607 #define FUNC_NAME s_scm_string_unfold_right
2611 SCM_VALIDATE_PROC (1, p
);
2612 SCM_VALIDATE_PROC (2, f
);
2613 SCM_VALIDATE_PROC (3, g
);
2614 if (!SCM_UNBNDP (base
))
2616 SCM_VALIDATE_STRING (5, base
);
2620 ans
= scm_allocate_string (0);
2621 if (!SCM_UNBNDP (make_final
))
2622 SCM_VALIDATE_PROC (6, make_final
);
2624 res
= scm_apply (p
, seed
, scm_listofnull
);
2625 while (SCM_FALSEP (res
))
2628 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
2629 if (!SCM_CHARP (ch
))
2630 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
2631 str
= scm_allocate_string (1);
2632 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2634 ans
= scm_string_append (SCM_LIST2 (str
, ans
));
2635 seed
= scm_apply (g
, seed
, scm_listofnull
);
2636 res
= scm_apply (p
, seed
, scm_listofnull
);
2638 if (!SCM_UNBNDP (make_final
))
2640 res
= scm_apply (make_final
, seed
, scm_listofnull
);
2641 return scm_string_append (SCM_LIST2 (res
, ans
));
2649 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2650 (SCM s
, SCM proc
, SCM start
, SCM end
),
2651 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2652 "return value is not specified.")
2653 #define FUNC_NAME s_scm_string_for_each
2658 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2661 SCM_VALIDATE_PROC (2, proc
);
2662 while (cstart
< cend
)
2664 scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]), scm_listofnull
);
2667 return SCM_UNSPECIFIED
;
2671 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2672 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2673 "This is the @emph{extended substring} procedure that implements\n"
2674 "replicated copying of a substring of some string.\n"
2676 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2677 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2678 "0 and the length of @var{s}. Replicate this substring up and\n"
2679 "down index space, in both the positive and negative directions.\n"
2680 "@code{xsubstring} returns the substring of this string\n"
2681 "beginning at index @var{from}, and ending at @var{to}, which\n"
2682 "defaults to @var{from} + (@var{end} - @var{start}).")
2683 #define FUNC_NAME s_scm_xsubstring
2686 int cstart
, cend
, cfrom
, cto
;
2689 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2692 SCM_VALIDATE_INUM_COPY (2, from
, cfrom
);
2693 SCM_VALIDATE_INUM_DEF_COPY (3, to
, cfrom
+ (cend
- cstart
), cto
);
2694 if (cstart
== cend
&& cfrom
!= cto
)
2695 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2697 result
= scm_allocate_string (cto
- cfrom
);
2699 p
= SCM_STRING_CHARS (result
);
2702 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2704 *p
= cs
[(cend
- cstart
) - t
];
2715 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2716 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2717 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2718 "is written into the string @var{target} starting at index\n"
2719 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2720 "@var{target} @var{s})} or these arguments share storage -- you\n"
2721 "cannot copy a string on top of itself.")
2722 #define FUNC_NAME s_scm_string_xcopy_x
2724 char * ctarget
, * cs
, * p
;
2725 int ctstart
, csfrom
, csto
, cstart
, cend
;
2726 SCM dummy
= SCM_UNDEFINED
;
2729 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
2732 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
2735 SCM_VALIDATE_INUM_COPY (4, sfrom
, csfrom
);
2736 SCM_VALIDATE_INUM_DEF_COPY (5, sto
, csfrom
+ (cend
- cstart
), csto
);
2737 if (cstart
== cend
&& csfrom
!= csto
)
2738 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2739 SCM_ASSERT_RANGE (1, tstart
,
2740 ctstart
+ (csto
- csfrom
) <= SCM_STRING_LENGTH (target
));
2742 p
= ctarget
+ ctstart
;
2743 while (csfrom
< csto
)
2745 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2747 *p
= cs
[(cend
- cstart
) - t
];
2753 return SCM_UNSPECIFIED
;
2758 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2759 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2760 "Return the string @var{s1}, but with the characters\n"
2761 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2762 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2763 #define FUNC_NAME s_scm_string_replace
2765 char * cstr1
, * cstr2
, * p
;
2766 int cstart1
, cend1
, cstart2
, cend2
;
2769 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
2772 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
2775 result
= scm_allocate_string (cstart1
+ (cend2
- cstart2
) +
2776 SCM_STRING_LENGTH (s1
) - cend1
);
2777 p
= SCM_STRING_CHARS (result
);
2778 memmove (p
, cstr1
, cstart1
);
2779 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
));
2780 memmove (p
+ cstart1
+ (cend2
- cstart2
),
2782 SCM_STRING_LENGTH (s1
) - cend1
);
2788 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2789 (SCM s
, SCM token_char
, SCM start
, SCM end
),
2790 "Split the string @var{s} into a list of substrings, where each\n"
2791 "substring is a maximal non-empty contiguous sequence of\n"
2792 "characters equal to the character @var{token_char}, or\n"
2793 "whitespace, if @var{token_char} is not given. If\n"
2794 "@var{token_char} is a character set, it is used for finding the\n"
2796 #define FUNC_NAME s_scm_string_tokenize
2800 SCM result
= SCM_EOL
;
2802 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2805 if (SCM_UNBNDP (token_char
))
2809 while (cstart
< cend
)
2811 while (cstart
< cend
)
2813 if (!isspace (cstr
[cend
- 1]))
2820 while (cstart
< cend
)
2822 if (isspace (cstr
[cend
- 1]))
2826 result
= scm_cons (scm_makfromstr (cstr
+ cend
, idx
- cend
,
2830 else if (SCM_CHARSETP (token_char
))
2834 while (cstart
< cend
)
2836 while (cstart
< cend
)
2838 if (!SCM_CHARSET_GET (token_char
, cstr
[cend
- 1]))
2845 while (cstart
< cend
)
2847 if (SCM_CHARSET_GET (token_char
, cstr
[cend
- 1]))
2851 result
= scm_cons (scm_makfromstr (cstr
+ cend
, idx
- cend
,
2860 SCM_VALIDATE_CHAR (2, token_char
);
2861 chr
= SCM_CHAR (token_char
);
2863 while (cstart
< cend
)
2865 while (cstart
< cend
)
2867 if (cstr
[cend
- 1] != chr
)
2874 while (cstart
< cend
)
2876 if (cstr
[cend
- 1] == chr
)
2880 result
= scm_cons (scm_makfromstr (cstr
+ cend
, idx
- cend
,
2889 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
2890 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2891 "Filter the string @var{s}, retaining only those characters that\n"
2892 "satisfy the @var{char_pred} argument. If the argument is a\n"
2893 "procedure, it is applied to each character as a predicate, if\n"
2894 "it is a character, it is tested for equality and if it is a\n"
2895 "character set, it is tested for membership.")
2896 #define FUNC_NAME s_scm_string_filter
2903 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2906 if (SCM_CHARP (char_pred
))
2911 chr
= SCM_CHAR (char_pred
);
2915 if (cstr
[idx
] == chr
)
2916 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2919 result
= scm_reverse_list_to_string (ls
);
2921 else if (SCM_CHARSETP (char_pred
))
2928 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2929 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2932 result
= scm_reverse_list_to_string (ls
);
2938 SCM_VALIDATE_PROC (2, char_pred
);
2943 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]),
2945 if (!SCM_FALSEP (res
))
2946 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2949 result
= scm_reverse_list_to_string (ls
);
2956 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
2957 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2958 "Filter the string @var{s}, retaining only those characters that\n"
2959 "do not satisfy the @var{char_pred} argument. If the argument\n"
2960 "is a procedure, it is applied to each character as a predicate,\n"
2961 "if it is a character, it is tested for equality and if it is a\n"
2962 "character set, it is tested for membership.")
2963 #define FUNC_NAME s_scm_string_delete
2970 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2973 if (SCM_CHARP (char_pred
))
2978 chr
= SCM_CHAR (char_pred
);
2982 if (cstr
[idx
] != chr
)
2983 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2986 result
= scm_reverse_list_to_string (ls
);
2988 else if (SCM_CHARSETP (char_pred
))
2995 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2996 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2999 result
= scm_reverse_list_to_string (ls
);
3005 SCM_VALIDATE_PROC (2, char_pred
);
3010 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]),
3012 if (SCM_FALSEP (res
))
3013 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
3016 result
= scm_reverse_list_to_string (ls
);
3026 #ifndef SCM_MAGIC_SNARFER
3027 #include "srfi-13.x"
3033 scm_init_srfi_13_14 ()
3035 static int initialized
= 0;
3039 SCM srfi_13_module
= scm_make_module (scm_read_0str ("(srfi srfi-13)"));
3040 SCM srfi_14_module
= scm_make_module (scm_read_0str ("(srfi srfi-14)"));
3045 old_module
= scm_set_current_module (srfi_13_module
);
3046 scm_init_srfi_13 ();
3047 scm_set_current_module (srfi_14_module
);
3048 scm_init_srfi_14 ();
3050 scm_set_current_module (old_module
);