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. */
55 SCM_DEFINE (scm_string_any
, "string-any", 2, 2, 0,
56 (SCM pred
, SCM s
, SCM start
, SCM end
),
57 "Check if the predicate @var{pred} is true for any character in\n"
58 "the string @var{s}, proceeding from left (index @var{start}) to\n"
59 "right (index @var{end}). If @code{string-any} returns true,\n"
60 "the returned true value is the one produced by the first\n"
61 "successful application of @var{pred}.")
62 #define FUNC_NAME s_scm_string_any
68 SCM_VALIDATE_PROC (1, pred
);
69 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
75 res
= scm_apply (pred
, SCM_MAKE_CHAR (*cstr
), scm_listofnull
);
76 if (!SCM_FALSEP (res
))
86 SCM_DEFINE (scm_string_every
, "string-every", 2, 2, 0,
87 (SCM pred
, SCM s
, SCM start
, SCM end
),
88 "Check if the predicate @var{pred} is true for every character\n"
89 "in the string @var{s}, proceeding from left (index @var{start})\n"
90 "to right (index @var{end}). If @code{string-every} returns\n"
91 "true, the returned true value is the one produced by the final\n"
92 "application of @var{pred} to the last character of @var{s}.")
93 #define FUNC_NAME s_scm_string_every
99 SCM_VALIDATE_PROC (1, pred
);
100 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
105 while (cstart
< cend
)
107 res
= scm_apply (pred
, SCM_MAKE_CHAR (*cstr
), scm_listofnull
);
108 if (SCM_FALSEP (res
))
118 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
120 "@var{proc} is an integer->char procedure. Construct a string\n"
121 "of size @var{len} by applying @var{proc} to each index to\n"
122 "produce the corresponding string element. The order in which\n"
123 "@var{proc} is applied to the indices is not specified.")
124 #define FUNC_NAME s_scm_string_tabulate
131 SCM_VALIDATE_PROC (1, proc
);
132 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
133 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
135 res
= scm_allocate_string (clen
);
136 p
= SCM_STRING_CHARS (res
);
140 ch
= scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
);
142 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
143 *p
++ = SCM_CHAR (ch
);
151 SCM_DEFINE (scm_string_to_listS
, "string->list", 1, 2, 0,
152 (SCM str
, SCM start
, SCM end
),
153 "Convert the string @var{str} into a list of characters.")
154 #define FUNC_NAME s_scm_string_to_listS
158 SCM result
= SCM_EOL
;
160 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
163 while (cstart
< cend
)
166 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
172 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
174 "An efficient implementation of @code{(compose string->list\n"
178 "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n"
180 #define FUNC_NAME s_scm_reverse_list_to_string
183 long i
= scm_ilength (chrs
);
186 SCM_WRONG_TYPE_ARG (1, chrs
);
187 result
= scm_allocate_string (i
);
190 unsigned char *data
= SCM_STRING_UCHARS (result
) + i
;
192 while (!SCM_NULLP (chrs
))
194 SCM elt
= SCM_CAR (chrs
);
196 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
198 *data
= SCM_CHAR (elt
);
199 chrs
= SCM_CDR (chrs
);
207 SCM_SYMBOL (scm_sym_infix
, "infix");
208 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
209 SCM_SYMBOL (scm_sym_suffix
, "suffix");
210 SCM_SYMBOL (scm_sym_prefix
, "prefix");
212 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
213 (SCM ls
, SCM delimiter
, SCM grammar
),
214 "Append the string in the string list @var{ls}, using the string\n"
215 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
216 "@var{grammar} is a symbol which specifies how the delimiter is\n"
217 "placed between the strings, and defaults to the symbol\n"
222 "Insert the separator between list elements. An empty string\n"
223 "will produce an empty list.\n"
224 "@item string-infix\n"
225 "Like @code{infix}, but will raise an error if given the empty\n"
228 "Insert the separator after every list element.\n"
230 "Insert the separator before each list element.\n"
232 #define FUNC_NAME s_scm_string_join
235 #define GRAM_STRICT_INFIX 1
236 #define GRAM_SUFFIX 2
237 #define GRAM_PREFIX 3
240 int gram
= GRAM_INFIX
;
241 int del_len
= 0, extra_len
= 0;
244 long strings
= scm_ilength (ls
);
246 /* Validate the string list. */
248 SCM_WRONG_TYPE_ARG (1, ls
);
250 /* Validate the delimiter and record its length. */
251 if (SCM_UNBNDP (delimiter
))
253 delimiter
= scm_makfrom0str (" ");
258 SCM_VALIDATE_STRING (2, delimiter
);
259 del_len
= SCM_STRING_LENGTH (delimiter
);
262 /* Validate the grammar symbol and remember the grammar. */
263 if (SCM_UNBNDP (grammar
))
265 else if (SCM_EQ_P (grammar
, scm_sym_infix
))
267 else if (SCM_EQ_P (grammar
, scm_sym_strict_infix
))
268 gram
= GRAM_STRICT_INFIX
;
269 else if (SCM_EQ_P (grammar
, scm_sym_suffix
))
271 else if (SCM_EQ_P (grammar
, scm_sym_prefix
))
274 SCM_WRONG_TYPE_ARG (3, grammar
);
276 /* Check grammar constraints and calculate the space required for
282 extra_len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
284 case GRAM_STRICT_INFIX
:
286 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
288 extra_len
= (strings
- 1) * del_len
;
291 extra_len
= strings
* del_len
;
296 while (SCM_CONSP (tmp
))
298 SCM elt
= SCM_CAR (tmp
);
299 SCM_VALIDATE_STRING (1, elt
);
300 len
+= SCM_STRING_LENGTH (elt
);
304 result
= scm_allocate_string (len
+ extra_len
);
305 p
= SCM_STRING_CHARS (result
);
311 case GRAM_STRICT_INFIX
:
312 while (!SCM_NULLP (tmp
))
314 SCM elt
= SCM_CAR (tmp
);
315 memmove (p
, SCM_STRING_CHARS (elt
),
316 SCM_STRING_LENGTH (elt
) * sizeof (char));
317 p
+= SCM_STRING_LENGTH (elt
);
318 if (!SCM_NULLP (SCM_CDR (tmp
)) && del_len
> 0)
320 memmove (p
, SCM_STRING_CHARS (delimiter
),
321 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
328 while (!SCM_NULLP (tmp
))
330 SCM elt
= SCM_CAR (tmp
);
331 memmove (p
, SCM_STRING_CHARS (elt
),
332 SCM_STRING_LENGTH (elt
) * sizeof (char));
333 p
+= SCM_STRING_LENGTH (elt
);
336 memmove (p
, SCM_STRING_CHARS (delimiter
),
337 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
344 while (!SCM_NULLP (tmp
))
346 SCM elt
= SCM_CAR (tmp
);
349 memmove (p
, SCM_STRING_CHARS (delimiter
),
350 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
353 memmove (p
, SCM_STRING_CHARS (elt
),
354 SCM_STRING_LENGTH (elt
) * sizeof (char));
355 p
+= SCM_STRING_LENGTH (elt
);
362 #undef GRAM_STRICT_INFIX
369 SCM_DEFINE (scm_string_copyS
, "string-copy", 1, 2, 0,
370 (SCM str
, SCM start
, SCM end
),
371 "Return a freshly allocated copy of the string @var{str}. If\n"
372 "given, @var{start} and @var{end} delimit the portion of\n"
373 "@var{str} which is copied.")
374 #define FUNC_NAME s_scm_string_copyS
379 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
382 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
388 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
389 (SCM str
, SCM start
, SCM end
),
390 "Like @code{substring}, but the result may share memory with the\n"
391 "argument @var{str}.")
392 #define FUNC_NAME s_scm_substring_shared
394 SCM_VALIDATE_STRING (1, str
);
395 SCM_VALIDATE_INUM (2, start
);
396 if (SCM_UNBNDP (end
))
397 end
= SCM_MAKINUM (SCM_STRING_LENGTH (str
));
399 SCM_VALIDATE_INUM (3, end
);
400 if (SCM_INUM (start
) == 0 &&
401 SCM_INUM (end
) == SCM_STRING_LENGTH (str
))
403 return scm_substring (str
, start
, end
);
408 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
409 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
410 "Copy the sequence of characters from index range [@var{start},\n"
411 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
412 "at index @var{tstart}. The characters are copied left-to-right\n"
413 "or right-to-left as needed -- the copy is guaranteed to work,\n"
414 "even if @var{target} and @var{s} are the same string. It is an\n"
415 "error if the copy operation runs off the end of the target\n"
417 #define FUNC_NAME s_scm_string_copy_x
419 char * cstr
, * ctarget
;
420 int cstart
, cend
, ctstart
, dummy
;
422 SCM sdummy
= SCM_UNDEFINED
;
424 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
427 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
431 SCM_ASSERT_RANGE (3, s
, len
<= SCM_STRING_LENGTH (target
) - ctstart
);
433 memmove (SCM_STRING_CHARS (target
) + ctstart
,
434 SCM_STRING_CHARS (s
) + cstart
,
435 len
* sizeof (char));
436 return SCM_UNSPECIFIED
;
441 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
443 "Return the @var{n} first characters of @var{s}.")
444 #define FUNC_NAME s_scm_string_take
449 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
450 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
451 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
453 return scm_mem2string (cstr
, cn
);
458 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
460 "Return all but the first @var{n} characters of @var{s}.")
461 #define FUNC_NAME s_scm_string_drop
466 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
467 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
468 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
470 return scm_mem2string (cstr
+ cn
, SCM_STRING_LENGTH (s
) - cn
);
475 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
477 "Return the @var{n} last characters of @var{s}.")
478 #define FUNC_NAME s_scm_string_take_right
483 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
484 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
485 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
487 return scm_mem2string (cstr
+ SCM_STRING_LENGTH (s
) - cn
, cn
);
492 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
494 "Return all but the last @var{n} characters of @var{s}.")
495 #define FUNC_NAME s_scm_string_drop_right
500 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
501 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
502 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
504 return scm_mem2string (cstr
, SCM_STRING_LENGTH (s
) - cn
);
509 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
510 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
511 "Take that characters from @var{start} to @var{end} from the\n"
512 "string @var{s} and return a new string, right-padded by the\n"
513 "character @var{chr} to length @var{len}. If the resulting\n"
514 "string is longer than @var{len}, it is truncated on the right.")
515 #define FUNC_NAME s_scm_string_pad
519 int cstart
, cend
, clen
;
522 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
525 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
526 if (SCM_UNBNDP (chr
))
530 SCM_VALIDATE_CHAR (3, chr
);
531 cchr
= SCM_CHAR (chr
);
533 result
= scm_allocate_string (clen
);
534 if (clen
< (cend
- cstart
))
535 memmove (SCM_STRING_CHARS (result
),
537 clen
* sizeof (char));
540 memset (SCM_STRING_CHARS (result
), cchr
,
541 (clen
- (cend
- cstart
)) * sizeof (char));
542 memmove (SCM_STRING_CHARS (result
) + (clen
- (cend
- cstart
)),
544 (cend
- cstart
) * sizeof (char));
551 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
552 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
553 "Take that characters from @var{start} to @var{end} from the\n"
554 "string @var{s} and return a new string, left-padded by the\n"
555 "character @var{chr} to length @var{len}. If the resulting\n"
556 "string is longer than @var{len}, it is truncated on the left.")
557 #define FUNC_NAME s_scm_string_pad_right
561 int cstart
, cend
, clen
;
564 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
567 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
568 if (SCM_UNBNDP (chr
))
572 SCM_VALIDATE_CHAR (3, chr
);
573 cchr
= SCM_CHAR (chr
);
575 result
= scm_allocate_string (clen
);
576 if (clen
< (cend
- cstart
))
577 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
, clen
* sizeof (char));
580 memset (SCM_STRING_CHARS (result
) + (cend
- cstart
),
581 cchr
, (clen
- (cend
- cstart
)) * sizeof (char));
582 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
,
583 (cend
- cstart
) * sizeof (char));
590 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
591 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
592 "Trim @var{s} by skipping over all characters on the left\n"
593 "that satisfy the parameter @var{char_pred}:\n"
597 "if it is the character @var{ch}, characters equal to\n"
598 "@var{ch} are trimmed,\n"
601 "if it is a procedure @var{pred} characters that\n"
602 "satisfy @var{pred} are trimmed,\n"
605 "if it is a character set, characters in that set are trimmed.\n"
608 "If called without a @var{char_pred} argument, all whitespace is\n"
610 #define FUNC_NAME s_scm_string_trim
615 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
618 if (SCM_UNBNDP (char_pred
))
620 while (cstart
< cend
)
622 if (!isspace(cstr
[cstart
]))
627 else if (SCM_CHARP (char_pred
))
629 char chr
= SCM_CHAR (char_pred
);
630 while (cstart
< cend
)
632 if (chr
!= cstr
[cstart
])
637 else if (SCM_CHARSETP (char_pred
))
639 while (cstart
< cend
)
641 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
648 SCM_VALIDATE_PROC (2, char_pred
);
649 while (cstart
< cend
)
653 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
655 if (SCM_FALSEP (res
))
660 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
665 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
666 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
667 "Trim @var{s} by skipping over all characters on the rightt\n"
668 "that satisfy the parameter @var{char_pred}:\n"
672 "if it is the character @var{ch}, characters equal to @var{ch}\n"
676 "if it is a procedure @var{pred} characters that satisfy\n"
677 "@var{pred} are trimmed,\n"
680 "if it is a character sets, all characters in that set are\n"
684 "If called without a @var{char_pred} argument, all whitespace is\n"
686 #define FUNC_NAME s_scm_string_trim_right
691 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
694 if (SCM_UNBNDP (char_pred
))
696 while (cstart
< cend
)
698 if (!isspace(cstr
[cend
- 1]))
703 else if (SCM_CHARP (char_pred
))
705 char chr
= SCM_CHAR (char_pred
);
706 while (cstart
< cend
)
708 if (chr
!= cstr
[cend
- 1])
713 else if (SCM_CHARSETP (char_pred
))
715 while (cstart
< cend
)
717 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
724 SCM_VALIDATE_PROC (2, char_pred
);
725 while (cstart
< cend
)
729 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]),
731 if (SCM_FALSEP (res
))
736 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
741 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
742 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
743 "Trim @var{s} by skipping over all characters on both sides of\n"
744 "the string that satisfy the parameter @var{char_pred}:\n"
748 "if it is the character @var{ch}, characters equal to @var{ch}\n"
752 "if it is a procedure @var{pred} characters that satisfy\n"
753 "@var{pred} are trimmed,\n"
756 "if it is a character set, the characters in the set are\n"
760 "If called without a @var{char_pred} argument, all whitespace is\n"
762 #define FUNC_NAME s_scm_string_trim_both
767 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
770 if (SCM_UNBNDP (char_pred
))
772 while (cstart
< cend
)
774 if (!isspace(cstr
[cstart
]))
778 while (cstart
< cend
)
780 if (!isspace(cstr
[cend
- 1]))
785 else if (SCM_CHARP (char_pred
))
787 char chr
= SCM_CHAR (char_pred
);
788 while (cstart
< cend
)
790 if (chr
!= cstr
[cstart
])
794 while (cstart
< cend
)
796 if (chr
!= cstr
[cend
- 1])
801 else if (SCM_CHARSETP (char_pred
))
803 while (cstart
< cend
)
805 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
809 while (cstart
< cend
)
811 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
818 SCM_VALIDATE_PROC (2, char_pred
);
819 while (cstart
< cend
)
823 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
825 if (SCM_FALSEP (res
))
829 while (cstart
< cend
)
833 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]),
835 if (SCM_FALSEP (res
))
840 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
845 SCM_DEFINE (scm_string_fill_xS
, "string-fill!", 2, 2, 0,
846 (SCM str
, SCM chr
, SCM start
, SCM end
),
847 "Stores @var{chr} in every element of the given @var{str} and\n"
848 "returns an unspecified value.")
849 #define FUNC_NAME s_scm_string_fill_xS
856 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
859 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
860 for (k
= cstart
; k
< cend
; k
++)
862 return SCM_UNSPECIFIED
;
867 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
868 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
869 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
870 "mismatch index, depending upon whether @var{s1} is less than,\n"
871 "equal to, or greater than @var{s2}. The mismatch index is the\n"
872 "largest index @var{i} such that for every 0 <= @var{j} <\n"
873 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
874 "@var{i} is the first position that does not match.")
875 #define FUNC_NAME s_scm_string_compare
877 char * cstr1
, * cstr2
;
878 int cstart1
, cend1
, cstart2
, cend2
;
880 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
883 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
886 SCM_VALIDATE_PROC (3, proc_lt
);
887 SCM_VALIDATE_PROC (4, proc_eq
);
888 SCM_VALIDATE_PROC (5, proc_gt
);
890 while (cstart1
< cend1
&& cstart2
< cend2
)
892 if (cstr1
[cstart1
] < cstr2
[cstart2
])
893 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
894 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
895 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
900 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
901 else if (cstart2
< cend2
)
902 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
904 return scm_apply (proc_eq
, SCM_MAKINUM (cstart1
), scm_listofnull
);
909 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
910 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
911 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
912 "mismatch index, depending upon whether @var{s1} is less than,\n"
913 "equal to, or greater than @var{s2}. The mismatch index is the\n"
914 "largest index @var{i} such that for every 0 <= @var{j} <\n"
915 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
916 "@var{i} is the first position that does not match. The\n"
917 "character comparison is done case-insensitively.")
918 #define FUNC_NAME s_scm_string_compare_ci
920 char * cstr1
, * cstr2
;
921 int cstart1
, cend1
, cstart2
, cend2
;
923 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
926 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
929 SCM_VALIDATE_PROC (3, proc_lt
);
930 SCM_VALIDATE_PROC (4, proc_eq
);
931 SCM_VALIDATE_PROC (5, proc_gt
);
933 while (cstart1
< cend1
&& cstart2
< cend2
)
935 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
936 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
937 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
938 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
943 return scm_apply (proc_gt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
944 else if (cstart2
< cend2
)
945 return scm_apply (proc_lt
, SCM_MAKINUM (cstart1
), scm_listofnull
);
947 return scm_apply (proc_eq
, SCM_MAKINUM (cstart1
), scm_listofnull
);
952 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
953 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
954 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
956 #define FUNC_NAME s_scm_string_eq
958 char * cstr1
, * cstr2
;
959 int cstart1
, cend1
, cstart2
, cend2
;
961 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
964 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
968 while (cstart1
< cend1
&& cstart2
< cend2
)
970 if (cstr1
[cstart1
] < cstr2
[cstart2
])
972 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
979 else if (cstart2
< cend2
)
982 return SCM_MAKINUM (cstart1
);
987 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
988 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
989 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
991 #define FUNC_NAME s_scm_string_neq
993 char * cstr1
, * cstr2
;
994 int cstart1
, cend1
, cstart2
, cend2
;
996 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
999 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1003 while (cstart1
< cend1
&& cstart2
< cend2
)
1005 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1006 return SCM_MAKINUM (cstart1
);
1007 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1008 return SCM_MAKINUM (cstart1
);
1012 if (cstart1
< cend1
)
1013 return SCM_MAKINUM (cstart1
);
1014 else if (cstart2
< cend2
)
1015 return SCM_MAKINUM (cstart1
);
1022 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1023 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1024 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1025 "true value otherwise.")
1026 #define FUNC_NAME s_scm_string_lt
1028 char * cstr1
, * cstr2
;
1029 int cstart1
, cend1
, cstart2
, cend2
;
1031 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1034 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1038 while (cstart1
< cend1
&& cstart2
< cend2
)
1040 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1041 return SCM_MAKINUM (cstart1
);
1042 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1047 if (cstart1
< cend1
)
1049 else if (cstart2
< cend2
)
1050 return SCM_MAKINUM (cstart1
);
1057 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1058 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1059 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1060 "true value otherwise.")
1061 #define FUNC_NAME s_scm_string_gt
1063 char * cstr1
, * cstr2
;
1064 int cstart1
, cend1
, cstart2
, cend2
;
1066 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1069 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1073 while (cstart1
< cend1
&& cstart2
< cend2
)
1075 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1077 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1078 return SCM_MAKINUM (cstart1
);
1082 if (cstart1
< cend1
)
1083 return SCM_MAKINUM (cstart1
);
1084 else if (cstart2
< cend2
)
1092 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1093 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1094 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1096 #define FUNC_NAME s_scm_string_le
1098 char * cstr1
, * cstr2
;
1099 int cstart1
, cend1
, cstart2
, cend2
;
1101 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1104 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1108 while (cstart1
< cend1
&& cstart2
< cend2
)
1110 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1111 return SCM_MAKINUM (cstart1
);
1112 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1117 if (cstart1
< cend1
)
1119 else if (cstart2
< cend2
)
1120 return SCM_MAKINUM (cstart1
);
1122 return SCM_MAKINUM (cstart1
);
1127 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1128 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1129 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1131 #define FUNC_NAME s_scm_string_ge
1133 char * cstr1
, * cstr2
;
1134 int cstart1
, cend1
, cstart2
, cend2
;
1136 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1139 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1143 while (cstart1
< cend1
&& cstart2
< cend2
)
1145 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1147 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1148 return SCM_MAKINUM (cstart1
);
1152 if (cstart1
< cend1
)
1153 return SCM_MAKINUM (cstart1
);
1154 else if (cstart2
< cend2
)
1157 return SCM_MAKINUM (cstart1
);
1162 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1163 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1164 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1165 "value otherwise. The character comparison is done\n"
1166 "case-insensitively.")
1167 #define FUNC_NAME s_scm_string_ci_eq
1169 char * cstr1
, * cstr2
;
1170 int cstart1
, cend1
, cstart2
, cend2
;
1172 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1175 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1179 while (cstart1
< cend1
&& cstart2
< cend2
)
1181 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1183 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1188 if (cstart1
< cend1
)
1190 else if (cstart2
< cend2
)
1193 return SCM_MAKINUM (cstart1
);
1198 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1199 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1200 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1201 "value otherwise. The character comparison is done\n"
1202 "case-insensitively.")
1203 #define FUNC_NAME s_scm_string_ci_neq
1205 char * cstr1
, * cstr2
;
1206 int cstart1
, cend1
, cstart2
, cend2
;
1208 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1211 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1215 while (cstart1
< cend1
&& cstart2
< cend2
)
1217 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1218 return SCM_MAKINUM (cstart1
);
1219 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1220 return SCM_MAKINUM (cstart1
);
1224 if (cstart1
< cend1
)
1225 return SCM_MAKINUM (cstart1
);
1226 else if (cstart2
< cend2
)
1227 return SCM_MAKINUM (cstart1
);
1234 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1235 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1236 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1237 "true value otherwise. The character comparison is done\n"
1238 "case-insensitively.")
1239 #define FUNC_NAME s_scm_string_ci_lt
1241 char * cstr1
, * cstr2
;
1242 int cstart1
, cend1
, cstart2
, cend2
;
1244 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1247 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1251 while (cstart1
< cend1
&& cstart2
< cend2
)
1253 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1254 return SCM_MAKINUM (cstart1
);
1255 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1260 if (cstart1
< cend1
)
1262 else if (cstart2
< cend2
)
1263 return SCM_MAKINUM (cstart1
);
1270 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1271 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1272 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1273 "true value otherwise. The character comparison is done\n"
1274 "case-insensitively.")
1275 #define FUNC_NAME s_scm_string_ci_gt
1277 char * cstr1
, * cstr2
;
1278 int cstart1
, cend1
, cstart2
, cend2
;
1280 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1283 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1287 while (cstart1
< cend1
&& cstart2
< cend2
)
1289 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1291 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1292 return SCM_MAKINUM (cstart1
);
1296 if (cstart1
< cend1
)
1297 return SCM_MAKINUM (cstart1
);
1298 else if (cstart2
< cend2
)
1306 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1307 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1308 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1309 "value otherwise. The character comparison is done\n"
1310 "case-insensitively.")
1311 #define FUNC_NAME s_scm_string_ci_le
1313 char * cstr1
, * cstr2
;
1314 int cstart1
, cend1
, cstart2
, cend2
;
1316 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1319 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1323 while (cstart1
< cend1
&& cstart2
< cend2
)
1325 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1326 return SCM_MAKINUM (cstart1
);
1327 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1332 if (cstart1
< cend1
)
1334 else if (cstart2
< cend2
)
1335 return SCM_MAKINUM (cstart1
);
1337 return SCM_MAKINUM (cstart1
);
1342 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1343 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1344 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1345 "otherwise. The character comparison is done\n"
1346 "case-insensitively.")
1347 #define FUNC_NAME s_scm_string_ci_ge
1349 char * cstr1
, * cstr2
;
1350 int cstart1
, cend1
, cstart2
, cend2
;
1352 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1355 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1359 while (cstart1
< cend1
&& cstart2
< cend2
)
1361 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1363 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1364 return SCM_MAKINUM (cstart1
);
1368 if (cstart1
< cend1
)
1369 return SCM_MAKINUM (cstart1
);
1370 else if (cstart2
< cend2
)
1373 return SCM_MAKINUM (cstart1
);
1378 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1379 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1380 "Return the length of the longest common prefix of the two\n"
1382 #define FUNC_NAME s_scm_string_prefix_length
1384 char * cstr1
, * cstr2
;
1385 int cstart1
, cend1
, cstart2
, cend2
;
1388 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1391 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1394 while (cstart1
< cend1
&& cstart2
< cend2
)
1396 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1397 return SCM_MAKINUM (len
);
1402 return SCM_MAKINUM (len
);
1407 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1408 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1409 "Return the length of the longest common prefix of the two\n"
1410 "strings, ignoring character case.")
1411 #define FUNC_NAME s_scm_string_prefix_length_ci
1413 char * cstr1
, * cstr2
;
1414 int cstart1
, cend1
, cstart2
, cend2
;
1417 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1420 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1423 while (cstart1
< cend1
&& cstart2
< cend2
)
1425 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1426 return SCM_MAKINUM (len
);
1431 return SCM_MAKINUM (len
);
1436 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1437 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1438 "Return the length of the longest common suffix of the two\n"
1440 #define FUNC_NAME s_scm_string_suffix_length
1442 char * cstr1
, * cstr2
;
1443 int cstart1
, cend1
, cstart2
, cend2
;
1446 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1449 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1452 while (cstart1
< cend1
&& cstart2
< cend2
)
1456 if (cstr1
[cend1
] != cstr2
[cend2
])
1457 return SCM_MAKINUM (len
);
1460 return SCM_MAKINUM (len
);
1465 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1466 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1467 "Return the length of the longest common suffix of the two\n"
1468 "strings, ignoring character case.")
1469 #define FUNC_NAME s_scm_string_suffix_length_ci
1471 char * cstr1
, * cstr2
;
1472 int cstart1
, cend1
, cstart2
, cend2
;
1475 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1478 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1481 while (cstart1
< cend1
&& cstart2
< cend2
)
1485 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1486 return SCM_MAKINUM (len
);
1489 return SCM_MAKINUM (len
);
1494 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1495 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1496 "Is @var{s1} a prefix of @var{s2}?")
1497 #define FUNC_NAME s_scm_string_prefix_p
1499 char * cstr1
, * cstr2
;
1500 int cstart1
, cend1
, cstart2
, cend2
;
1503 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1506 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1509 len1
= cend1
- cstart1
;
1510 while (cstart1
< cend1
&& cstart2
< cend2
)
1512 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1513 return SCM_BOOL (len
== len1
);
1518 return SCM_BOOL (len
== len1
);
1523 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1524 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1525 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1526 #define FUNC_NAME s_scm_string_prefix_ci_p
1528 char * cstr1
, * cstr2
;
1529 int cstart1
, cend1
, cstart2
, cend2
;
1532 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1535 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1538 len1
= cend1
- cstart1
;
1539 while (cstart1
< cend1
&& cstart2
< cend2
)
1541 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1542 return SCM_BOOL (len
== len1
);
1547 return SCM_BOOL (len
== len1
);
1552 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1553 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1554 "Is @var{s1} a suffix of @var{s2}?")
1555 #define FUNC_NAME s_scm_string_suffix_p
1557 char * cstr1
, * cstr2
;
1558 int cstart1
, cend1
, cstart2
, cend2
;
1561 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1564 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1567 len1
= cend1
- cstart1
;
1568 while (cstart1
< cend1
&& cstart2
< cend2
)
1572 if (cstr1
[cend1
] != cstr2
[cend2
])
1573 return SCM_BOOL (len
== len1
);
1576 return SCM_BOOL (len
== len1
);
1581 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1582 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1583 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1584 #define FUNC_NAME s_scm_string_suffix_ci_p
1586 char * cstr1
, * cstr2
;
1587 int cstart1
, cend1
, cstart2
, cend2
;
1590 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1593 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1596 len1
= cend1
- cstart1
;
1597 while (cstart1
< cend1
&& cstart2
< cend2
)
1601 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1602 return SCM_BOOL (len
== len1
);
1605 return SCM_BOOL (len
== len1
);
1610 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1611 in the core, which does not accept a predicate. */
1612 SCM_DEFINE (scm_string_indexS
, "string-index", 2, 2, 0,
1613 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1614 "Search through the string @var{s} from left to right, returning\n"
1615 "the index of the first occurence of a character which\n"
1617 "@itemize @bullet\n"
1619 "equals @var{char_pred}, if it is character,\n"
1622 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1625 "is in the set @var{char_pred}, if it is a character set.\n"
1627 #define FUNC_NAME s_scm_string_indexS
1632 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1635 if (SCM_CHARP (char_pred
))
1637 char cchr
= SCM_CHAR (char_pred
);
1638 while (cstart
< cend
)
1640 if (cchr
== cstr
[cstart
])
1641 return SCM_MAKINUM (cstart
);
1645 else if (SCM_CHARSETP (char_pred
))
1647 while (cstart
< cend
)
1649 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1650 return SCM_MAKINUM (cstart
);
1656 SCM_VALIDATE_PROC (2, char_pred
);
1657 while (cstart
< cend
)
1660 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1662 if (!SCM_FALSEP (res
))
1663 return SCM_MAKINUM (cstart
);
1672 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1673 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1674 "Search through the string @var{s} from right to left, returning\n"
1675 "the index of the last occurence of a character which\n"
1677 "@itemize @bullet\n"
1679 "equals @var{char_pred}, if it is character,\n"
1682 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1685 "is in the set if @var{char_pred} is a character set.\n"
1687 #define FUNC_NAME s_scm_string_index_right
1692 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1695 if (SCM_CHARP (char_pred
))
1697 char cchr
= SCM_CHAR (char_pred
);
1698 while (cstart
< cend
)
1701 if (cchr
== cstr
[cend
])
1702 return SCM_MAKINUM (cend
);
1705 else if (SCM_CHARSETP (char_pred
))
1707 while (cstart
< cend
)
1710 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1711 return SCM_MAKINUM (cend
);
1716 SCM_VALIDATE_PROC (2, char_pred
);
1717 while (cstart
< cend
)
1721 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]),
1723 if (!SCM_FALSEP (res
))
1724 return SCM_MAKINUM (cend
);
1732 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1733 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1734 "Search through the string @var{s} from left to right, returning\n"
1735 "the index of the first occurence of a character which\n"
1737 "@itemize @bullet\n"
1739 "does not equal @var{char_pred}, if it is character,\n"
1742 "does not satisify the predicate @var{char_pred}, if it is a\n"
1746 "is not in the set if @var{char_pred} is a character set.\n"
1748 #define FUNC_NAME s_scm_string_skip
1753 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1756 if (SCM_CHARP (char_pred
))
1758 char cchr
= SCM_CHAR (char_pred
);
1759 while (cstart
< cend
)
1761 if (cchr
!= cstr
[cstart
])
1762 return SCM_MAKINUM (cstart
);
1766 else if (SCM_CHARSETP (char_pred
))
1768 while (cstart
< cend
)
1770 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1771 return SCM_MAKINUM (cstart
);
1777 SCM_VALIDATE_PROC (2, char_pred
);
1778 while (cstart
< cend
)
1781 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1783 if (SCM_FALSEP (res
))
1784 return SCM_MAKINUM (cstart
);
1793 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1794 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1795 "Search through the string @var{s} from right to left, returning\n"
1796 "the index of the last occurence of a character which\n"
1798 "@itemize @bullet\n"
1800 "does not equal @var{char_pred}, if it is character,\n"
1803 "does not satisifie the predicate @var{char_pred}, if it is a\n"
1807 "is not in the set if @var{char_pred} is a character set.\n"
1809 #define FUNC_NAME s_scm_string_skip_right
1814 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1817 if (SCM_CHARP (char_pred
))
1819 char cchr
= SCM_CHAR (char_pred
);
1820 while (cstart
< cend
)
1823 if (cchr
!= cstr
[cend
])
1824 return SCM_MAKINUM (cend
);
1827 else if (SCM_CHARSETP (char_pred
))
1829 while (cstart
< cend
)
1832 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1833 return SCM_MAKINUM (cend
);
1838 SCM_VALIDATE_PROC (2, char_pred
);
1839 while (cstart
< cend
)
1843 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]),
1845 if (SCM_FALSEP (res
))
1846 return SCM_MAKINUM (cend
);
1854 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1855 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1856 "Return the count of the number of characters in the string\n"
1859 "@itemize @bullet\n"
1861 "equals @var{char_pred}, if it is character,\n"
1864 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1867 "is in the set @var{char_pred}, if it is a character set.\n"
1869 #define FUNC_NAME s_scm_string_count
1875 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1878 if (SCM_CHARP (char_pred
))
1880 char cchr
= SCM_CHAR (char_pred
);
1881 while (cstart
< cend
)
1883 if (cchr
== cstr
[cstart
])
1888 else if (SCM_CHARSETP (char_pred
))
1890 while (cstart
< cend
)
1892 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1899 SCM_VALIDATE_PROC (2, char_pred
);
1900 while (cstart
< cend
)
1903 res
= scm_apply (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]),
1905 if (!SCM_FALSEP (res
))
1910 return SCM_MAKINUM (count
);
1915 /* FIXME::martin: This should definitely get implemented more
1916 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1918 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1919 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1920 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1921 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1922 "The optional start/end indices restrict the operation to the\n"
1923 "indicated substrings.")
1924 #define FUNC_NAME s_scm_string_contains
1927 int cstart1
, cend1
, cstart2
, cend2
;
1930 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1933 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1936 len2
= cend2
- cstart2
;
1937 while (cstart1
<= cend1
- len2
)
1941 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
1947 return SCM_MAKINUM (cstart1
);
1955 /* FIXME::martin: This should definitely get implemented more
1956 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1958 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
1959 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1960 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1961 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1962 "The optional start/end indices restrict the operation to the\n"
1963 "indicated substrings. Character comparison is done\n"
1964 "case-insensitively.")
1965 #define FUNC_NAME s_scm_string_contains_ci
1968 int cstart1
, cend1
, cstart2
, cend2
;
1971 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1974 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1977 len2
= cend2
- cstart2
;
1978 while (cstart1
<= cend1
- len2
)
1982 while (i
< cend1
&& j
< cend2
&&
1983 scm_downcase (cs1
[i
]) == scm_downcase (cs2
[j
]))
1989 return SCM_MAKINUM (cstart1
);
1997 /* Helper function for the string uppercase conversion functions.
1998 * No argument checking is performed. */
2000 string_upcase_x (SCM v
, int start
, int end
)
2004 for (k
= start
; k
< end
; ++k
)
2005 SCM_STRING_UCHARS (v
) [k
] = scm_upcase (SCM_STRING_UCHARS (v
) [k
]);
2011 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2012 in the core, which does not accept start/end indices */
2013 SCM_DEFINE (scm_string_upcase_xS
, "string-upcase!", 1, 2, 0,
2014 (SCM str
, SCM start
, SCM end
),
2015 "Destructively upcase every character in @code{str}.\n"
2018 "(string-upcase! y)\n"
2019 "@result{} \"ARRDEFG\"\n"
2021 "@result{} \"ARRDEFG\"\n"
2023 #define FUNC_NAME s_scm_string_upcase_xS
2028 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2031 return string_upcase_x (str
, cstart
, cend
);
2036 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2037 in the core, which does not accept start/end indices */
2038 SCM_DEFINE (scm_string_upcaseS
, "string-upcase", 1, 2, 0,
2039 (SCM str
, SCM start
, SCM end
),
2040 "Upcase every character in @code{str}.")
2041 #define FUNC_NAME s_scm_string_upcaseS
2046 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2049 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2054 /* Helper function for the string lowercase conversion functions.
2055 * No argument checking is performed. */
2057 string_downcase_x (SCM v
, int start
, int end
)
2061 for (k
= start
; k
< end
; ++k
)
2062 SCM_STRING_UCHARS (v
) [k
] = scm_downcase (SCM_STRING_UCHARS (v
) [k
]);
2068 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2069 in the core, which does not accept start/end indices */
2070 SCM_DEFINE (scm_string_downcase_xS
, "string-downcase!", 1, 2, 0,
2071 (SCM str
, SCM start
, SCM end
),
2072 "Destructively downcase every character in @var{str}.\n"
2076 "@result{} \"ARRDEFG\"\n"
2077 "(string-downcase! y)\n"
2078 "@result{} \"arrdefg\"\n"
2080 "@result{} \"arrdefg\"\n"
2082 #define FUNC_NAME s_scm_string_downcase_xS
2087 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2090 return string_downcase_x (str
, cstart
, cend
);
2095 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2096 in the core, which does not accept start/end indices */
2097 SCM_DEFINE (scm_string_downcaseS
, "string-downcase", 1, 2, 0,
2098 (SCM str
, SCM start
, SCM end
),
2099 "Downcase every character in @var{str}.")
2100 #define FUNC_NAME s_scm_string_downcaseS
2105 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2108 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2113 /* Helper function for the string capitalization functions.
2114 * No argument checking is performed. */
2116 string_titlecase_x (SCM str
, int start
, int end
)
2121 sz
= SCM_STRING_CHARS (str
);
2122 for(i
= start
; i
< end
; i
++)
2124 if (!SCM_FALSEP (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2128 sz
[i
] = scm_upcase(sz
[i
]);
2133 sz
[i
] = scm_downcase(sz
[i
]);
2143 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2144 (SCM str
, SCM start
, SCM end
),
2145 "Destructively titlecase every first character in a word in\n"
2147 #define FUNC_NAME s_scm_string_titlecase_x
2152 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2155 return string_titlecase_x (str
, cstart
, cend
);
2160 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2161 (SCM str
, SCM start
, SCM end
),
2162 "Titlecase every first character in a word in @var{str}.")
2163 #define FUNC_NAME s_scm_string_titlecase
2168 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2171 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2176 /* Reverse the portion of @var{str} between str[cstart] (including)
2177 and str[cend] excluding. */
2179 string_reverse_x (char * str
, int cstart
, int cend
)
2184 while (cstart
< cend
)
2187 str
[cstart
] = str
[cend
];
2195 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2196 (SCM str
, SCM start
, SCM end
),
2197 "Reverse the string @var{str}. The optional arguments\n"
2198 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2200 #define FUNC_NAME s_scm_string_reverse
2207 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2210 result
= scm_string_copy (str
);
2211 string_reverse_x (SCM_STRING_CHARS (result
), cstart
, cend
);
2217 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2218 (SCM str
, SCM start
, SCM end
),
2219 "Reverse the string @var{str} in-place. The optional arguments\n"
2220 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2221 "operate on. The return value is unspecified.")
2222 #define FUNC_NAME s_scm_string_reverse_x
2228 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2231 string_reverse_x (SCM_STRING_CHARS (str
), cstart
, cend
);
2232 return SCM_UNSPECIFIED
;
2237 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2239 "Like @code{string-append}, but the result may share memory\n"
2240 "with the argument strings.")
2241 #define FUNC_NAME s_scm_string_append_shared
2245 SCM_VALIDATE_REST_ARGUMENT (ls
);
2247 /* Optimize the one-argument case. */
2248 i
= scm_ilength (ls
);
2250 return SCM_CAR (ls
);
2252 return scm_string_append (ls
);
2257 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2259 "Append the elements of @var{ls} (which must be strings)\n"
2260 "together into a single string. Guaranteed to return a freshly\n"
2261 "allocated string.")
2262 #define FUNC_NAME s_scm_string_concatenate
2264 long strings
= scm_ilength (ls
);
2269 /* Validate the string list. */
2271 SCM_WRONG_TYPE_ARG (1, ls
);
2273 /* Calculate the size of the result string. */
2275 while (!SCM_NULLP (tmp
))
2277 SCM elt
= SCM_CAR (tmp
);
2278 SCM_VALIDATE_STRING (1, elt
);
2279 len
+= SCM_STRING_LENGTH (elt
);
2280 tmp
= SCM_CDR (tmp
);
2282 result
= scm_allocate_string (len
);
2284 /* Copy the list elements into the result. */
2285 p
= SCM_STRING_CHARS (result
);
2287 while (!SCM_NULLP (tmp
))
2289 SCM elt
= SCM_CAR (tmp
);
2290 memmove (p
, SCM_STRING_CHARS (elt
),
2291 SCM_STRING_LENGTH (elt
) * sizeof (char));
2292 p
+= SCM_STRING_LENGTH (elt
);
2293 tmp
= SCM_CDR (tmp
);
2300 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2301 (SCM ls
, SCM final_string
, SCM end
),
2302 "Without optional arguments, this procedure is equivalent to\n"
2305 "(string-concatenate (reverse ls))\n"
2308 "If the optional argument @var{final_string} is specified, it is\n"
2309 "consed onto the beginning to @var{ls} before performing the\n"
2310 "list-reverse and string-concatenate operations. If @var{end}\n"
2311 "is given, only the characters of @var{final_string} up to index\n"
2312 "@var{end} are used.\n"
2314 "Guaranteed to return a freshly allocated string.")
2315 #define FUNC_NAME s_scm_string_concatenate_reverse
2323 /* Check the optional arguments and calculate the additional length
2324 of the result string. */
2325 if (!SCM_UNBNDP (final_string
))
2327 SCM_VALIDATE_STRING (2, final_string
);
2328 if (!SCM_UNBNDP (end
))
2330 SCM_VALIDATE_INUM_COPY (3, end
, cend
);
2331 SCM_ASSERT_RANGE (3, end
,
2333 (cend
<= SCM_STRING_LENGTH (final_string
)));
2337 cend
= SCM_STRING_LENGTH (final_string
);
2341 strings
= scm_ilength (ls
);
2342 /* Validate the string list. */
2344 SCM_WRONG_TYPE_ARG (1, ls
);
2346 /* Calculate the length of the result string. */
2348 while (!SCM_NULLP (tmp
))
2350 SCM elt
= SCM_CAR (tmp
);
2351 SCM_VALIDATE_STRING (1, elt
);
2352 len
+= SCM_STRING_LENGTH (elt
);
2353 tmp
= SCM_CDR (tmp
);
2356 result
= scm_allocate_string (len
);
2358 p
= SCM_STRING_CHARS (result
) + len
;
2360 /* Construct the result string, possibly by using the optional final
2362 if (!SCM_UNBNDP (final_string
))
2365 memmove (p
, SCM_STRING_CHARS (final_string
), cend
* sizeof (char));
2368 while (!SCM_NULLP (tmp
))
2370 SCM elt
= SCM_CAR (tmp
);
2371 p
-= SCM_STRING_LENGTH (elt
);
2372 memmove (p
, SCM_STRING_CHARS (elt
),
2373 SCM_STRING_LENGTH (elt
) * sizeof (char));
2374 tmp
= SCM_CDR (tmp
);
2381 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2383 "Like @code{string-concatenate}, but the result may share memory\n"
2384 "with the strings in the list @var{ls}.")
2385 #define FUNC_NAME s_scm_string_concatenate_shared
2387 /* Optimize the one-string case. */
2388 long i
= scm_ilength (ls
);
2391 SCM_VALIDATE_STRING (1, SCM_CAR (ls
));
2392 return SCM_CAR (ls
);
2394 return scm_string_concatenate (ls
);
2399 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2400 (SCM ls
, SCM final_string
, SCM end
),
2401 "Like @code{string-concatenate-reverse}, but the result may\n"
2402 "share memory with the the strings in the @var{ls} arguments.")
2403 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2405 /* Just call the non-sharing version. */
2406 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2411 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2412 (SCM s
, SCM proc
, SCM start
, SCM end
),
2413 "@var{proc} is a char->char procedure, it is mapped over\n"
2414 "@var{s}. The order in which the procedure is applied to the\n"
2415 "string elements is not specified.")
2416 #define FUNC_NAME s_scm_string_map
2422 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2425 SCM_VALIDATE_PROC (2, proc
);
2426 result
= scm_allocate_string (cend
- cstart
);
2427 p
= SCM_STRING_CHARS (result
);
2428 while (cstart
< cend
)
2430 SCM ch
= scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]),
2432 if (!SCM_CHARP (ch
))
2433 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
2435 *p
++ = SCM_CHAR (ch
);
2442 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2443 (SCM s
, SCM proc
, SCM start
, SCM end
),
2444 "@var{proc} is a char->char procedure, it is mapped over\n"
2445 "@var{s}. The order in which the procedure is applied to the\n"
2446 "string elements is not specified. The string @var{s} is\n"
2447 "modified in-place, the return value is not specified.")
2448 #define FUNC_NAME s_scm_string_map_x
2453 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2456 SCM_VALIDATE_PROC (2, proc
);
2457 p
= SCM_STRING_CHARS (s
) + cstart
;
2458 while (cstart
< cend
)
2460 SCM ch
= scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]),
2462 if (!SCM_CHARP (ch
))
2463 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc
));
2465 *p
++ = SCM_CHAR (ch
);
2467 return SCM_UNSPECIFIED
;
2472 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2473 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2474 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2475 "as the terminating element, from left to right. @var{kons}\n"
2476 "must expect two arguments: The actual character and the last\n"
2477 "result of @var{kons}' application.")
2478 #define FUNC_NAME s_scm_string_fold
2484 SCM_VALIDATE_PROC (1, kons
);
2485 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2489 while (cstart
< cend
)
2491 result
= scm_apply (kons
, SCM_LIST2 (SCM_MAKE_CHAR (cstr
[cstart
]),
2500 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2501 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2502 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2503 "as the terminating element, from right to left. @var{kons}\n"
2504 "must expect two arguments: The actual character and the last\n"
2505 "result of @var{kons}' application.")
2506 #define FUNC_NAME s_scm_string_fold_right
2512 SCM_VALIDATE_PROC (1, kons
);
2513 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2517 while (cstart
< cend
)
2519 result
= scm_apply (kons
, SCM_LIST2 (SCM_MAKE_CHAR (cstr
[cend
- 1]),
2528 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2529 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2530 "@itemize @bullet\n"
2531 "@item @var{g} is used to generate a series of @emph{seed}\n"
2532 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2533 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2535 "@item @var{p} tells us when to stop -- when it returns true\n"
2536 "when applied to one of these seed values.\n"
2537 "@item @var{f} maps each seed value to the corresponding \n"
2538 "character in the result string. These chars are assembled\n"
2539 "into the string in a left-to-right order.\n"
2540 "@item @var{base} is the optional initial/leftmost portion\n"
2541 "of the constructed string; it default to the empty\n"
2543 "@item @var{make_final} is applied to the terminal seed\n"
2544 "value (on which @var{p} returns true) to produce\n"
2545 "the final/rightmost portion of the constructed string.\n"
2546 "It defaults to @code{(lambda (x) "")}.\n"
2548 #define FUNC_NAME s_scm_string_unfold
2552 SCM_VALIDATE_PROC (1, p
);
2553 SCM_VALIDATE_PROC (2, f
);
2554 SCM_VALIDATE_PROC (3, g
);
2555 if (!SCM_UNBNDP (base
))
2557 SCM_VALIDATE_STRING (5, base
);
2561 ans
= scm_allocate_string (0);
2562 if (!SCM_UNBNDP (make_final
))
2563 SCM_VALIDATE_PROC (6, make_final
);
2565 res
= scm_apply (p
, seed
, scm_listofnull
);
2566 while (SCM_FALSEP (res
))
2569 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
2570 if (!SCM_CHARP (ch
))
2571 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
2572 str
= scm_allocate_string (1);
2573 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2575 ans
= scm_string_append (SCM_LIST2 (ans
, str
));
2576 seed
= scm_apply (g
, seed
, scm_listofnull
);
2577 res
= scm_apply (p
, seed
, scm_listofnull
);
2579 if (!SCM_UNBNDP (make_final
))
2581 res
= scm_apply (make_final
, seed
, scm_listofnull
);
2582 return scm_string_append (SCM_LIST2 (ans
, res
));
2590 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2591 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2592 "@itemize @bullet\n"
2593 "@item @var{g} is used to generate a series of @emph{seed}\n"
2594 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2595 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2597 "@item @var{p} tells us when to stop -- when it returns true\n"
2598 "when applied to one of these seed values.\n"
2599 "@item @var{f} maps each seed value to the corresponding \n"
2600 "character in the result string. These chars are assembled\n"
2601 "into the string in a right-to-left order.\n"
2602 "@item @var{base} is the optional initial/rightmost portion\n"
2603 "of the constructed string; it default to the empty\n"
2605 "@item @var{make_final} is applied to the terminal seed\n"
2606 "value (on which @var{p} returns true) to produce\n"
2607 "the final/leftmost portion of the constructed string.\n"
2608 "It defaults to @code{(lambda (x) "")}.\n"
2610 #define FUNC_NAME s_scm_string_unfold_right
2614 SCM_VALIDATE_PROC (1, p
);
2615 SCM_VALIDATE_PROC (2, f
);
2616 SCM_VALIDATE_PROC (3, g
);
2617 if (!SCM_UNBNDP (base
))
2619 SCM_VALIDATE_STRING (5, base
);
2623 ans
= scm_allocate_string (0);
2624 if (!SCM_UNBNDP (make_final
))
2625 SCM_VALIDATE_PROC (6, make_final
);
2627 res
= scm_apply (p
, seed
, scm_listofnull
);
2628 while (SCM_FALSEP (res
))
2631 SCM ch
= scm_apply (f
, seed
, scm_listofnull
);
2632 if (!SCM_CHARP (ch
))
2633 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f
));
2634 str
= scm_allocate_string (1);
2635 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2637 ans
= scm_string_append (SCM_LIST2 (str
, ans
));
2638 seed
= scm_apply (g
, seed
, scm_listofnull
);
2639 res
= scm_apply (p
, seed
, scm_listofnull
);
2641 if (!SCM_UNBNDP (make_final
))
2643 res
= scm_apply (make_final
, seed
, scm_listofnull
);
2644 return scm_string_append (SCM_LIST2 (res
, ans
));
2652 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2653 (SCM s
, SCM proc
, SCM start
, SCM end
),
2654 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2655 "return value is not specified.")
2656 #define FUNC_NAME s_scm_string_for_each
2661 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2664 SCM_VALIDATE_PROC (2, proc
);
2665 while (cstart
< cend
)
2667 scm_apply (proc
, SCM_MAKE_CHAR (cstr
[cstart
]), scm_listofnull
);
2670 return SCM_UNSPECIFIED
;
2674 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2675 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2676 "This is the @emph{extended substring} procedure that implements\n"
2677 "replicated copying of a substring of some string.\n"
2679 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2680 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2681 "0 and the length of @var{s}. Replicate this substring up and\n"
2682 "down index space, in both the positive and negative directions.\n"
2683 "@code{xsubstring} returns the substring of this string\n"
2684 "beginning at index @var{from}, and ending at @var{to}, which\n"
2685 "defaults to @var{from} + (@var{end} - @var{start}).")
2686 #define FUNC_NAME s_scm_xsubstring
2689 int cstart
, cend
, cfrom
, cto
;
2692 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2695 SCM_VALIDATE_INUM_COPY (2, from
, cfrom
);
2696 SCM_VALIDATE_INUM_DEF_COPY (3, to
, cfrom
+ (cend
- cstart
), cto
);
2697 if (cstart
== cend
&& cfrom
!= cto
)
2698 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2700 result
= scm_allocate_string (cto
- cfrom
);
2702 p
= SCM_STRING_CHARS (result
);
2705 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2707 *p
= cs
[(cend
- cstart
) - t
];
2718 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2719 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2720 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2721 "is written into the string @var{target} starting at index\n"
2722 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2723 "@var{target} @var{s})} or these arguments share storage -- you\n"
2724 "cannot copy a string on top of itself.")
2725 #define FUNC_NAME s_scm_string_xcopy_x
2727 char * ctarget
, * cs
, * p
;
2728 int ctstart
, csfrom
, csto
, cstart
, cend
;
2729 SCM dummy
= SCM_UNDEFINED
;
2732 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
2735 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
2738 SCM_VALIDATE_INUM_COPY (4, sfrom
, csfrom
);
2739 SCM_VALIDATE_INUM_DEF_COPY (5, sto
, csfrom
+ (cend
- cstart
), csto
);
2740 if (cstart
== cend
&& csfrom
!= csto
)
2741 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2742 SCM_ASSERT_RANGE (1, tstart
,
2743 ctstart
+ (csto
- csfrom
) <= SCM_STRING_LENGTH (target
));
2745 p
= ctarget
+ ctstart
;
2746 while (csfrom
< csto
)
2748 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2750 *p
= cs
[(cend
- cstart
) - t
];
2756 return SCM_UNSPECIFIED
;
2761 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2762 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2763 "Return the string @var{s1}, but with the characters\n"
2764 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2765 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2766 #define FUNC_NAME s_scm_string_replace
2768 char * cstr1
, * cstr2
, * p
;
2769 int cstart1
, cend1
, cstart2
, cend2
;
2772 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
2775 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
2778 result
= scm_allocate_string (cstart1
+ (cend2
- cstart2
) +
2779 SCM_STRING_LENGTH (s1
) - cend1
);
2780 p
= SCM_STRING_CHARS (result
);
2781 memmove (p
, cstr1
, cstart1
* sizeof (char));
2782 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
2783 memmove (p
+ cstart1
+ (cend2
- cstart2
),
2785 (SCM_STRING_LENGTH (s1
) - cend1
) * sizeof (char));
2791 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2792 (SCM s
, SCM token_char
, SCM start
, SCM end
),
2793 "Split the string @var{s} into a list of substrings, where each\n"
2794 "substring is a maximal non-empty contiguous sequence of\n"
2795 "characters equal to the character @var{token_char}, or\n"
2796 "whitespace, if @var{token_char} is not given. If\n"
2797 "@var{token_char} is a character set, it is used for finding the\n"
2799 #define FUNC_NAME s_scm_string_tokenize
2803 SCM result
= SCM_EOL
;
2805 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2808 if (SCM_UNBNDP (token_char
))
2812 while (cstart
< cend
)
2814 while (cstart
< cend
)
2816 if (!isspace (cstr
[cend
- 1]))
2823 while (cstart
< cend
)
2825 if (isspace (cstr
[cend
- 1]))
2829 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
2832 else if (SCM_CHARSETP (token_char
))
2836 while (cstart
< cend
)
2838 while (cstart
< cend
)
2840 if (!SCM_CHARSET_GET (token_char
, cstr
[cend
- 1]))
2847 while (cstart
< cend
)
2849 if (SCM_CHARSET_GET (token_char
, cstr
[cend
- 1]))
2853 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
2861 SCM_VALIDATE_CHAR (2, token_char
);
2862 chr
= SCM_CHAR (token_char
);
2864 while (cstart
< cend
)
2866 while (cstart
< cend
)
2868 if (cstr
[cend
- 1] != chr
)
2875 while (cstart
< cend
)
2877 if (cstr
[cend
- 1] == chr
)
2881 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
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
);
3024 scm_init_srfi_13 (void)
3026 scm_c_init_srfi_14 ();
3027 #ifndef SCM_MAGIC_SNARFER
3028 #include "srfi/srfi-13.x"