1 /* srfi-13.c --- SRFI-13 procedures for Guile
3 * Copyright (C) 2001, 2004 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
29 SCM_DEFINE (scm_string_any
, "string-any", 2, 2, 0,
30 (SCM pred
, SCM s
, SCM start
, SCM end
),
31 "Check if the predicate @var{pred} is true for any character in\n"
32 "the string @var{s}, proceeding from left (index @var{start}) to\n"
33 "right (index @var{end}). If @code{string-any} returns true,\n"
34 "the returned true value is the one produced by the first\n"
35 "successful application of @var{pred}.")
36 #define FUNC_NAME s_scm_string_any
42 SCM_VALIDATE_PROC (1, pred
);
43 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
49 res
= scm_call_1 (pred
, SCM_MAKE_CHAR (*cstr
));
50 if (!SCM_FALSEP (res
))
60 SCM_DEFINE (scm_string_every
, "string-every", 2, 2, 0,
61 (SCM pred
, SCM s
, SCM start
, SCM end
),
62 "Check if the predicate @var{pred} is true for every character\n"
63 "in the string @var{s}, proceeding from left (index @var{start})\n"
64 "to right (index @var{end}). If @code{string-every} returns\n"
65 "true, the returned true value is the one produced by the final\n"
66 "application of @var{pred} to the last character of @var{s}.")
67 #define FUNC_NAME s_scm_string_every
73 SCM_VALIDATE_PROC (1, pred
);
74 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
81 res
= scm_call_1 (pred
, SCM_MAKE_CHAR (*cstr
));
92 SCM_DEFINE (scm_string_tabulate
, "string-tabulate", 2, 0, 0,
94 "@var{proc} is an integer->char procedure. Construct a string\n"
95 "of size @var{len} by applying @var{proc} to each index to\n"
96 "produce the corresponding string element. The order in which\n"
97 "@var{proc} is applied to the indices is not specified.")
98 #define FUNC_NAME s_scm_string_tabulate
105 SCM_VALIDATE_PROC (1, proc
);
106 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
107 SCM_ASSERT_RANGE (2, len
, clen
>= 0);
109 res
= scm_allocate_string (clen
);
110 p
= SCM_STRING_CHARS (res
);
114 ch
= scm_call_1 (proc
, SCM_MAKINUM (i
));
116 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
117 *p
++ = SCM_CHAR (ch
);
125 SCM_DEFINE (scm_string_to_listS
, "string->list", 1, 2, 0,
126 (SCM str
, SCM start
, SCM end
),
127 "Convert the string @var{str} into a list of characters.")
128 #define FUNC_NAME s_scm_string_to_listS
132 SCM result
= SCM_EOL
;
134 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
137 while (cstart
< cend
)
140 result
= scm_cons (SCM_MAKE_CHAR (cstr
[cend
]), result
);
146 SCM_DEFINE (scm_reverse_list_to_string
, "reverse-list->string", 1, 0, 0,
148 "An efficient implementation of @code{(compose string->list\n"
152 "(reverse-list->string '(#\a #\B #\c)) @result{} \"cBa\"\n"
154 #define FUNC_NAME s_scm_reverse_list_to_string
157 long i
= scm_ilength (chrs
);
160 SCM_WRONG_TYPE_ARG (1, chrs
);
161 result
= scm_allocate_string (i
);
164 unsigned char *data
= SCM_STRING_UCHARS (result
) + i
;
166 while (!SCM_NULLP (chrs
))
168 SCM elt
= SCM_CAR (chrs
);
170 SCM_VALIDATE_CHAR (SCM_ARGn
, elt
);
172 *data
= SCM_CHAR (elt
);
173 chrs
= SCM_CDR (chrs
);
181 SCM_SYMBOL (scm_sym_infix
, "infix");
182 SCM_SYMBOL (scm_sym_strict_infix
, "strict-infix");
183 SCM_SYMBOL (scm_sym_suffix
, "suffix");
184 SCM_SYMBOL (scm_sym_prefix
, "prefix");
186 SCM_DEFINE (scm_string_join
, "string-join", 1, 2, 0,
187 (SCM ls
, SCM delimiter
, SCM grammar
),
188 "Append the string in the string list @var{ls}, using the string\n"
189 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
190 "@var{grammar} is a symbol which specifies how the delimiter is\n"
191 "placed between the strings, and defaults to the symbol\n"
196 "Insert the separator between list elements. An empty string\n"
197 "will produce an empty list.\n"
198 "@item string-infix\n"
199 "Like @code{infix}, but will raise an error if given the empty\n"
202 "Insert the separator after every list element.\n"
204 "Insert the separator before each list element.\n"
206 #define FUNC_NAME s_scm_string_join
209 #define GRAM_STRICT_INFIX 1
210 #define GRAM_SUFFIX 2
211 #define GRAM_PREFIX 3
214 int gram
= GRAM_INFIX
;
215 int del_len
= 0, extra_len
= 0;
218 long strings
= scm_ilength (ls
);
220 /* Validate the string list. */
222 SCM_WRONG_TYPE_ARG (1, ls
);
224 /* Validate the delimiter and record its length. */
225 if (SCM_UNBNDP (delimiter
))
227 delimiter
= scm_makfrom0str (" ");
232 SCM_VALIDATE_STRING (2, delimiter
);
233 del_len
= SCM_STRING_LENGTH (delimiter
);
236 /* Validate the grammar symbol and remember the grammar. */
237 if (SCM_UNBNDP (grammar
))
239 else if (SCM_EQ_P (grammar
, scm_sym_infix
))
241 else if (SCM_EQ_P (grammar
, scm_sym_strict_infix
))
242 gram
= GRAM_STRICT_INFIX
;
243 else if (SCM_EQ_P (grammar
, scm_sym_suffix
))
245 else if (SCM_EQ_P (grammar
, scm_sym_prefix
))
248 SCM_WRONG_TYPE_ARG (3, grammar
);
250 /* Check grammar constraints and calculate the space required for
256 extra_len
= (strings
> 0) ? ((strings
- 1) * del_len
) : 0;
258 case GRAM_STRICT_INFIX
:
260 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
262 extra_len
= (strings
- 1) * del_len
;
265 extra_len
= strings
* del_len
;
270 while (SCM_CONSP (tmp
))
272 SCM elt
= SCM_CAR (tmp
);
273 SCM_VALIDATE_STRING (1, elt
);
274 len
+= SCM_STRING_LENGTH (elt
);
278 result
= scm_allocate_string (len
+ extra_len
);
279 p
= SCM_STRING_CHARS (result
);
285 case GRAM_STRICT_INFIX
:
286 while (!SCM_NULLP (tmp
))
288 SCM elt
= SCM_CAR (tmp
);
289 memmove (p
, SCM_STRING_CHARS (elt
),
290 SCM_STRING_LENGTH (elt
) * sizeof (char));
291 p
+= SCM_STRING_LENGTH (elt
);
292 if (!SCM_NULLP (SCM_CDR (tmp
)) && del_len
> 0)
294 memmove (p
, SCM_STRING_CHARS (delimiter
),
295 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
302 while (!SCM_NULLP (tmp
))
304 SCM elt
= SCM_CAR (tmp
);
305 memmove (p
, SCM_STRING_CHARS (elt
),
306 SCM_STRING_LENGTH (elt
) * sizeof (char));
307 p
+= SCM_STRING_LENGTH (elt
);
310 memmove (p
, SCM_STRING_CHARS (delimiter
),
311 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
318 while (!SCM_NULLP (tmp
))
320 SCM elt
= SCM_CAR (tmp
);
323 memmove (p
, SCM_STRING_CHARS (delimiter
),
324 SCM_STRING_LENGTH (delimiter
) * sizeof (char));
327 memmove (p
, SCM_STRING_CHARS (elt
),
328 SCM_STRING_LENGTH (elt
) * sizeof (char));
329 p
+= SCM_STRING_LENGTH (elt
);
336 #undef GRAM_STRICT_INFIX
343 SCM_DEFINE (scm_string_copyS
, "string-copy", 1, 2, 0,
344 (SCM str
, SCM start
, SCM end
),
345 "Return a freshly allocated copy of the string @var{str}. If\n"
346 "given, @var{start} and @var{end} delimit the portion of\n"
347 "@var{str} which is copied.")
348 #define FUNC_NAME s_scm_string_copyS
353 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
356 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
362 SCM_DEFINE (scm_substring_shared
, "substring/shared", 2, 1, 0,
363 (SCM str
, SCM start
, SCM end
),
364 "Like @code{substring}, but the result may share memory with the\n"
365 "argument @var{str}.")
366 #define FUNC_NAME s_scm_substring_shared
368 SCM_VALIDATE_STRING (1, str
);
369 SCM_VALIDATE_INUM (2, start
);
370 if (SCM_UNBNDP (end
))
371 end
= SCM_MAKINUM (SCM_STRING_LENGTH (str
));
373 SCM_VALIDATE_INUM (3, end
);
374 if (SCM_INUM (start
) == 0 &&
375 SCM_INUM (end
) == SCM_STRING_LENGTH (str
))
377 return scm_substring (str
, start
, end
);
382 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
383 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
384 "Copy the sequence of characters from index range [@var{start},\n"
385 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
386 "at index @var{tstart}. The characters are copied left-to-right\n"
387 "or right-to-left as needed -- the copy is guaranteed to work,\n"
388 "even if @var{target} and @var{s} are the same string. It is an\n"
389 "error if the copy operation runs off the end of the target\n"
391 #define FUNC_NAME s_scm_string_copy_x
393 char * cstr
, * ctarget
;
394 int cstart
, cend
, ctstart
, dummy
;
396 SCM sdummy
= SCM_UNDEFINED
;
398 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
401 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
405 SCM_ASSERT_RANGE (3, s
, len
<= SCM_STRING_LENGTH (target
) - ctstart
);
407 memmove (SCM_STRING_CHARS (target
) + ctstart
,
408 SCM_STRING_CHARS (s
) + cstart
,
409 len
* sizeof (char));
410 return SCM_UNSPECIFIED
;
415 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
417 "Return the @var{n} first characters of @var{s}.")
418 #define FUNC_NAME s_scm_string_take
423 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
424 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
425 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
427 return scm_mem2string (cstr
, cn
);
432 SCM_DEFINE (scm_string_drop
, "string-drop", 2, 0, 0,
434 "Return all but the first @var{n} characters of @var{s}.")
435 #define FUNC_NAME s_scm_string_drop
440 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
441 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
442 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
444 return scm_mem2string (cstr
+ cn
, SCM_STRING_LENGTH (s
) - cn
);
449 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
451 "Return the @var{n} last characters of @var{s}.")
452 #define FUNC_NAME s_scm_string_take_right
457 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
458 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
459 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
461 return scm_mem2string (cstr
+ SCM_STRING_LENGTH (s
) - cn
, cn
);
466 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
468 "Return all but the last @var{n} characters of @var{s}.")
469 #define FUNC_NAME s_scm_string_drop_right
474 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
475 SCM_VALIDATE_INUM_COPY (2, n
, cn
);
476 SCM_ASSERT_RANGE (2, n
, cn
>= 0 && cn
<= SCM_STRING_LENGTH (s
));
478 return scm_mem2string (cstr
, SCM_STRING_LENGTH (s
) - cn
);
483 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
484 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
485 "Take that characters from @var{start} to @var{end} from the\n"
486 "string @var{s} and return a new string, right-padded by the\n"
487 "character @var{chr} to length @var{len}. If the resulting\n"
488 "string is longer than @var{len}, it is truncated on the right.")
489 #define FUNC_NAME s_scm_string_pad
493 int cstart
, cend
, clen
;
496 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
499 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
500 if (SCM_UNBNDP (chr
))
504 SCM_VALIDATE_CHAR (3, chr
);
505 cchr
= SCM_CHAR (chr
);
507 result
= scm_allocate_string (clen
);
508 if (clen
< (cend
- cstart
))
509 memmove (SCM_STRING_CHARS (result
),
511 clen
* sizeof (char));
514 memset (SCM_STRING_CHARS (result
), cchr
,
515 (clen
- (cend
- cstart
)) * sizeof (char));
516 memmove (SCM_STRING_CHARS (result
) + (clen
- (cend
- cstart
)),
518 (cend
- cstart
) * sizeof (char));
525 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
526 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
527 "Take that characters from @var{start} to @var{end} from the\n"
528 "string @var{s} and return a new string, left-padded by the\n"
529 "character @var{chr} to length @var{len}. If the resulting\n"
530 "string is longer than @var{len}, it is truncated on the left.")
531 #define FUNC_NAME s_scm_string_pad_right
535 int cstart
, cend
, clen
;
538 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
541 SCM_VALIDATE_INUM_COPY (2, len
, clen
);
542 if (SCM_UNBNDP (chr
))
546 SCM_VALIDATE_CHAR (3, chr
);
547 cchr
= SCM_CHAR (chr
);
549 result
= scm_allocate_string (clen
);
550 if (clen
< (cend
- cstart
))
551 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
, clen
* sizeof (char));
554 memset (SCM_STRING_CHARS (result
) + (cend
- cstart
),
555 cchr
, (clen
- (cend
- cstart
)) * sizeof (char));
556 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
,
557 (cend
- cstart
) * sizeof (char));
564 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
565 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
566 "Trim @var{s} by skipping over all characters on the left\n"
567 "that satisfy the parameter @var{char_pred}:\n"
571 "if it is the character @var{ch}, characters equal to\n"
572 "@var{ch} are trimmed,\n"
575 "if it is a procedure @var{pred} characters that\n"
576 "satisfy @var{pred} are trimmed,\n"
579 "if it is a character set, characters in that set are trimmed.\n"
582 "If called without a @var{char_pred} argument, all whitespace is\n"
584 #define FUNC_NAME s_scm_string_trim
589 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
592 if (SCM_UNBNDP (char_pred
))
594 while (cstart
< cend
)
596 if (!isspace((int) (unsigned char) cstr
[cstart
]))
601 else if (SCM_CHARP (char_pred
))
603 char chr
= SCM_CHAR (char_pred
);
604 while (cstart
< cend
)
606 if (chr
!= cstr
[cstart
])
611 else if (SCM_CHARSETP (char_pred
))
613 while (cstart
< cend
)
615 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
622 SCM_VALIDATE_PROC (2, char_pred
);
623 while (cstart
< cend
)
627 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
628 if (SCM_FALSEP (res
))
633 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
638 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
639 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
640 "Trim @var{s} by skipping over all characters on the rightt\n"
641 "that satisfy the parameter @var{char_pred}:\n"
645 "if it is the character @var{ch}, characters equal to @var{ch}\n"
649 "if it is a procedure @var{pred} characters that satisfy\n"
650 "@var{pred} are trimmed,\n"
653 "if it is a character sets, all characters in that set are\n"
657 "If called without a @var{char_pred} argument, all whitespace is\n"
659 #define FUNC_NAME s_scm_string_trim_right
664 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
667 if (SCM_UNBNDP (char_pred
))
669 while (cstart
< cend
)
671 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
676 else if (SCM_CHARP (char_pred
))
678 char chr
= SCM_CHAR (char_pred
);
679 while (cstart
< cend
)
681 if (chr
!= cstr
[cend
- 1])
686 else if (SCM_CHARSETP (char_pred
))
688 while (cstart
< cend
)
690 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
697 SCM_VALIDATE_PROC (2, char_pred
);
698 while (cstart
< cend
)
702 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
703 if (SCM_FALSEP (res
))
708 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
713 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
714 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
715 "Trim @var{s} by skipping over all characters on both sides of\n"
716 "the string that satisfy the parameter @var{char_pred}:\n"
720 "if it is the character @var{ch}, characters equal to @var{ch}\n"
724 "if it is a procedure @var{pred} characters that satisfy\n"
725 "@var{pred} are trimmed,\n"
728 "if it is a character set, the characters in the set are\n"
732 "If called without a @var{char_pred} argument, all whitespace is\n"
734 #define FUNC_NAME s_scm_string_trim_both
739 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
742 if (SCM_UNBNDP (char_pred
))
744 while (cstart
< cend
)
746 if (!isspace((int) (unsigned char) cstr
[cstart
]))
750 while (cstart
< cend
)
752 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
757 else if (SCM_CHARP (char_pred
))
759 char chr
= SCM_CHAR (char_pred
);
760 while (cstart
< cend
)
762 if (chr
!= cstr
[cstart
])
766 while (cstart
< cend
)
768 if (chr
!= cstr
[cend
- 1])
773 else if (SCM_CHARSETP (char_pred
))
775 while (cstart
< cend
)
777 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
781 while (cstart
< cend
)
783 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
790 SCM_VALIDATE_PROC (2, char_pred
);
791 while (cstart
< cend
)
795 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
796 if (SCM_FALSEP (res
))
800 while (cstart
< cend
)
804 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
805 if (SCM_FALSEP (res
))
810 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
815 SCM_DEFINE (scm_string_fill_xS
, "string-fill!", 2, 2, 0,
816 (SCM str
, SCM chr
, SCM start
, SCM end
),
817 "Stores @var{chr} in every element of the given @var{str} and\n"
818 "returns an unspecified value.")
819 #define FUNC_NAME s_scm_string_fill_xS
826 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
829 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
830 for (k
= cstart
; k
< cend
; k
++)
832 return SCM_UNSPECIFIED
;
837 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
838 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
839 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
840 "mismatch index, depending upon whether @var{s1} is less than,\n"
841 "equal to, or greater than @var{s2}. The mismatch index is the\n"
842 "largest index @var{i} such that for every 0 <= @var{j} <\n"
843 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
844 "@var{i} is the first position that does not match.")
845 #define FUNC_NAME s_scm_string_compare
847 char * cstr1
, * cstr2
;
848 int cstart1
, cend1
, cstart2
, cend2
;
850 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
853 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
856 SCM_VALIDATE_PROC (3, proc_lt
);
857 SCM_VALIDATE_PROC (4, proc_eq
);
858 SCM_VALIDATE_PROC (5, proc_gt
);
860 while (cstart1
< cend1
&& cstart2
< cend2
)
862 if (cstr1
[cstart1
] < cstr2
[cstart2
])
863 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
864 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
865 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
870 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
871 else if (cstart2
< cend2
)
872 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
874 return scm_call_1 (proc_eq
, SCM_MAKINUM (cstart1
));
879 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
880 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
881 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
882 "mismatch index, depending upon whether @var{s1} is less than,\n"
883 "equal to, or greater than @var{s2}. The mismatch index is the\n"
884 "largest index @var{i} such that for every 0 <= @var{j} <\n"
885 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
886 "@var{i} is the first position that does not match. The\n"
887 "character comparison is done case-insensitively.")
888 #define FUNC_NAME s_scm_string_compare_ci
890 char * cstr1
, * cstr2
;
891 int cstart1
, cend1
, cstart2
, cend2
;
893 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
896 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
899 SCM_VALIDATE_PROC (3, proc_lt
);
900 SCM_VALIDATE_PROC (4, proc_eq
);
901 SCM_VALIDATE_PROC (5, proc_gt
);
903 while (cstart1
< cend1
&& cstart2
< cend2
)
905 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
906 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
907 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
908 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
913 return scm_call_1 (proc_gt
, SCM_MAKINUM (cstart1
));
914 else if (cstart2
< cend2
)
915 return scm_call_1 (proc_lt
, SCM_MAKINUM (cstart1
));
917 return scm_call_1 (proc_eq
, SCM_MAKINUM (cstart1
));
922 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
923 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
924 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
926 #define FUNC_NAME s_scm_string_eq
928 char * cstr1
, * cstr2
;
929 int cstart1
, cend1
, cstart2
, cend2
;
931 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
934 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
938 while (cstart1
< cend1
&& cstart2
< cend2
)
940 if (cstr1
[cstart1
] < cstr2
[cstart2
])
942 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
949 else if (cstart2
< cend2
)
952 return SCM_MAKINUM (cstart1
);
957 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
958 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
959 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
961 #define FUNC_NAME s_scm_string_neq
963 char * cstr1
, * cstr2
;
964 int cstart1
, cend1
, cstart2
, cend2
;
966 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
969 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
973 while (cstart1
< cend1
&& cstart2
< cend2
)
975 if (cstr1
[cstart1
] < cstr2
[cstart2
])
976 return SCM_MAKINUM (cstart1
);
977 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
978 return SCM_MAKINUM (cstart1
);
983 return SCM_MAKINUM (cstart1
);
984 else if (cstart2
< cend2
)
985 return SCM_MAKINUM (cstart1
);
992 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
993 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
994 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
995 "true value otherwise.")
996 #define FUNC_NAME s_scm_string_lt
998 char * cstr1
, * cstr2
;
999 int cstart1
, cend1
, cstart2
, cend2
;
1001 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1004 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1008 while (cstart1
< cend1
&& cstart2
< cend2
)
1010 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1011 return SCM_MAKINUM (cstart1
);
1012 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1017 if (cstart1
< cend1
)
1019 else if (cstart2
< cend2
)
1020 return SCM_MAKINUM (cstart1
);
1027 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1028 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1029 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1030 "true value otherwise.")
1031 #define FUNC_NAME s_scm_string_gt
1033 char * cstr1
, * cstr2
;
1034 int cstart1
, cend1
, cstart2
, cend2
;
1036 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1039 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1043 while (cstart1
< cend1
&& cstart2
< cend2
)
1045 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1047 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1048 return SCM_MAKINUM (cstart1
);
1052 if (cstart1
< cend1
)
1053 return SCM_MAKINUM (cstart1
);
1054 else if (cstart2
< cend2
)
1062 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1063 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1064 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1066 #define FUNC_NAME s_scm_string_le
1068 char * cstr1
, * cstr2
;
1069 int cstart1
, cend1
, cstart2
, cend2
;
1071 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1074 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1078 while (cstart1
< cend1
&& cstart2
< cend2
)
1080 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1081 return SCM_MAKINUM (cstart1
);
1082 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1087 if (cstart1
< cend1
)
1089 else if (cstart2
< cend2
)
1090 return SCM_MAKINUM (cstart1
);
1092 return SCM_MAKINUM (cstart1
);
1097 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1098 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1099 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1101 #define FUNC_NAME s_scm_string_ge
1103 char * cstr1
, * cstr2
;
1104 int cstart1
, cend1
, cstart2
, cend2
;
1106 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1109 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1113 while (cstart1
< cend1
&& cstart2
< cend2
)
1115 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1117 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1118 return SCM_MAKINUM (cstart1
);
1122 if (cstart1
< cend1
)
1123 return SCM_MAKINUM (cstart1
);
1124 else if (cstart2
< cend2
)
1127 return SCM_MAKINUM (cstart1
);
1132 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1133 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1134 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1135 "value otherwise. The character comparison is done\n"
1136 "case-insensitively.")
1137 #define FUNC_NAME s_scm_string_ci_eq
1139 char * cstr1
, * cstr2
;
1140 int cstart1
, cend1
, cstart2
, cend2
;
1142 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1145 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1149 while (cstart1
< cend1
&& cstart2
< cend2
)
1151 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1153 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1158 if (cstart1
< cend1
)
1160 else if (cstart2
< cend2
)
1163 return SCM_MAKINUM (cstart1
);
1168 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1169 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1170 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1171 "value otherwise. The character comparison is done\n"
1172 "case-insensitively.")
1173 #define FUNC_NAME s_scm_string_ci_neq
1175 char * cstr1
, * cstr2
;
1176 int cstart1
, cend1
, cstart2
, cend2
;
1178 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1181 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1185 while (cstart1
< cend1
&& cstart2
< cend2
)
1187 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1188 return SCM_MAKINUM (cstart1
);
1189 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1190 return SCM_MAKINUM (cstart1
);
1194 if (cstart1
< cend1
)
1195 return SCM_MAKINUM (cstart1
);
1196 else if (cstart2
< cend2
)
1197 return SCM_MAKINUM (cstart1
);
1204 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1205 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1206 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1207 "true value otherwise. The character comparison is done\n"
1208 "case-insensitively.")
1209 #define FUNC_NAME s_scm_string_ci_lt
1211 char * cstr1
, * cstr2
;
1212 int cstart1
, cend1
, cstart2
, cend2
;
1214 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1217 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1221 while (cstart1
< cend1
&& cstart2
< cend2
)
1223 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1224 return SCM_MAKINUM (cstart1
);
1225 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1230 if (cstart1
< cend1
)
1232 else if (cstart2
< cend2
)
1233 return SCM_MAKINUM (cstart1
);
1240 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1241 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1242 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1243 "true value otherwise. The character comparison is done\n"
1244 "case-insensitively.")
1245 #define FUNC_NAME s_scm_string_ci_gt
1247 char * cstr1
, * cstr2
;
1248 int cstart1
, cend1
, cstart2
, cend2
;
1250 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1253 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1257 while (cstart1
< cend1
&& cstart2
< cend2
)
1259 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1261 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1262 return SCM_MAKINUM (cstart1
);
1266 if (cstart1
< cend1
)
1267 return SCM_MAKINUM (cstart1
);
1268 else if (cstart2
< cend2
)
1276 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1277 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1278 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1279 "value otherwise. The character comparison is done\n"
1280 "case-insensitively.")
1281 #define FUNC_NAME s_scm_string_ci_le
1283 char * cstr1
, * cstr2
;
1284 int cstart1
, cend1
, cstart2
, cend2
;
1286 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1289 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1293 while (cstart1
< cend1
&& cstart2
< cend2
)
1295 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1296 return SCM_MAKINUM (cstart1
);
1297 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1302 if (cstart1
< cend1
)
1304 else if (cstart2
< cend2
)
1305 return SCM_MAKINUM (cstart1
);
1307 return SCM_MAKINUM (cstart1
);
1312 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1313 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1314 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1315 "otherwise. The character comparison is done\n"
1316 "case-insensitively.")
1317 #define FUNC_NAME s_scm_string_ci_ge
1319 char * cstr1
, * cstr2
;
1320 int cstart1
, cend1
, cstart2
, cend2
;
1322 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1325 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1329 while (cstart1
< cend1
&& cstart2
< cend2
)
1331 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1333 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1334 return SCM_MAKINUM (cstart1
);
1338 if (cstart1
< cend1
)
1339 return SCM_MAKINUM (cstart1
);
1340 else if (cstart2
< cend2
)
1343 return SCM_MAKINUM (cstart1
);
1348 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1349 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1350 "Return the length of the longest common prefix of the two\n"
1352 #define FUNC_NAME s_scm_string_prefix_length
1354 char * cstr1
, * cstr2
;
1355 int cstart1
, cend1
, cstart2
, cend2
;
1358 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1361 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1364 while (cstart1
< cend1
&& cstart2
< cend2
)
1366 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1367 return SCM_MAKINUM (len
);
1372 return SCM_MAKINUM (len
);
1377 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1378 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1379 "Return the length of the longest common prefix of the two\n"
1380 "strings, ignoring character case.")
1381 #define FUNC_NAME s_scm_string_prefix_length_ci
1383 char * cstr1
, * cstr2
;
1384 int cstart1
, cend1
, cstart2
, cend2
;
1387 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1390 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1393 while (cstart1
< cend1
&& cstart2
< cend2
)
1395 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1396 return SCM_MAKINUM (len
);
1401 return SCM_MAKINUM (len
);
1406 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1407 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1408 "Return the length of the longest common suffix of the two\n"
1410 #define FUNC_NAME s_scm_string_suffix_length
1412 char * cstr1
, * cstr2
;
1413 int cstart1
, cend1
, cstart2
, cend2
;
1416 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1419 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1422 while (cstart1
< cend1
&& cstart2
< cend2
)
1426 if (cstr1
[cend1
] != cstr2
[cend2
])
1427 return SCM_MAKINUM (len
);
1430 return SCM_MAKINUM (len
);
1435 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1436 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1437 "Return the length of the longest common suffix of the two\n"
1438 "strings, ignoring character case.")
1439 #define FUNC_NAME s_scm_string_suffix_length_ci
1441 char * cstr1
, * cstr2
;
1442 int cstart1
, cend1
, cstart2
, cend2
;
1445 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1448 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1451 while (cstart1
< cend1
&& cstart2
< cend2
)
1455 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1456 return SCM_MAKINUM (len
);
1459 return SCM_MAKINUM (len
);
1464 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1465 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1466 "Is @var{s1} a prefix of @var{s2}?")
1467 #define FUNC_NAME s_scm_string_prefix_p
1469 char * cstr1
, * cstr2
;
1470 int cstart1
, cend1
, cstart2
, cend2
;
1473 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1476 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1479 len1
= cend1
- cstart1
;
1480 while (cstart1
< cend1
&& cstart2
< cend2
)
1482 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1483 return SCM_BOOL (len
== len1
);
1488 return SCM_BOOL (len
== len1
);
1493 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1494 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1495 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1496 #define FUNC_NAME s_scm_string_prefix_ci_p
1498 char * cstr1
, * cstr2
;
1499 int cstart1
, cend1
, cstart2
, cend2
;
1502 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1505 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1508 len1
= cend1
- cstart1
;
1509 while (cstart1
< cend1
&& cstart2
< cend2
)
1511 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1512 return SCM_BOOL (len
== len1
);
1517 return SCM_BOOL (len
== len1
);
1522 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1523 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1524 "Is @var{s1} a suffix of @var{s2}?")
1525 #define FUNC_NAME s_scm_string_suffix_p
1527 char * cstr1
, * cstr2
;
1528 int cstart1
, cend1
, cstart2
, cend2
;
1531 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1534 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1537 len1
= cend1
- cstart1
;
1538 while (cstart1
< cend1
&& cstart2
< cend2
)
1542 if (cstr1
[cend1
] != cstr2
[cend2
])
1543 return SCM_BOOL (len
== len1
);
1546 return SCM_BOOL (len
== len1
);
1551 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1552 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1553 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1554 #define FUNC_NAME s_scm_string_suffix_ci_p
1556 char * cstr1
, * cstr2
;
1557 int cstart1
, cend1
, cstart2
, cend2
;
1560 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1563 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1566 len1
= cend1
- cstart1
;
1567 while (cstart1
< cend1
&& cstart2
< cend2
)
1571 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1572 return SCM_BOOL (len
== len1
);
1575 return SCM_BOOL (len
== len1
);
1580 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1581 in the core, which does not accept a predicate. */
1582 SCM_DEFINE (scm_string_indexS
, "string-index", 2, 2, 0,
1583 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1584 "Search through the string @var{s} from left to right, returning\n"
1585 "the index of the first occurence of a character which\n"
1587 "@itemize @bullet\n"
1589 "equals @var{char_pred}, if it is character,\n"
1592 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1595 "is in the set @var{char_pred}, if it is a character set.\n"
1597 #define FUNC_NAME s_scm_string_indexS
1602 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1605 if (SCM_CHARP (char_pred
))
1607 char cchr
= SCM_CHAR (char_pred
);
1608 while (cstart
< cend
)
1610 if (cchr
== cstr
[cstart
])
1611 return SCM_MAKINUM (cstart
);
1615 else if (SCM_CHARSETP (char_pred
))
1617 while (cstart
< cend
)
1619 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1620 return SCM_MAKINUM (cstart
);
1626 SCM_VALIDATE_PROC (2, char_pred
);
1627 while (cstart
< cend
)
1630 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1631 if (!SCM_FALSEP (res
))
1632 return SCM_MAKINUM (cstart
);
1641 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1642 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1643 "Search through the string @var{s} from right to left, returning\n"
1644 "the index of the last occurence of a character which\n"
1646 "@itemize @bullet\n"
1648 "equals @var{char_pred}, if it is character,\n"
1651 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1654 "is in the set if @var{char_pred} is a character set.\n"
1656 #define FUNC_NAME s_scm_string_index_right
1661 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1664 if (SCM_CHARP (char_pred
))
1666 char cchr
= SCM_CHAR (char_pred
);
1667 while (cstart
< cend
)
1670 if (cchr
== cstr
[cend
])
1671 return SCM_MAKINUM (cend
);
1674 else if (SCM_CHARSETP (char_pred
))
1676 while (cstart
< cend
)
1679 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1680 return SCM_MAKINUM (cend
);
1685 SCM_VALIDATE_PROC (2, char_pred
);
1686 while (cstart
< cend
)
1690 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1691 if (!SCM_FALSEP (res
))
1692 return SCM_MAKINUM (cend
);
1700 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1701 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1702 "Search through the string @var{s} from left to right, returning\n"
1703 "the index of the first occurence of a character which\n"
1705 "@itemize @bullet\n"
1707 "does not equal @var{char_pred}, if it is character,\n"
1710 "does not satisify the predicate @var{char_pred}, if it is a\n"
1714 "is not in the set if @var{char_pred} is a character set.\n"
1716 #define FUNC_NAME s_scm_string_skip
1721 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1724 if (SCM_CHARP (char_pred
))
1726 char cchr
= SCM_CHAR (char_pred
);
1727 while (cstart
< cend
)
1729 if (cchr
!= cstr
[cstart
])
1730 return SCM_MAKINUM (cstart
);
1734 else if (SCM_CHARSETP (char_pred
))
1736 while (cstart
< cend
)
1738 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1739 return SCM_MAKINUM (cstart
);
1745 SCM_VALIDATE_PROC (2, char_pred
);
1746 while (cstart
< cend
)
1749 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1750 if (SCM_FALSEP (res
))
1751 return SCM_MAKINUM (cstart
);
1760 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1761 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1762 "Search through the string @var{s} from right to left, returning\n"
1763 "the index of the last occurence of a character which\n"
1765 "@itemize @bullet\n"
1767 "does not equal @var{char_pred}, if it is character,\n"
1770 "does not satisifie the predicate @var{char_pred}, if it is a\n"
1774 "is not in the set if @var{char_pred} is a character set.\n"
1776 #define FUNC_NAME s_scm_string_skip_right
1781 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1784 if (SCM_CHARP (char_pred
))
1786 char cchr
= SCM_CHAR (char_pred
);
1787 while (cstart
< cend
)
1790 if (cchr
!= cstr
[cend
])
1791 return SCM_MAKINUM (cend
);
1794 else if (SCM_CHARSETP (char_pred
))
1796 while (cstart
< cend
)
1799 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1800 return SCM_MAKINUM (cend
);
1805 SCM_VALIDATE_PROC (2, char_pred
);
1806 while (cstart
< cend
)
1810 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1811 if (SCM_FALSEP (res
))
1812 return SCM_MAKINUM (cend
);
1820 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1821 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1822 "Return the count of the number of characters in the string\n"
1825 "@itemize @bullet\n"
1827 "equals @var{char_pred}, if it is character,\n"
1830 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1833 "is in the set @var{char_pred}, if it is a character set.\n"
1835 #define FUNC_NAME s_scm_string_count
1841 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1844 if (SCM_CHARP (char_pred
))
1846 char cchr
= SCM_CHAR (char_pred
);
1847 while (cstart
< cend
)
1849 if (cchr
== cstr
[cstart
])
1854 else if (SCM_CHARSETP (char_pred
))
1856 while (cstart
< cend
)
1858 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1865 SCM_VALIDATE_PROC (2, char_pred
);
1866 while (cstart
< cend
)
1869 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1870 if (!SCM_FALSEP (res
))
1875 return SCM_MAKINUM (count
);
1880 /* FIXME::martin: This should definitely get implemented more
1881 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1883 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1884 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1885 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1886 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1887 "The optional start/end indices restrict the operation to the\n"
1888 "indicated substrings.")
1889 #define FUNC_NAME s_scm_string_contains
1892 int cstart1
, cend1
, cstart2
, cend2
;
1895 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1898 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1901 len2
= cend2
- cstart2
;
1902 while (cstart1
<= cend1
- len2
)
1906 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
1912 return SCM_MAKINUM (cstart1
);
1920 /* FIXME::martin: This should definitely get implemented more
1921 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1923 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
1924 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1925 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1926 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1927 "The optional start/end indices restrict the operation to the\n"
1928 "indicated substrings. Character comparison is done\n"
1929 "case-insensitively.")
1930 #define FUNC_NAME s_scm_string_contains_ci
1933 int cstart1
, cend1
, cstart2
, cend2
;
1936 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1939 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1942 len2
= cend2
- cstart2
;
1943 while (cstart1
<= cend1
- len2
)
1947 while (i
< cend1
&& j
< cend2
&&
1948 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
1954 return SCM_MAKINUM (cstart1
);
1962 /* Helper function for the string uppercase conversion functions.
1963 * No argument checking is performed. */
1965 string_upcase_x (SCM v
, int start
, int end
)
1969 for (k
= start
; k
< end
; ++k
)
1970 SCM_STRING_UCHARS (v
) [k
] = scm_c_upcase (SCM_STRING_UCHARS (v
) [k
]);
1976 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1977 in the core, which does not accept start/end indices */
1978 SCM_DEFINE (scm_string_upcase_xS
, "string-upcase!", 1, 2, 0,
1979 (SCM str
, SCM start
, SCM end
),
1980 "Destructively upcase every character in @code{str}.\n"
1983 "(string-upcase! y)\n"
1984 "@result{} \"ARRDEFG\"\n"
1986 "@result{} \"ARRDEFG\"\n"
1988 #define FUNC_NAME s_scm_string_upcase_xS
1993 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
1996 return string_upcase_x (str
, cstart
, cend
);
2001 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2002 in the core, which does not accept start/end indices */
2003 SCM_DEFINE (scm_string_upcaseS
, "string-upcase", 1, 2, 0,
2004 (SCM str
, SCM start
, SCM end
),
2005 "Upcase every character in @code{str}.")
2006 #define FUNC_NAME s_scm_string_upcaseS
2011 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2014 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2019 /* Helper function for the string lowercase conversion functions.
2020 * No argument checking is performed. */
2022 string_downcase_x (SCM v
, int start
, int end
)
2026 for (k
= start
; k
< end
; ++k
)
2027 SCM_STRING_UCHARS (v
) [k
] = scm_c_downcase (SCM_STRING_UCHARS (v
) [k
]);
2033 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2034 in the core, which does not accept start/end indices */
2035 SCM_DEFINE (scm_string_downcase_xS
, "string-downcase!", 1, 2, 0,
2036 (SCM str
, SCM start
, SCM end
),
2037 "Destructively downcase every character in @var{str}.\n"
2041 "@result{} \"ARRDEFG\"\n"
2042 "(string-downcase! y)\n"
2043 "@result{} \"arrdefg\"\n"
2045 "@result{} \"arrdefg\"\n"
2047 #define FUNC_NAME s_scm_string_downcase_xS
2052 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2055 return string_downcase_x (str
, cstart
, cend
);
2060 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2061 in the core, which does not accept start/end indices */
2062 SCM_DEFINE (scm_string_downcaseS
, "string-downcase", 1, 2, 0,
2063 (SCM str
, SCM start
, SCM end
),
2064 "Downcase every character in @var{str}.")
2065 #define FUNC_NAME s_scm_string_downcaseS
2070 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2073 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2078 /* Helper function for the string capitalization functions.
2079 * No argument checking is performed. */
2081 string_titlecase_x (SCM str
, int start
, int end
)
2086 sz
= SCM_STRING_UCHARS (str
);
2087 for(i
= start
; i
< end
; i
++)
2089 if (!SCM_FALSEP (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2093 sz
[i
] = scm_c_upcase(sz
[i
]);
2098 sz
[i
] = scm_c_downcase(sz
[i
]);
2108 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2109 (SCM str
, SCM start
, SCM end
),
2110 "Destructively titlecase every first character in a word in\n"
2112 #define FUNC_NAME s_scm_string_titlecase_x
2117 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2120 return string_titlecase_x (str
, cstart
, cend
);
2125 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2126 (SCM str
, SCM start
, SCM end
),
2127 "Titlecase every first character in a word in @var{str}.")
2128 #define FUNC_NAME s_scm_string_titlecase
2133 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2136 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2141 /* Reverse the portion of @var{str} between str[cstart] (including)
2142 and str[cend] excluding. */
2144 string_reverse_x (char * str
, int cstart
, int cend
)
2149 while (cstart
< cend
)
2152 str
[cstart
] = str
[cend
];
2160 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2161 (SCM str
, SCM start
, SCM end
),
2162 "Reverse the string @var{str}. The optional arguments\n"
2163 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2165 #define FUNC_NAME s_scm_string_reverse
2172 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2175 result
= scm_string_copy (str
);
2176 string_reverse_x (SCM_STRING_CHARS (result
), cstart
, cend
);
2182 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2183 (SCM str
, SCM start
, SCM end
),
2184 "Reverse the string @var{str} in-place. The optional arguments\n"
2185 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2186 "operate on. The return value is unspecified.")
2187 #define FUNC_NAME s_scm_string_reverse_x
2193 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2196 string_reverse_x (SCM_STRING_CHARS (str
), cstart
, cend
);
2197 return SCM_UNSPECIFIED
;
2202 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2204 "Like @code{string-append}, but the result may share memory\n"
2205 "with the argument strings.")
2206 #define FUNC_NAME s_scm_string_append_shared
2210 SCM_VALIDATE_REST_ARGUMENT (ls
);
2212 /* Optimize the one-argument case. */
2213 i
= scm_ilength (ls
);
2215 return SCM_CAR (ls
);
2217 return scm_string_append (ls
);
2222 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2224 "Append the elements of @var{ls} (which must be strings)\n"
2225 "together into a single string. Guaranteed to return a freshly\n"
2226 "allocated string.")
2227 #define FUNC_NAME s_scm_string_concatenate
2229 long strings
= scm_ilength (ls
);
2234 /* Validate the string list. */
2236 SCM_WRONG_TYPE_ARG (1, ls
);
2238 /* Calculate the size of the result string. */
2240 while (!SCM_NULLP (tmp
))
2242 SCM elt
= SCM_CAR (tmp
);
2243 SCM_VALIDATE_STRING (1, elt
);
2244 len
+= SCM_STRING_LENGTH (elt
);
2245 tmp
= SCM_CDR (tmp
);
2247 result
= scm_allocate_string (len
);
2249 /* Copy the list elements into the result. */
2250 p
= SCM_STRING_CHARS (result
);
2252 while (!SCM_NULLP (tmp
))
2254 SCM elt
= SCM_CAR (tmp
);
2255 memmove (p
, SCM_STRING_CHARS (elt
),
2256 SCM_STRING_LENGTH (elt
) * sizeof (char));
2257 p
+= SCM_STRING_LENGTH (elt
);
2258 tmp
= SCM_CDR (tmp
);
2265 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2266 (SCM ls
, SCM final_string
, SCM end
),
2267 "Without optional arguments, this procedure is equivalent to\n"
2270 "(string-concatenate (reverse ls))\n"
2273 "If the optional argument @var{final_string} is specified, it is\n"
2274 "consed onto the beginning to @var{ls} before performing the\n"
2275 "list-reverse and string-concatenate operations. If @var{end}\n"
2276 "is given, only the characters of @var{final_string} up to index\n"
2277 "@var{end} are used.\n"
2279 "Guaranteed to return a freshly allocated string.")
2280 #define FUNC_NAME s_scm_string_concatenate_reverse
2288 /* Check the optional arguments and calculate the additional length
2289 of the result string. */
2290 if (!SCM_UNBNDP (final_string
))
2292 SCM_VALIDATE_STRING (2, final_string
);
2293 if (!SCM_UNBNDP (end
))
2295 SCM_VALIDATE_INUM_COPY (3, end
, cend
);
2296 SCM_ASSERT_RANGE (3, end
,
2298 (cend
<= SCM_STRING_LENGTH (final_string
)));
2302 cend
= SCM_STRING_LENGTH (final_string
);
2306 strings
= scm_ilength (ls
);
2307 /* Validate the string list. */
2309 SCM_WRONG_TYPE_ARG (1, ls
);
2311 /* Calculate the length of the result string. */
2313 while (!SCM_NULLP (tmp
))
2315 SCM elt
= SCM_CAR (tmp
);
2316 SCM_VALIDATE_STRING (1, elt
);
2317 len
+= SCM_STRING_LENGTH (elt
);
2318 tmp
= SCM_CDR (tmp
);
2321 result
= scm_allocate_string (len
);
2323 p
= SCM_STRING_CHARS (result
) + len
;
2325 /* Construct the result string, possibly by using the optional final
2327 if (!SCM_UNBNDP (final_string
))
2330 memmove (p
, SCM_STRING_CHARS (final_string
), cend
* sizeof (char));
2333 while (!SCM_NULLP (tmp
))
2335 SCM elt
= SCM_CAR (tmp
);
2336 p
-= SCM_STRING_LENGTH (elt
);
2337 memmove (p
, SCM_STRING_CHARS (elt
),
2338 SCM_STRING_LENGTH (elt
) * sizeof (char));
2339 tmp
= SCM_CDR (tmp
);
2346 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2348 "Like @code{string-concatenate}, but the result may share memory\n"
2349 "with the strings in the list @var{ls}.")
2350 #define FUNC_NAME s_scm_string_concatenate_shared
2352 /* Optimize the one-string case. */
2353 long i
= scm_ilength (ls
);
2356 SCM_VALIDATE_STRING (1, SCM_CAR (ls
));
2357 return SCM_CAR (ls
);
2359 return scm_string_concatenate (ls
);
2364 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2365 (SCM ls
, SCM final_string
, SCM end
),
2366 "Like @code{string-concatenate-reverse}, but the result may\n"
2367 "share memory with the the strings in the @var{ls} arguments.")
2368 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2370 /* Just call the non-sharing version. */
2371 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2376 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2377 (SCM proc
, SCM s
, SCM start
, SCM end
),
2378 "@var{proc} is a char->char procedure, it is mapped over\n"
2379 "@var{s}. The order in which the procedure is applied to the\n"
2380 "string elements is not specified.")
2381 #define FUNC_NAME s_scm_string_map
2387 SCM_VALIDATE_PROC (1, proc
);
2388 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2391 result
= scm_allocate_string (cend
- cstart
);
2392 p
= SCM_STRING_CHARS (result
);
2393 while (cstart
< cend
)
2395 unsigned int c
= (unsigned char) cstr
[cstart
];
2396 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2397 if (!SCM_CHARP (ch
))
2398 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2400 *p
++ = SCM_CHAR (ch
);
2407 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2408 (SCM proc
, SCM s
, SCM start
, SCM end
),
2409 "@var{proc} is a char->char procedure, it is mapped over\n"
2410 "@var{s}. The order in which the procedure is applied to the\n"
2411 "string elements is not specified. The string @var{s} is\n"
2412 "modified in-place, the return value is not specified.")
2413 #define FUNC_NAME s_scm_string_map_x
2418 SCM_VALIDATE_PROC (1, proc
);
2419 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2422 p
= SCM_STRING_CHARS (s
) + cstart
;
2423 while (cstart
< cend
)
2425 unsigned int c
= (unsigned char) cstr
[cstart
];
2426 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2427 if (!SCM_CHARP (ch
))
2428 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2430 *p
++ = SCM_CHAR (ch
);
2432 return SCM_UNSPECIFIED
;
2437 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2438 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2439 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2440 "as the terminating element, from left to right. @var{kons}\n"
2441 "must expect two arguments: The actual character and the last\n"
2442 "result of @var{kons}' application.")
2443 #define FUNC_NAME s_scm_string_fold
2449 SCM_VALIDATE_PROC (1, kons
);
2450 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2454 while (cstart
< cend
)
2456 unsigned int c
= (unsigned char) cstr
[cstart
];
2457 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2465 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2466 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2467 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2468 "as the terminating element, from right to left. @var{kons}\n"
2469 "must expect two arguments: The actual character and the last\n"
2470 "result of @var{kons}' application.")
2471 #define FUNC_NAME s_scm_string_fold_right
2477 SCM_VALIDATE_PROC (1, kons
);
2478 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2482 while (cstart
< cend
)
2484 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2485 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2493 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2494 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2495 "@itemize @bullet\n"
2496 "@item @var{g} is used to generate a series of @emph{seed}\n"
2497 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2498 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2500 "@item @var{p} tells us when to stop -- when it returns true\n"
2501 "when applied to one of these seed values.\n"
2502 "@item @var{f} maps each seed value to the corresponding\n"
2503 "character in the result string. These chars are assembled\n"
2504 "into the string in a left-to-right order.\n"
2505 "@item @var{base} is the optional initial/leftmost portion\n"
2506 "of the constructed string; it default to the empty\n"
2508 "@item @var{make_final} is applied to the terminal seed\n"
2509 "value (on which @var{p} returns true) to produce\n"
2510 "the final/rightmost portion of the constructed string.\n"
2511 "It defaults to @code{(lambda (x) "")}.\n"
2513 #define FUNC_NAME s_scm_string_unfold
2517 SCM_VALIDATE_PROC (1, p
);
2518 SCM_VALIDATE_PROC (2, f
);
2519 SCM_VALIDATE_PROC (3, g
);
2520 if (!SCM_UNBNDP (base
))
2522 SCM_VALIDATE_STRING (5, base
);
2526 ans
= scm_allocate_string (0);
2527 if (!SCM_UNBNDP (make_final
))
2528 SCM_VALIDATE_PROC (6, make_final
);
2530 res
= scm_call_1 (p
, seed
);
2531 while (SCM_FALSEP (res
))
2534 SCM ch
= scm_call_1 (f
, seed
);
2535 if (!SCM_CHARP (ch
))
2536 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2537 str
= scm_allocate_string (1);
2538 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2540 ans
= scm_string_append (scm_list_2 (ans
, str
));
2541 seed
= scm_call_1 (g
, seed
);
2542 res
= scm_call_1 (p
, seed
);
2544 if (!SCM_UNBNDP (make_final
))
2546 res
= scm_call_1 (make_final
, seed
);
2547 return scm_string_append (scm_list_2 (ans
, res
));
2555 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2556 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2557 "@itemize @bullet\n"
2558 "@item @var{g} is used to generate a series of @emph{seed}\n"
2559 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2560 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2562 "@item @var{p} tells us when to stop -- when it returns true\n"
2563 "when applied to one of these seed values.\n"
2564 "@item @var{f} maps each seed value to the corresponding\n"
2565 "character in the result string. These chars are assembled\n"
2566 "into the string in a right-to-left order.\n"
2567 "@item @var{base} is the optional initial/rightmost portion\n"
2568 "of the constructed string; it default to the empty\n"
2570 "@item @var{make_final} is applied to the terminal seed\n"
2571 "value (on which @var{p} returns true) to produce\n"
2572 "the final/leftmost portion of the constructed string.\n"
2573 "It defaults to @code{(lambda (x) "")}.\n"
2575 #define FUNC_NAME s_scm_string_unfold_right
2579 SCM_VALIDATE_PROC (1, p
);
2580 SCM_VALIDATE_PROC (2, f
);
2581 SCM_VALIDATE_PROC (3, g
);
2582 if (!SCM_UNBNDP (base
))
2584 SCM_VALIDATE_STRING (5, base
);
2588 ans
= scm_allocate_string (0);
2589 if (!SCM_UNBNDP (make_final
))
2590 SCM_VALIDATE_PROC (6, make_final
);
2592 res
= scm_call_1 (p
, seed
);
2593 while (SCM_FALSEP (res
))
2596 SCM ch
= scm_call_1 (f
, seed
);
2597 if (!SCM_CHARP (ch
))
2598 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2599 str
= scm_allocate_string (1);
2600 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2602 ans
= scm_string_append (scm_list_2 (str
, ans
));
2603 seed
= scm_call_1 (g
, seed
);
2604 res
= scm_call_1 (p
, seed
);
2606 if (!SCM_UNBNDP (make_final
))
2608 res
= scm_call_1 (make_final
, seed
);
2609 return scm_string_append (scm_list_2 (res
, ans
));
2617 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2618 (SCM proc
, SCM s
, SCM start
, SCM end
),
2619 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2620 "return value is not specified.")
2621 #define FUNC_NAME s_scm_string_for_each
2626 SCM_VALIDATE_PROC (1, proc
);
2627 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2630 while (cstart
< cend
)
2632 unsigned int c
= (unsigned char) cstr
[cstart
];
2633 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2636 return SCM_UNSPECIFIED
;
2640 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2641 (SCM proc
, SCM s
, SCM start
, SCM end
),
2642 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2643 "return value is not specified.")
2644 #define FUNC_NAME s_scm_string_for_each
2649 SCM_VALIDATE_PROC (1, proc
);
2650 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2653 while (cstart
< cend
)
2655 scm_call_1 (proc
, SCM_MAKINUM (cstart
));
2658 return SCM_UNSPECIFIED
;
2662 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2663 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2664 "This is the @emph{extended substring} procedure that implements\n"
2665 "replicated copying of a substring of some string.\n"
2667 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2668 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2669 "0 and the length of @var{s}. Replicate this substring up and\n"
2670 "down index space, in both the positive and negative directions.\n"
2671 "@code{xsubstring} returns the substring of this string\n"
2672 "beginning at index @var{from}, and ending at @var{to}, which\n"
2673 "defaults to @var{from} + (@var{end} - @var{start}).")
2674 #define FUNC_NAME s_scm_xsubstring
2677 int cstart
, cend
, cfrom
, cto
;
2680 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2683 SCM_VALIDATE_INUM_COPY (2, from
, cfrom
);
2684 SCM_VALIDATE_INUM_DEF_COPY (3, to
, cfrom
+ (cend
- cstart
), cto
);
2685 if (cstart
== cend
&& cfrom
!= cto
)
2686 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2688 result
= scm_allocate_string (cto
- cfrom
);
2690 p
= SCM_STRING_CHARS (result
);
2693 int t
= ((cfrom
< 0) ? -cfrom
: cfrom
) % (cend
- cstart
);
2695 *p
= cs
[(cend
- cstart
) - t
];
2706 SCM_DEFINE (scm_string_xcopy_x
, "string-xcopy!", 4, 3, 0,
2707 (SCM target
, SCM tstart
, SCM s
, SCM sfrom
, SCM sto
, SCM start
, SCM end
),
2708 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2709 "is written into the string @var{target} starting at index\n"
2710 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2711 "@var{target} @var{s})} or these arguments share storage -- you\n"
2712 "cannot copy a string on top of itself.")
2713 #define FUNC_NAME s_scm_string_xcopy_x
2715 char * ctarget
, * cs
, * p
;
2716 int ctstart
, csfrom
, csto
, cstart
, cend
;
2717 SCM dummy
= SCM_UNDEFINED
;
2720 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
2723 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cs
,
2726 SCM_VALIDATE_INUM_COPY (4, sfrom
, csfrom
);
2727 SCM_VALIDATE_INUM_DEF_COPY (5, sto
, csfrom
+ (cend
- cstart
), csto
);
2728 if (cstart
== cend
&& csfrom
!= csto
)
2729 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2730 SCM_ASSERT_RANGE (1, tstart
,
2731 ctstart
+ (csto
- csfrom
) <= SCM_STRING_LENGTH (target
));
2733 p
= ctarget
+ ctstart
;
2734 while (csfrom
< csto
)
2736 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2738 *p
= cs
[(cend
- cstart
) - t
];
2744 return SCM_UNSPECIFIED
;
2749 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2750 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2751 "Return the string @var{s1}, but with the characters\n"
2752 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2753 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2754 #define FUNC_NAME s_scm_string_replace
2756 char * cstr1
, * cstr2
, * p
;
2757 int cstart1
, cend1
, cstart2
, cend2
;
2760 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
2763 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
2766 result
= scm_allocate_string (cstart1
+ (cend2
- cstart2
) +
2767 SCM_STRING_LENGTH (s1
) - cend1
);
2768 p
= SCM_STRING_CHARS (result
);
2769 memmove (p
, cstr1
, cstart1
* sizeof (char));
2770 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
2771 memmove (p
+ cstart1
+ (cend2
- cstart2
),
2773 (SCM_STRING_LENGTH (s1
) - cend1
) * sizeof (char));
2779 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2780 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2781 "Split the string @var{s} into a list of substrings, where each\n"
2782 "substring is a maximal non-empty contiguous sequence of\n"
2783 "characters from the character set @var{token_set}, which\n"
2784 "defaults to @code{char-set:graphic} from module (srfi srfi-14).\n"
2785 "If @var{start} or @var{end} indices are provided, they restrict\n"
2786 "@code{string-tokenize} to operating on the indicated substring\n"
2788 #define FUNC_NAME s_scm_string_tokenize
2792 SCM result
= SCM_EOL
;
2794 static SCM charset_graphic
= SCM_BOOL_F
;
2796 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2800 if (SCM_UNBNDP (token_set
))
2802 if (charset_graphic
== SCM_BOOL_F
)
2804 SCM srfi_14_module
= scm_c_resolve_module ("srfi srfi-14");
2805 SCM charset_graphic_var
= scm_c_module_lookup (srfi_14_module
,
2806 "char-set:graphic");
2808 scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var
));
2810 token_set
= charset_graphic
;
2813 if (SCM_CHARSETP (token_set
))
2817 while (cstart
< cend
)
2819 while (cstart
< cend
)
2821 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2828 while (cstart
< cend
)
2830 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2834 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
2837 else SCM_WRONG_TYPE_ARG (2, token_set
);
2843 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
2844 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2845 "Filter the string @var{s}, retaining only those characters that\n"
2846 "satisfy the @var{char_pred} argument. If the argument is a\n"
2847 "procedure, it is applied to each character as a predicate, if\n"
2848 "it is a character, it is tested for equality and if it is a\n"
2849 "character set, it is tested for membership.")
2850 #define FUNC_NAME s_scm_string_filter
2857 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2860 if (SCM_CHARP (char_pred
))
2865 chr
= SCM_CHAR (char_pred
);
2869 if (cstr
[idx
] == chr
)
2870 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2873 result
= scm_reverse_list_to_string (ls
);
2875 else if (SCM_CHARSETP (char_pred
))
2882 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2883 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2886 result
= scm_reverse_list_to_string (ls
);
2892 SCM_VALIDATE_PROC (2, char_pred
);
2897 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2898 if (!SCM_FALSEP (res
))
2899 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2902 result
= scm_reverse_list_to_string (ls
);
2909 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
2910 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2911 "Filter the string @var{s}, retaining only those characters that\n"
2912 "do not satisfy the @var{char_pred} argument. If the argument\n"
2913 "is a procedure, it is applied to each character as a predicate,\n"
2914 "if it is a character, it is tested for equality and if it is a\n"
2915 "character set, it is tested for membership.")
2916 #define FUNC_NAME s_scm_string_delete
2923 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2926 if (SCM_CHARP (char_pred
))
2931 chr
= SCM_CHAR (char_pred
);
2935 if (cstr
[idx
] != chr
)
2936 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2939 result
= scm_reverse_list_to_string (ls
);
2941 else if (SCM_CHARSETP (char_pred
))
2948 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2949 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2952 result
= scm_reverse_list_to_string (ls
);
2958 SCM_VALIDATE_PROC (2, char_pred
);
2963 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2964 if (SCM_FALSEP (res
))
2965 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2968 result
= scm_reverse_list_to_string (ls
);
2975 /* Initialize the SRFI-13 module. This function will be called by the
2976 loading Scheme module. */
2978 scm_init_srfi_13 (void)
2980 /* We initialize the SRFI-14 module here, because the string
2981 primitives need the charset smob type created by that module. */
2982 scm_c_init_srfi_14 ();
2984 /* Install the string primitives. */
2985 #include "srfi/srfi-13.x"
2988 /* End of srfi-13.c. */