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_call_1 (pred
, SCM_MAKE_CHAR (*cstr
));
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_call_1 (pred
, SCM_MAKE_CHAR (*cstr
));
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_call_1 (proc
, SCM_MAKINUM (i
));
142 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (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_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
654 if (SCM_FALSEP (res
))
659 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
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_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
729 if (SCM_FALSEP (res
))
734 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
739 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
740 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
741 "Trim @var{s} by skipping over all characters on both sides of\n"
742 "the string that satisfy the parameter @var{char_pred}:\n"
746 "if it is the character @var{ch}, characters equal to @var{ch}\n"
750 "if it is a procedure @var{pred} characters that satisfy\n"
751 "@var{pred} are trimmed,\n"
754 "if it is a character set, the characters in the set are\n"
758 "If called without a @var{char_pred} argument, all whitespace is\n"
760 #define FUNC_NAME s_scm_string_trim_both
765 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
768 if (SCM_UNBNDP (char_pred
))
770 while (cstart
< cend
)
772 if (!isspace(cstr
[cstart
]))
776 while (cstart
< cend
)
778 if (!isspace(cstr
[cend
- 1]))
783 else if (SCM_CHARP (char_pred
))
785 char chr
= SCM_CHAR (char_pred
);
786 while (cstart
< cend
)
788 if (chr
!= cstr
[cstart
])
792 while (cstart
< cend
)
794 if (chr
!= cstr
[cend
- 1])
799 else if (SCM_CHARSETP (char_pred
))
801 while (cstart
< cend
)
803 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
807 while (cstart
< cend
)
809 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
816 SCM_VALIDATE_PROC (2, char_pred
);
817 while (cstart
< cend
)
821 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
822 if (SCM_FALSEP (res
))
826 while (cstart
< cend
)
830 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
831 if (SCM_FALSEP (res
))
836 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
841 SCM_DEFINE (scm_string_fill_xS
, "string-fill!", 2, 2, 0,
842 (SCM str
, SCM chr
, SCM start
, SCM end
),
843 "Stores @var{chr} in every element of the given @var{str} and\n"
844 "returns an unspecified value.")
845 #define FUNC_NAME s_scm_string_fill_xS
852 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
855 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
856 for (k
= cstart
; k
< cend
; k
++)
858 return SCM_UNSPECIFIED
;
863 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
864 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
865 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
866 "mismatch index, depending upon whether @var{s1} is less than,\n"
867 "equal to, or greater than @var{s2}. The mismatch index is the\n"
868 "largest index @var{i} such that for every 0 <= @var{j} <\n"
869 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
870 "@var{i} is the first position that does not match.")
871 #define FUNC_NAME s_scm_string_compare
873 char * cstr1
, * cstr2
;
874 int cstart1
, cend1
, cstart2
, cend2
;
876 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
879 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
882 SCM_VALIDATE_PROC (3, proc_lt
);
883 SCM_VALIDATE_PROC (4, proc_eq
);
884 SCM_VALIDATE_PROC (5, proc_gt
);
886 while (cstart1
< cend1
&& cstart2
< cend2
)
888 if (cstr1
[cstart1
] < cstr2
[cstart2
])
889 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
890 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
891 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
896 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
897 else if (cstart2
< cend2
)
898 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
900 return scm_call_1 (proc_eq
, SCM_MAKINUM (cstart1
));
905 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
906 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
907 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
908 "mismatch index, depending upon whether @var{s1} is less than,\n"
909 "equal to, or greater than @var{s2}. The mismatch index is the\n"
910 "largest index @var{i} such that for every 0 <= @var{j} <\n"
911 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
912 "@var{i} is the first position that does not match. The\n"
913 "character comparison is done case-insensitively.")
914 #define FUNC_NAME s_scm_string_compare_ci
916 char * cstr1
, * cstr2
;
917 int cstart1
, cend1
, cstart2
, cend2
;
919 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
922 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
925 SCM_VALIDATE_PROC (3, proc_lt
);
926 SCM_VALIDATE_PROC (4, proc_eq
);
927 SCM_VALIDATE_PROC (5, proc_gt
);
929 while (cstart1
< cend1
&& cstart2
< cend2
)
931 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
932 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
933 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
934 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
939 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
940 else if (cstart2
< cend2
)
941 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
943 return scm_call_1 (proc_eq
, SCM_MAKINUM (cstart1
));
948 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
949 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
950 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
952 #define FUNC_NAME s_scm_string_eq
954 char * cstr1
, * cstr2
;
955 int cstart1
, cend1
, cstart2
, cend2
;
957 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
960 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
964 while (cstart1
< cend1
&& cstart2
< cend2
)
966 if (cstr1
[cstart1
] < cstr2
[cstart2
])
968 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
975 else if (cstart2
< cend2
)
978 return SCM_MAKINUM (cstart1
);
983 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
984 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
985 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
987 #define FUNC_NAME s_scm_string_neq
989 char * cstr1
, * cstr2
;
990 int cstart1
, cend1
, cstart2
, cend2
;
992 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
995 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
999 while (cstart1
< cend1
&& cstart2
< cend2
)
1001 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1002 return SCM_MAKINUM (cstart1
);
1003 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1004 return SCM_MAKINUM (cstart1
);
1008 if (cstart1
< cend1
)
1009 return SCM_MAKINUM (cstart1
);
1010 else if (cstart2
< cend2
)
1011 return SCM_MAKINUM (cstart1
);
1018 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
1019 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1020 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1021 "true value otherwise.")
1022 #define FUNC_NAME s_scm_string_lt
1024 char * cstr1
, * cstr2
;
1025 int cstart1
, cend1
, cstart2
, cend2
;
1027 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1030 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1034 while (cstart1
< cend1
&& cstart2
< cend2
)
1036 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1037 return SCM_MAKINUM (cstart1
);
1038 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1043 if (cstart1
< cend1
)
1045 else if (cstart2
< cend2
)
1046 return SCM_MAKINUM (cstart1
);
1053 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1054 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1055 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1056 "true value otherwise.")
1057 #define FUNC_NAME s_scm_string_gt
1059 char * cstr1
, * cstr2
;
1060 int cstart1
, cend1
, cstart2
, cend2
;
1062 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1065 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1069 while (cstart1
< cend1
&& cstart2
< cend2
)
1071 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1073 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1074 return SCM_MAKINUM (cstart1
);
1078 if (cstart1
< cend1
)
1079 return SCM_MAKINUM (cstart1
);
1080 else if (cstart2
< cend2
)
1088 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1089 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1090 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1092 #define FUNC_NAME s_scm_string_le
1094 char * cstr1
, * cstr2
;
1095 int cstart1
, cend1
, cstart2
, cend2
;
1097 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1100 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1104 while (cstart1
< cend1
&& cstart2
< cend2
)
1106 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1107 return SCM_MAKINUM (cstart1
);
1108 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1113 if (cstart1
< cend1
)
1115 else if (cstart2
< cend2
)
1116 return SCM_MAKINUM (cstart1
);
1118 return SCM_MAKINUM (cstart1
);
1123 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1124 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1125 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1127 #define FUNC_NAME s_scm_string_ge
1129 char * cstr1
, * cstr2
;
1130 int cstart1
, cend1
, cstart2
, cend2
;
1132 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1135 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1139 while (cstart1
< cend1
&& cstart2
< cend2
)
1141 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1143 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1144 return SCM_MAKINUM (cstart1
);
1148 if (cstart1
< cend1
)
1149 return SCM_MAKINUM (cstart1
);
1150 else if (cstart2
< cend2
)
1153 return SCM_MAKINUM (cstart1
);
1158 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1159 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1160 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1161 "value otherwise. The character comparison is done\n"
1162 "case-insensitively.")
1163 #define FUNC_NAME s_scm_string_ci_eq
1165 char * cstr1
, * cstr2
;
1166 int cstart1
, cend1
, cstart2
, cend2
;
1168 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1171 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1175 while (cstart1
< cend1
&& cstart2
< cend2
)
1177 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1179 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1184 if (cstart1
< cend1
)
1186 else if (cstart2
< cend2
)
1189 return SCM_MAKINUM (cstart1
);
1194 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1195 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1196 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1197 "value otherwise. The character comparison is done\n"
1198 "case-insensitively.")
1199 #define FUNC_NAME s_scm_string_ci_neq
1201 char * cstr1
, * cstr2
;
1202 int cstart1
, cend1
, cstart2
, cend2
;
1204 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1207 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1211 while (cstart1
< cend1
&& cstart2
< cend2
)
1213 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1214 return SCM_MAKINUM (cstart1
);
1215 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1216 return SCM_MAKINUM (cstart1
);
1220 if (cstart1
< cend1
)
1221 return SCM_MAKINUM (cstart1
);
1222 else if (cstart2
< cend2
)
1223 return SCM_MAKINUM (cstart1
);
1230 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1231 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1232 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1233 "true value otherwise. The character comparison is done\n"
1234 "case-insensitively.")
1235 #define FUNC_NAME s_scm_string_ci_lt
1237 char * cstr1
, * cstr2
;
1238 int cstart1
, cend1
, cstart2
, cend2
;
1240 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1243 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1247 while (cstart1
< cend1
&& cstart2
< cend2
)
1249 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1250 return SCM_MAKINUM (cstart1
);
1251 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1256 if (cstart1
< cend1
)
1258 else if (cstart2
< cend2
)
1259 return SCM_MAKINUM (cstart1
);
1266 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1267 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1268 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1269 "true value otherwise. The character comparison is done\n"
1270 "case-insensitively.")
1271 #define FUNC_NAME s_scm_string_ci_gt
1273 char * cstr1
, * cstr2
;
1274 int cstart1
, cend1
, cstart2
, cend2
;
1276 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1279 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1283 while (cstart1
< cend1
&& cstart2
< cend2
)
1285 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1287 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1288 return SCM_MAKINUM (cstart1
);
1292 if (cstart1
< cend1
)
1293 return SCM_MAKINUM (cstart1
);
1294 else if (cstart2
< cend2
)
1302 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1303 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1304 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1305 "value otherwise. The character comparison is done\n"
1306 "case-insensitively.")
1307 #define FUNC_NAME s_scm_string_ci_le
1309 char * cstr1
, * cstr2
;
1310 int cstart1
, cend1
, cstart2
, cend2
;
1312 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1315 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1319 while (cstart1
< cend1
&& cstart2
< cend2
)
1321 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1322 return SCM_MAKINUM (cstart1
);
1323 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1328 if (cstart1
< cend1
)
1330 else if (cstart2
< cend2
)
1331 return SCM_MAKINUM (cstart1
);
1333 return SCM_MAKINUM (cstart1
);
1338 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1339 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1340 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1341 "otherwise. The character comparison is done\n"
1342 "case-insensitively.")
1343 #define FUNC_NAME s_scm_string_ci_ge
1345 char * cstr1
, * cstr2
;
1346 int cstart1
, cend1
, cstart2
, cend2
;
1348 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1351 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1355 while (cstart1
< cend1
&& cstart2
< cend2
)
1357 if (scm_downcase (cstr1
[cstart1
]) < scm_downcase (cstr2
[cstart2
]))
1359 else if (scm_downcase (cstr1
[cstart1
]) > scm_downcase (cstr2
[cstart2
]))
1360 return SCM_MAKINUM (cstart1
);
1364 if (cstart1
< cend1
)
1365 return SCM_MAKINUM (cstart1
);
1366 else if (cstart2
< cend2
)
1369 return SCM_MAKINUM (cstart1
);
1374 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1375 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1376 "Return the length of the longest common prefix of the two\n"
1378 #define FUNC_NAME s_scm_string_prefix_length
1380 char * cstr1
, * cstr2
;
1381 int cstart1
, cend1
, cstart2
, cend2
;
1384 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1387 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1390 while (cstart1
< cend1
&& cstart2
< cend2
)
1392 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1393 return SCM_MAKINUM (len
);
1398 return SCM_MAKINUM (len
);
1403 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1404 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1405 "Return the length of the longest common prefix of the two\n"
1406 "strings, ignoring character case.")
1407 #define FUNC_NAME s_scm_string_prefix_length_ci
1409 char * cstr1
, * cstr2
;
1410 int cstart1
, cend1
, cstart2
, cend2
;
1413 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1416 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1419 while (cstart1
< cend1
&& cstart2
< cend2
)
1421 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1422 return SCM_MAKINUM (len
);
1427 return SCM_MAKINUM (len
);
1432 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1433 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1434 "Return the length of the longest common suffix of the two\n"
1436 #define FUNC_NAME s_scm_string_suffix_length
1438 char * cstr1
, * cstr2
;
1439 int cstart1
, cend1
, cstart2
, cend2
;
1442 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1445 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1448 while (cstart1
< cend1
&& cstart2
< cend2
)
1452 if (cstr1
[cend1
] != cstr2
[cend2
])
1453 return SCM_MAKINUM (len
);
1456 return SCM_MAKINUM (len
);
1461 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1462 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1463 "Return the length of the longest common suffix of the two\n"
1464 "strings, ignoring character case.")
1465 #define FUNC_NAME s_scm_string_suffix_length_ci
1467 char * cstr1
, * cstr2
;
1468 int cstart1
, cend1
, cstart2
, cend2
;
1471 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1474 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1477 while (cstart1
< cend1
&& cstart2
< cend2
)
1481 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1482 return SCM_MAKINUM (len
);
1485 return SCM_MAKINUM (len
);
1490 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1491 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1492 "Is @var{s1} a prefix of @var{s2}?")
1493 #define FUNC_NAME s_scm_string_prefix_p
1495 char * cstr1
, * cstr2
;
1496 int cstart1
, cend1
, cstart2
, cend2
;
1499 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1502 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1505 len1
= cend1
- cstart1
;
1506 while (cstart1
< cend1
&& cstart2
< cend2
)
1508 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1509 return SCM_BOOL (len
== len1
);
1514 return SCM_BOOL (len
== len1
);
1519 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1520 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1521 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1522 #define FUNC_NAME s_scm_string_prefix_ci_p
1524 char * cstr1
, * cstr2
;
1525 int cstart1
, cend1
, cstart2
, cend2
;
1528 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1531 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1534 len1
= cend1
- cstart1
;
1535 while (cstart1
< cend1
&& cstart2
< cend2
)
1537 if (scm_downcase (cstr1
[cstart1
]) != scm_downcase (cstr2
[cstart2
]))
1538 return SCM_BOOL (len
== len1
);
1543 return SCM_BOOL (len
== len1
);
1548 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1549 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1550 "Is @var{s1} a suffix of @var{s2}?")
1551 #define FUNC_NAME s_scm_string_suffix_p
1553 char * cstr1
, * cstr2
;
1554 int cstart1
, cend1
, cstart2
, cend2
;
1557 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1560 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1563 len1
= cend1
- cstart1
;
1564 while (cstart1
< cend1
&& cstart2
< cend2
)
1568 if (cstr1
[cend1
] != cstr2
[cend2
])
1569 return SCM_BOOL (len
== len1
);
1572 return SCM_BOOL (len
== len1
);
1577 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1578 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1579 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1580 #define FUNC_NAME s_scm_string_suffix_ci_p
1582 char * cstr1
, * cstr2
;
1583 int cstart1
, cend1
, cstart2
, cend2
;
1586 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1589 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1592 len1
= cend1
- cstart1
;
1593 while (cstart1
< cend1
&& cstart2
< cend2
)
1597 if (scm_downcase (cstr1
[cend1
]) != scm_downcase (cstr2
[cend2
]))
1598 return SCM_BOOL (len
== len1
);
1601 return SCM_BOOL (len
== len1
);
1606 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1607 in the core, which does not accept a predicate. */
1608 SCM_DEFINE (scm_string_indexS
, "string-index", 2, 2, 0,
1609 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1610 "Search through the string @var{s} from left to right, returning\n"
1611 "the index of the first occurence of a character which\n"
1613 "@itemize @bullet\n"
1615 "equals @var{char_pred}, if it is character,\n"
1618 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1621 "is in the set @var{char_pred}, if it is a character set.\n"
1623 #define FUNC_NAME s_scm_string_indexS
1628 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1631 if (SCM_CHARP (char_pred
))
1633 char cchr
= SCM_CHAR (char_pred
);
1634 while (cstart
< cend
)
1636 if (cchr
== cstr
[cstart
])
1637 return SCM_MAKINUM (cstart
);
1641 else if (SCM_CHARSETP (char_pred
))
1643 while (cstart
< cend
)
1645 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1646 return SCM_MAKINUM (cstart
);
1652 SCM_VALIDATE_PROC (2, char_pred
);
1653 while (cstart
< cend
)
1656 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1657 if (!SCM_FALSEP (res
))
1658 return SCM_MAKINUM (cstart
);
1667 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1668 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1669 "Search through the string @var{s} from right to left, returning\n"
1670 "the index of the last occurence of a character which\n"
1672 "@itemize @bullet\n"
1674 "equals @var{char_pred}, if it is character,\n"
1677 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1680 "is in the set if @var{char_pred} is a character set.\n"
1682 #define FUNC_NAME s_scm_string_index_right
1687 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1690 if (SCM_CHARP (char_pred
))
1692 char cchr
= SCM_CHAR (char_pred
);
1693 while (cstart
< cend
)
1696 if (cchr
== cstr
[cend
])
1697 return SCM_MAKINUM (cend
);
1700 else if (SCM_CHARSETP (char_pred
))
1702 while (cstart
< cend
)
1705 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1706 return SCM_MAKINUM (cend
);
1711 SCM_VALIDATE_PROC (2, char_pred
);
1712 while (cstart
< cend
)
1716 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1717 if (!SCM_FALSEP (res
))
1718 return SCM_MAKINUM (cend
);
1726 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1727 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1728 "Search through the string @var{s} from left to right, returning\n"
1729 "the index of the first occurence of a character which\n"
1731 "@itemize @bullet\n"
1733 "does not equal @var{char_pred}, if it is character,\n"
1736 "does not satisify the predicate @var{char_pred}, if it is a\n"
1740 "is not in the set if @var{char_pred} is a character set.\n"
1742 #define FUNC_NAME s_scm_string_skip
1747 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1750 if (SCM_CHARP (char_pred
))
1752 char cchr
= SCM_CHAR (char_pred
);
1753 while (cstart
< cend
)
1755 if (cchr
!= cstr
[cstart
])
1756 return SCM_MAKINUM (cstart
);
1760 else if (SCM_CHARSETP (char_pred
))
1762 while (cstart
< cend
)
1764 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1765 return SCM_MAKINUM (cstart
);
1771 SCM_VALIDATE_PROC (2, char_pred
);
1772 while (cstart
< cend
)
1775 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1776 if (SCM_FALSEP (res
))
1777 return SCM_MAKINUM (cstart
);
1786 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1787 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1788 "Search through the string @var{s} from right to left, returning\n"
1789 "the index of the last occurence of a character which\n"
1791 "@itemize @bullet\n"
1793 "does not equal @var{char_pred}, if it is character,\n"
1796 "does not satisifie the predicate @var{char_pred}, if it is a\n"
1800 "is not in the set if @var{char_pred} is a character set.\n"
1802 #define FUNC_NAME s_scm_string_skip_right
1807 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1810 if (SCM_CHARP (char_pred
))
1812 char cchr
= SCM_CHAR (char_pred
);
1813 while (cstart
< cend
)
1816 if (cchr
!= cstr
[cend
])
1817 return SCM_MAKINUM (cend
);
1820 else if (SCM_CHARSETP (char_pred
))
1822 while (cstart
< cend
)
1825 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1826 return SCM_MAKINUM (cend
);
1831 SCM_VALIDATE_PROC (2, char_pred
);
1832 while (cstart
< cend
)
1836 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1837 if (SCM_FALSEP (res
))
1838 return SCM_MAKINUM (cend
);
1846 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1847 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1848 "Return the count of the number of characters in the string\n"
1851 "@itemize @bullet\n"
1853 "equals @var{char_pred}, if it is character,\n"
1856 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1859 "is in the set @var{char_pred}, if it is a character set.\n"
1861 #define FUNC_NAME s_scm_string_count
1867 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1870 if (SCM_CHARP (char_pred
))
1872 char cchr
= SCM_CHAR (char_pred
);
1873 while (cstart
< cend
)
1875 if (cchr
== cstr
[cstart
])
1880 else if (SCM_CHARSETP (char_pred
))
1882 while (cstart
< cend
)
1884 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1891 SCM_VALIDATE_PROC (2, char_pred
);
1892 while (cstart
< cend
)
1895 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1896 if (!SCM_FALSEP (res
))
1901 return SCM_MAKINUM (count
);
1906 /* FIXME::martin: This should definitely get implemented more
1907 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1909 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1910 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1911 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1912 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1913 "The optional start/end indices restrict the operation to the\n"
1914 "indicated substrings.")
1915 #define FUNC_NAME s_scm_string_contains
1918 int cstart1
, cend1
, cstart2
, cend2
;
1921 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1924 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1927 len2
= cend2
- cstart2
;
1928 while (cstart1
<= cend1
- len2
)
1932 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
1938 return SCM_MAKINUM (cstart1
);
1946 /* FIXME::martin: This should definitely get implemented more
1947 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1949 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
1950 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1951 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1952 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1953 "The optional start/end indices restrict the operation to the\n"
1954 "indicated substrings. Character comparison is done\n"
1955 "case-insensitively.")
1956 #define FUNC_NAME s_scm_string_contains_ci
1959 int cstart1
, cend1
, cstart2
, cend2
;
1962 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1965 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1968 len2
= cend2
- cstart2
;
1969 while (cstart1
<= cend1
- len2
)
1973 while (i
< cend1
&& j
< cend2
&&
1974 scm_downcase (cs1
[i
]) == scm_downcase (cs2
[j
]))
1980 return SCM_MAKINUM (cstart1
);
1988 /* Helper function for the string uppercase conversion functions.
1989 * No argument checking is performed. */
1991 string_upcase_x (SCM v
, int start
, int end
)
1995 for (k
= start
; k
< end
; ++k
)
1996 SCM_STRING_UCHARS (v
) [k
] = scm_upcase (SCM_STRING_UCHARS (v
) [k
]);
2002 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2003 in the core, which does not accept start/end indices */
2004 SCM_DEFINE (scm_string_upcase_xS
, "string-upcase!", 1, 2, 0,
2005 (SCM str
, SCM start
, SCM end
),
2006 "Destructively upcase every character in @code{str}.\n"
2009 "(string-upcase! y)\n"
2010 "@result{} \"ARRDEFG\"\n"
2012 "@result{} \"ARRDEFG\"\n"
2014 #define FUNC_NAME s_scm_string_upcase_xS
2019 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2022 return string_upcase_x (str
, cstart
, cend
);
2027 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2028 in the core, which does not accept start/end indices */
2029 SCM_DEFINE (scm_string_upcaseS
, "string-upcase", 1, 2, 0,
2030 (SCM str
, SCM start
, SCM end
),
2031 "Upcase every character in @code{str}.")
2032 #define FUNC_NAME s_scm_string_upcaseS
2037 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2040 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2045 /* Helper function for the string lowercase conversion functions.
2046 * No argument checking is performed. */
2048 string_downcase_x (SCM v
, int start
, int end
)
2052 for (k
= start
; k
< end
; ++k
)
2053 SCM_STRING_UCHARS (v
) [k
] = scm_downcase (SCM_STRING_UCHARS (v
) [k
]);
2059 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2060 in the core, which does not accept start/end indices */
2061 SCM_DEFINE (scm_string_downcase_xS
, "string-downcase!", 1, 2, 0,
2062 (SCM str
, SCM start
, SCM end
),
2063 "Destructively downcase every character in @var{str}.\n"
2067 "@result{} \"ARRDEFG\"\n"
2068 "(string-downcase! y)\n"
2069 "@result{} \"arrdefg\"\n"
2071 "@result{} \"arrdefg\"\n"
2073 #define FUNC_NAME s_scm_string_downcase_xS
2078 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2081 return string_downcase_x (str
, cstart
, cend
);
2086 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2087 in the core, which does not accept start/end indices */
2088 SCM_DEFINE (scm_string_downcaseS
, "string-downcase", 1, 2, 0,
2089 (SCM str
, SCM start
, SCM end
),
2090 "Downcase every character in @var{str}.")
2091 #define FUNC_NAME s_scm_string_downcaseS
2096 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2099 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2104 /* Helper function for the string capitalization functions.
2105 * No argument checking is performed. */
2107 string_titlecase_x (SCM str
, int start
, int end
)
2112 sz
= SCM_STRING_UCHARS (str
);
2113 for(i
= start
; i
< end
; i
++)
2115 if (!SCM_FALSEP (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2119 sz
[i
] = scm_upcase(sz
[i
]);
2124 sz
[i
] = scm_downcase(sz
[i
]);
2134 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2135 (SCM str
, SCM start
, SCM end
),
2136 "Destructively titlecase every first character in a word in\n"
2138 #define FUNC_NAME s_scm_string_titlecase_x
2143 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2146 return string_titlecase_x (str
, cstart
, cend
);
2151 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2152 (SCM str
, SCM start
, SCM end
),
2153 "Titlecase every first character in a word in @var{str}.")
2154 #define FUNC_NAME s_scm_string_titlecase
2159 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2162 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2167 /* Reverse the portion of @var{str} between str[cstart] (including)
2168 and str[cend] excluding. */
2170 string_reverse_x (char * str
, int cstart
, int cend
)
2175 while (cstart
< cend
)
2178 str
[cstart
] = str
[cend
];
2186 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2187 (SCM str
, SCM start
, SCM end
),
2188 "Reverse the string @var{str}. The optional arguments\n"
2189 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2191 #define FUNC_NAME s_scm_string_reverse
2198 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2201 result
= scm_string_copy (str
);
2202 string_reverse_x (SCM_STRING_CHARS (result
), cstart
, cend
);
2208 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2209 (SCM str
, SCM start
, SCM end
),
2210 "Reverse the string @var{str} in-place. The optional arguments\n"
2211 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2212 "operate on. The return value is unspecified.")
2213 #define FUNC_NAME s_scm_string_reverse_x
2219 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2222 string_reverse_x (SCM_STRING_CHARS (str
), cstart
, cend
);
2223 return SCM_UNSPECIFIED
;
2228 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2230 "Like @code{string-append}, but the result may share memory\n"
2231 "with the argument strings.")
2232 #define FUNC_NAME s_scm_string_append_shared
2236 SCM_VALIDATE_REST_ARGUMENT (ls
);
2238 /* Optimize the one-argument case. */
2239 i
= scm_ilength (ls
);
2241 return SCM_CAR (ls
);
2243 return scm_string_append (ls
);
2248 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2250 "Append the elements of @var{ls} (which must be strings)\n"
2251 "together into a single string. Guaranteed to return a freshly\n"
2252 "allocated string.")
2253 #define FUNC_NAME s_scm_string_concatenate
2255 long strings
= scm_ilength (ls
);
2260 /* Validate the string list. */
2262 SCM_WRONG_TYPE_ARG (1, ls
);
2264 /* Calculate the size of the result string. */
2266 while (!SCM_NULLP (tmp
))
2268 SCM elt
= SCM_CAR (tmp
);
2269 SCM_VALIDATE_STRING (1, elt
);
2270 len
+= SCM_STRING_LENGTH (elt
);
2271 tmp
= SCM_CDR (tmp
);
2273 result
= scm_allocate_string (len
);
2275 /* Copy the list elements into the result. */
2276 p
= SCM_STRING_CHARS (result
);
2278 while (!SCM_NULLP (tmp
))
2280 SCM elt
= SCM_CAR (tmp
);
2281 memmove (p
, SCM_STRING_CHARS (elt
),
2282 SCM_STRING_LENGTH (elt
) * sizeof (char));
2283 p
+= SCM_STRING_LENGTH (elt
);
2284 tmp
= SCM_CDR (tmp
);
2291 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2292 (SCM ls
, SCM final_string
, SCM end
),
2293 "Without optional arguments, this procedure is equivalent to\n"
2296 "(string-concatenate (reverse ls))\n"
2299 "If the optional argument @var{final_string} is specified, it is\n"
2300 "consed onto the beginning to @var{ls} before performing the\n"
2301 "list-reverse and string-concatenate operations. If @var{end}\n"
2302 "is given, only the characters of @var{final_string} up to index\n"
2303 "@var{end} are used.\n"
2305 "Guaranteed to return a freshly allocated string.")
2306 #define FUNC_NAME s_scm_string_concatenate_reverse
2314 /* Check the optional arguments and calculate the additional length
2315 of the result string. */
2316 if (!SCM_UNBNDP (final_string
))
2318 SCM_VALIDATE_STRING (2, final_string
);
2319 if (!SCM_UNBNDP (end
))
2321 SCM_VALIDATE_INUM_COPY (3, end
, cend
);
2322 SCM_ASSERT_RANGE (3, end
,
2324 (cend
<= SCM_STRING_LENGTH (final_string
)));
2328 cend
= SCM_STRING_LENGTH (final_string
);
2332 strings
= scm_ilength (ls
);
2333 /* Validate the string list. */
2335 SCM_WRONG_TYPE_ARG (1, ls
);
2337 /* Calculate the length of the result string. */
2339 while (!SCM_NULLP (tmp
))
2341 SCM elt
= SCM_CAR (tmp
);
2342 SCM_VALIDATE_STRING (1, elt
);
2343 len
+= SCM_STRING_LENGTH (elt
);
2344 tmp
= SCM_CDR (tmp
);
2347 result
= scm_allocate_string (len
);
2349 p
= SCM_STRING_CHARS (result
) + len
;
2351 /* Construct the result string, possibly by using the optional final
2353 if (!SCM_UNBNDP (final_string
))
2356 memmove (p
, SCM_STRING_CHARS (final_string
), cend
* sizeof (char));
2359 while (!SCM_NULLP (tmp
))
2361 SCM elt
= SCM_CAR (tmp
);
2362 p
-= SCM_STRING_LENGTH (elt
);
2363 memmove (p
, SCM_STRING_CHARS (elt
),
2364 SCM_STRING_LENGTH (elt
) * sizeof (char));
2365 tmp
= SCM_CDR (tmp
);
2372 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2374 "Like @code{string-concatenate}, but the result may share memory\n"
2375 "with the strings in the list @var{ls}.")
2376 #define FUNC_NAME s_scm_string_concatenate_shared
2378 /* Optimize the one-string case. */
2379 long i
= scm_ilength (ls
);
2382 SCM_VALIDATE_STRING (1, SCM_CAR (ls
));
2383 return SCM_CAR (ls
);
2385 return scm_string_concatenate (ls
);
2390 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2391 (SCM ls
, SCM final_string
, SCM end
),
2392 "Like @code{string-concatenate-reverse}, but the result may\n"
2393 "share memory with the the strings in the @var{ls} arguments.")
2394 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2396 /* Just call the non-sharing version. */
2397 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2402 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2403 (SCM proc
, SCM s
, SCM start
, SCM end
),
2404 "@var{proc} is a char->char procedure, it is mapped over\n"
2405 "@var{s}. The order in which the procedure is applied to the\n"
2406 "string elements is not specified.")
2407 #define FUNC_NAME s_scm_string_map
2413 SCM_VALIDATE_PROC (1, proc
);
2414 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2417 result
= scm_allocate_string (cend
- cstart
);
2418 p
= SCM_STRING_CHARS (result
);
2419 while (cstart
< cend
)
2421 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (cstr
[cstart
]));
2422 if (!SCM_CHARP (ch
))
2423 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2425 *p
++ = SCM_CHAR (ch
);
2432 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2433 (SCM proc
, SCM s
, SCM start
, SCM end
),
2434 "@var{proc} is a char->char procedure, it is mapped over\n"
2435 "@var{s}. The order in which the procedure is applied to the\n"
2436 "string elements is not specified. The string @var{s} is\n"
2437 "modified in-place, the return value is not specified.")
2438 #define FUNC_NAME s_scm_string_map_x
2443 SCM_VALIDATE_PROC (1, proc
);
2444 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2447 p
= SCM_STRING_CHARS (s
) + cstart
;
2448 while (cstart
< cend
)
2450 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (cstr
[cstart
]));
2451 if (!SCM_CHARP (ch
))
2452 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2454 *p
++ = SCM_CHAR (ch
);
2456 return SCM_UNSPECIFIED
;
2461 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2462 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2463 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2464 "as the terminating element, from left to right. @var{kons}\n"
2465 "must expect two arguments: The actual character and the last\n"
2466 "result of @var{kons}' application.")
2467 #define FUNC_NAME s_scm_string_fold
2473 SCM_VALIDATE_PROC (1, kons
);
2474 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2478 while (cstart
< cend
)
2480 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (cstr
[cstart
]), result
);
2488 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2489 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2490 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2491 "as the terminating element, from right to left. @var{kons}\n"
2492 "must expect two arguments: The actual character and the last\n"
2493 "result of @var{kons}' application.")
2494 #define FUNC_NAME s_scm_string_fold_right
2500 SCM_VALIDATE_PROC (1, kons
);
2501 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2505 while (cstart
< cend
)
2507 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (cstr
[cend
- 1]), result
);
2515 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2516 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2517 "@itemize @bullet\n"
2518 "@item @var{g} is used to generate a series of @emph{seed}\n"
2519 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2520 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2522 "@item @var{p} tells us when to stop -- when it returns true\n"
2523 "when applied to one of these seed values.\n"
2524 "@item @var{f} maps each seed value to the corresponding\n"
2525 "character in the result string. These chars are assembled\n"
2526 "into the string in a left-to-right order.\n"
2527 "@item @var{base} is the optional initial/leftmost portion\n"
2528 "of the constructed string; it default to the empty\n"
2530 "@item @var{make_final} is applied to the terminal seed\n"
2531 "value (on which @var{p} returns true) to produce\n"
2532 "the final/rightmost portion of the constructed string.\n"
2533 "It defaults to @code{(lambda (x) "")}.\n"
2535 #define FUNC_NAME s_scm_string_unfold
2539 SCM_VALIDATE_PROC (1, p
);
2540 SCM_VALIDATE_PROC (2, f
);
2541 SCM_VALIDATE_PROC (3, g
);
2542 if (!SCM_UNBNDP (base
))
2544 SCM_VALIDATE_STRING (5, base
);
2548 ans
= scm_allocate_string (0);
2549 if (!SCM_UNBNDP (make_final
))
2550 SCM_VALIDATE_PROC (6, make_final
);
2552 res
= scm_call_1 (p
, seed
);
2553 while (SCM_FALSEP (res
))
2556 SCM ch
= scm_call_1 (f
, seed
);
2557 if (!SCM_CHARP (ch
))
2558 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2559 str
= scm_allocate_string (1);
2560 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2562 ans
= scm_string_append (scm_list_2 (ans
, str
));
2563 seed
= scm_call_1 (g
, seed
);
2564 res
= scm_call_1 (p
, seed
);
2566 if (!SCM_UNBNDP (make_final
))
2568 res
= scm_call_1 (make_final
, seed
);
2569 return scm_string_append (scm_list_2 (ans
, res
));
2577 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2578 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2579 "@itemize @bullet\n"
2580 "@item @var{g} is used to generate a series of @emph{seed}\n"
2581 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2582 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2584 "@item @var{p} tells us when to stop -- when it returns true\n"
2585 "when applied to one of these seed values.\n"
2586 "@item @var{f} maps each seed value to the corresponding\n"
2587 "character in the result string. These chars are assembled\n"
2588 "into the string in a right-to-left order.\n"
2589 "@item @var{base} is the optional initial/rightmost portion\n"
2590 "of the constructed string; it default to the empty\n"
2592 "@item @var{make_final} is applied to the terminal seed\n"
2593 "value (on which @var{p} returns true) to produce\n"
2594 "the final/leftmost portion of the constructed string.\n"
2595 "It defaults to @code{(lambda (x) "")}.\n"
2597 #define FUNC_NAME s_scm_string_unfold_right
2601 SCM_VALIDATE_PROC (1, p
);
2602 SCM_VALIDATE_PROC (2, f
);
2603 SCM_VALIDATE_PROC (3, g
);
2604 if (!SCM_UNBNDP (base
))
2606 SCM_VALIDATE_STRING (5, base
);
2610 ans
= scm_allocate_string (0);
2611 if (!SCM_UNBNDP (make_final
))
2612 SCM_VALIDATE_PROC (6, make_final
);
2614 res
= scm_call_1 (p
, seed
);
2615 while (SCM_FALSEP (res
))
2618 SCM ch
= scm_call_1 (f
, seed
);
2619 if (!SCM_CHARP (ch
))
2620 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2621 str
= scm_allocate_string (1);
2622 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2624 ans
= scm_string_append (scm_list_2 (str
, ans
));
2625 seed
= scm_call_1 (g
, seed
);
2626 res
= scm_call_1 (p
, seed
);
2628 if (!SCM_UNBNDP (make_final
))
2630 res
= scm_call_1 (make_final
, seed
);
2631 return scm_string_append (scm_list_2 (res
, ans
));
2639 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2640 (SCM proc
, SCM s
, SCM start
, SCM end
),
2641 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2642 "return value is not specified.")
2643 #define FUNC_NAME s_scm_string_for_each
2648 SCM_VALIDATE_PROC (1, proc
);
2649 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2652 while (cstart
< cend
)
2654 scm_call_1 (proc
, SCM_MAKE_CHAR (cstr
[cstart
]));
2657 return SCM_UNSPECIFIED
;
2661 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2662 (SCM proc
, SCM s
, SCM start
, SCM end
),
2663 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2664 "return value is not specified.")
2665 #define FUNC_NAME s_scm_string_for_each
2670 SCM_VALIDATE_PROC (1, proc
);
2671 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2674 while (cstart
< cend
)
2676 scm_call_1 (proc
, SCM_MAKINUM (cstart
));
2679 return SCM_UNSPECIFIED
;
2683 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2684 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2685 "This is the @emph{extended substring} procedure that implements\n"
2686 "replicated copying of a substring of some string.\n"
2688 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2689 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2690 "0 and the length of @var{s}. Replicate this substring up and\n"
2691 "down index space, in both the positive and negative directions.\n"
2692 "@code{xsubstring} returns the substring of this string\n"
2693 "beginning at index @var{from}, and ending at @var{to}, which\n"
2694 "defaults to @var{from} + (@var{end} - @var{start}).")
2695 #define FUNC_NAME s_scm_xsubstring
2698 int cstart
, cend
, cfrom
, cto
;
2701 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2704 SCM_VALIDATE_INUM_COPY (2, from
, cfrom
);
2705 SCM_VALIDATE_INUM_DEF_COPY (3, to
, cfrom
+ (cend
- cstart
), cto
);
2706 if (cstart
== cend
&& cfrom
!= cto
)
2707 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2709 result
= scm_allocate_string (cto
- cfrom
);
2711 p
= SCM_STRING_CHARS (result
);
2714 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2716 *p
= cs
[(cend
- cstart
) - t
];
2727 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2728 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2729 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2730 "is written into the string @var{target} starting at index\n"
2731 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2732 "@var{target} @var{s})} or these arguments share storage -- you\n"
2733 "cannot copy a string on top of itself.")
2734 #define FUNC_NAME s_scm_string_xcopy_x
2736 char * ctarget
, * cs
, * p
;
2737 int ctstart
, csfrom
, csto
, cstart
, cend
;
2738 SCM dummy
= SCM_UNDEFINED
;
2741 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
2744 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
2747 SCM_VALIDATE_INUM_COPY (4, sfrom
, csfrom
);
2748 SCM_VALIDATE_INUM_DEF_COPY (5, sto
, csfrom
+ (cend
- cstart
), csto
);
2749 if (cstart
== cend
&& csfrom
!= csto
)
2750 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2751 SCM_ASSERT_RANGE (1, tstart
,
2752 ctstart
+ (csto
- csfrom
) <= SCM_STRING_LENGTH (target
));
2754 p
= ctarget
+ ctstart
;
2755 while (csfrom
< csto
)
2757 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2759 *p
= cs
[(cend
- cstart
) - t
];
2765 return SCM_UNSPECIFIED
;
2770 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2771 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2772 "Return the string @var{s1}, but with the characters\n"
2773 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2774 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2775 #define FUNC_NAME s_scm_string_replace
2777 char * cstr1
, * cstr2
, * p
;
2778 int cstart1
, cend1
, cstart2
, cend2
;
2781 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
2784 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
2787 result
= scm_allocate_string (cstart1
+ (cend2
- cstart2
) +
2788 SCM_STRING_LENGTH (s1
) - cend1
);
2789 p
= SCM_STRING_CHARS (result
);
2790 memmove (p
, cstr1
, cstart1
* sizeof (char));
2791 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
2792 memmove (p
+ cstart1
+ (cend2
- cstart2
),
2794 (SCM_STRING_LENGTH (s1
) - cend1
) * sizeof (char));
2800 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2801 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2802 "Split the string @var{s} into a list of substrings, where each\n"
2803 "substring is a maximal non-empty contiguous sequence of\n"
2804 "characters from the character set @var{token_set}, which\n"
2805 "defaults to @code{char-set:graphic} from module (srfi srfi-14).\n"
2806 "If @var{start} or @var{end} indices are provided, they restrict\n"
2807 "@code{string-tokenize} to operating on the indicated substring\n"
2809 #define FUNC_NAME s_scm_string_tokenize
2813 SCM result
= SCM_EOL
;
2815 static SCM charset_graphic
= SCM_BOOL_F
;
2817 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2821 if (SCM_UNBNDP (token_set
))
2823 if (charset_graphic
== SCM_BOOL_F
)
2825 SCM srfi_14_module
= scm_c_resolve_module ("srfi srfi-14");
2826 SCM charset_graphic_var
= scm_c_module_lookup (srfi_14_module
,
2827 "char-set:graphic");
2829 scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var
));
2831 token_set
= charset_graphic
;
2834 if (SCM_CHARSETP (token_set
))
2838 while (cstart
< cend
)
2840 while (cstart
< cend
)
2842 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2849 while (cstart
< cend
)
2851 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2855 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
2858 else SCM_WRONG_TYPE_ARG (2, token_set
);
2864 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
2865 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2866 "Filter the string @var{s}, retaining only those characters that\n"
2867 "satisfy the @var{char_pred} argument. If the argument is a\n"
2868 "procedure, it is applied to each character as a predicate, if\n"
2869 "it is a character, it is tested for equality and if it is a\n"
2870 "character set, it is tested for membership.")
2871 #define FUNC_NAME s_scm_string_filter
2878 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2881 if (SCM_CHARP (char_pred
))
2886 chr
= SCM_CHAR (char_pred
);
2890 if (cstr
[idx
] == chr
)
2891 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2894 result
= scm_reverse_list_to_string (ls
);
2896 else if (SCM_CHARSETP (char_pred
))
2903 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2904 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2907 result
= scm_reverse_list_to_string (ls
);
2913 SCM_VALIDATE_PROC (2, char_pred
);
2918 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2919 if (!SCM_FALSEP (res
))
2920 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2923 result
= scm_reverse_list_to_string (ls
);
2930 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
2931 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2932 "Filter the string @var{s}, retaining only those characters that\n"
2933 "do not satisfy the @var{char_pred} argument. If the argument\n"
2934 "is a procedure, it is applied to each character as a predicate,\n"
2935 "if it is a character, it is tested for equality and if it is a\n"
2936 "character set, it is tested for membership.")
2937 #define FUNC_NAME s_scm_string_delete
2944 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2947 if (SCM_CHARP (char_pred
))
2952 chr
= SCM_CHAR (char_pred
);
2956 if (cstr
[idx
] != chr
)
2957 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2960 result
= scm_reverse_list_to_string (ls
);
2962 else if (SCM_CHARSETP (char_pred
))
2969 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2970 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2973 result
= scm_reverse_list_to_string (ls
);
2979 SCM_VALIDATE_PROC (2, char_pred
);
2984 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2985 if (SCM_FALSEP (res
))
2986 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2989 result
= scm_reverse_list_to_string (ls
);
2996 /* Initialize the SRFI-13 module. This function will be called by the
2997 loading Scheme module. */
2999 scm_init_srfi_13 (void)
3001 /* We initialize the SRFI-14 module here, because the string
3002 primitives need the charset smob type created by that module. */
3003 scm_c_init_srfi_14 ();
3005 /* Install the string primitives. */
3006 #include "srfi/srfi-13.x"
3009 /* End of srfi-13.c. */