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_is_true (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
));
82 if (scm_is_false (res
))
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 clen
= scm_to_size_t (len
);
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_from_int (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_is_eq (grammar
, scm_sym_infix
))
241 else if (scm_is_eq (grammar
, scm_sym_strict_infix
))
242 gram
= GRAM_STRICT_INFIX
;
243 else if (scm_is_eq (grammar
, scm_sym_suffix
))
245 else if (scm_is_eq (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
369 SCM_VALIDATE_STRING (1, str
);
370 s
= scm_to_size_t (start
);
371 if (SCM_UNBNDP (end
))
372 e
= SCM_STRING_LENGTH (str
);
374 e
= scm_to_size_t (end
);
375 if (s
== 0 && e
== SCM_STRING_LENGTH (str
))
378 return scm_substring (str
, start
, end
);
383 SCM_DEFINE (scm_string_copy_x
, "string-copy!", 3, 2, 0,
384 (SCM target
, SCM tstart
, SCM s
, SCM start
, SCM end
),
385 "Copy the sequence of characters from index range [@var{start},\n"
386 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
387 "at index @var{tstart}. The characters are copied left-to-right\n"
388 "or right-to-left as needed -- the copy is guaranteed to work,\n"
389 "even if @var{target} and @var{s} are the same string. It is an\n"
390 "error if the copy operation runs off the end of the target\n"
392 #define FUNC_NAME s_scm_string_copy_x
394 char * cstr
, * ctarget
;
395 int cstart
, cend
, ctstart
, dummy
;
397 SCM sdummy
= SCM_UNDEFINED
;
399 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, target
, ctarget
,
402 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
406 SCM_ASSERT_RANGE (3, s
, len
<= SCM_STRING_LENGTH (target
) - ctstart
);
408 memmove (SCM_STRING_CHARS (target
) + ctstart
,
409 SCM_STRING_CHARS (s
) + cstart
,
410 len
* sizeof (char));
411 return SCM_UNSPECIFIED
;
416 SCM_DEFINE (scm_string_take
, "string-take", 2, 0, 0,
418 "Return the @var{n} first characters of @var{s}.")
419 #define FUNC_NAME s_scm_string_take
424 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
425 cn
= scm_to_unsigned_integer (n
, 0, 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 cn
= scm_to_unsigned_integer (n
, 0, SCM_STRING_LENGTH (s
));
443 return scm_mem2string (cstr
+ cn
, SCM_STRING_LENGTH (s
) - cn
);
448 SCM_DEFINE (scm_string_take_right
, "string-take-right", 2, 0, 0,
450 "Return the @var{n} last characters of @var{s}.")
451 #define FUNC_NAME s_scm_string_take_right
456 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
457 cn
= scm_to_unsigned_integer (n
, 0, SCM_STRING_LENGTH (s
));
459 return scm_mem2string (cstr
+ SCM_STRING_LENGTH (s
) - cn
, cn
);
464 SCM_DEFINE (scm_string_drop_right
, "string-drop-right", 2, 0, 0,
466 "Return all but the last @var{n} characters of @var{s}.")
467 #define FUNC_NAME s_scm_string_drop_right
472 SCM_VALIDATE_STRING_COPY (1, s
, cstr
);
473 cn
= scm_to_unsigned_integer (n
, 0, SCM_STRING_LENGTH (s
));
475 return scm_mem2string (cstr
, SCM_STRING_LENGTH (s
) - cn
);
480 SCM_DEFINE (scm_string_pad
, "string-pad", 2, 3, 0,
481 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
482 "Take that characters from @var{start} to @var{end} from the\n"
483 "string @var{s} and return a new string, right-padded by the\n"
484 "character @var{chr} to length @var{len}. If the resulting\n"
485 "string is longer than @var{len}, it is truncated on the right.")
486 #define FUNC_NAME s_scm_string_pad
490 size_t cstart
, cend
, clen
;
493 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
496 clen
= scm_to_size_t (len
);
498 if (SCM_UNBNDP (chr
))
502 SCM_VALIDATE_CHAR (3, chr
);
503 cchr
= SCM_CHAR (chr
);
505 result
= scm_allocate_string (clen
);
506 if (clen
< (cend
- cstart
))
507 memmove (SCM_STRING_CHARS (result
),
509 clen
* sizeof (char));
512 memset (SCM_STRING_CHARS (result
), cchr
,
513 (clen
- (cend
- cstart
)) * sizeof (char));
514 memmove (SCM_STRING_CHARS (result
) + (clen
- (cend
- cstart
)),
516 (cend
- cstart
) * sizeof (char));
523 SCM_DEFINE (scm_string_pad_right
, "string-pad-right", 2, 3, 0,
524 (SCM s
, SCM len
, SCM chr
, SCM start
, SCM end
),
525 "Take that characters from @var{start} to @var{end} from the\n"
526 "string @var{s} and return a new string, left-padded by the\n"
527 "character @var{chr} to length @var{len}. If the resulting\n"
528 "string is longer than @var{len}, it is truncated on the left.")
529 #define FUNC_NAME s_scm_string_pad_right
533 size_t cstart
, cend
, clen
;
536 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
539 clen
= scm_to_size_t (len
);
541 if (SCM_UNBNDP (chr
))
545 SCM_VALIDATE_CHAR (3, chr
);
546 cchr
= SCM_CHAR (chr
);
548 result
= scm_allocate_string (clen
);
549 if (clen
< (cend
- cstart
))
550 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
, clen
* sizeof (char));
553 memset (SCM_STRING_CHARS (result
) + (cend
- cstart
),
554 cchr
, (clen
- (cend
- cstart
)) * sizeof (char));
555 memmove (SCM_STRING_CHARS (result
), cstr
+ cstart
,
556 (cend
- cstart
) * sizeof (char));
563 SCM_DEFINE (scm_string_trim
, "string-trim", 1, 3, 0,
564 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
565 "Trim @var{s} by skipping over all characters on the left\n"
566 "that satisfy the parameter @var{char_pred}:\n"
570 "if it is the character @var{ch}, characters equal to\n"
571 "@var{ch} are trimmed,\n"
574 "if it is a procedure @var{pred} characters that\n"
575 "satisfy @var{pred} are trimmed,\n"
578 "if it is a character set, characters in that set are trimmed.\n"
581 "If called without a @var{char_pred} argument, all whitespace is\n"
583 #define FUNC_NAME s_scm_string_trim
588 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
591 if (SCM_UNBNDP (char_pred
))
593 while (cstart
< cend
)
595 if (!isspace((int) (unsigned char) cstr
[cstart
]))
600 else if (SCM_CHARP (char_pred
))
602 char chr
= SCM_CHAR (char_pred
);
603 while (cstart
< cend
)
605 if (chr
!= cstr
[cstart
])
610 else if (SCM_CHARSETP (char_pred
))
612 while (cstart
< cend
)
614 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
621 SCM_VALIDATE_PROC (2, char_pred
);
622 while (cstart
< cend
)
626 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
627 if (scm_is_false (res
))
632 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
637 SCM_DEFINE (scm_string_trim_right
, "string-trim-right", 1, 3, 0,
638 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
639 "Trim @var{s} by skipping over all characters on the rightt\n"
640 "that satisfy the parameter @var{char_pred}:\n"
644 "if it is the character @var{ch}, characters equal to @var{ch}\n"
648 "if it is a procedure @var{pred} characters that satisfy\n"
649 "@var{pred} are trimmed,\n"
652 "if it is a character sets, all characters in that set are\n"
656 "If called without a @var{char_pred} argument, all whitespace is\n"
658 #define FUNC_NAME s_scm_string_trim_right
663 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
666 if (SCM_UNBNDP (char_pred
))
668 while (cstart
< cend
)
670 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
675 else if (SCM_CHARP (char_pred
))
677 char chr
= SCM_CHAR (char_pred
);
678 while (cstart
< cend
)
680 if (chr
!= cstr
[cend
- 1])
685 else if (SCM_CHARSETP (char_pred
))
687 while (cstart
< cend
)
689 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
696 SCM_VALIDATE_PROC (2, char_pred
);
697 while (cstart
< cend
)
701 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
702 if (scm_is_false (res
))
707 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
712 SCM_DEFINE (scm_string_trim_both
, "string-trim-both", 1, 3, 0,
713 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
714 "Trim @var{s} by skipping over all characters on both sides of\n"
715 "the string that satisfy the parameter @var{char_pred}:\n"
719 "if it is the character @var{ch}, characters equal to @var{ch}\n"
723 "if it is a procedure @var{pred} characters that satisfy\n"
724 "@var{pred} are trimmed,\n"
727 "if it is a character set, the characters in the set are\n"
731 "If called without a @var{char_pred} argument, all whitespace is\n"
733 #define FUNC_NAME s_scm_string_trim_both
738 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
741 if (SCM_UNBNDP (char_pred
))
743 while (cstart
< cend
)
745 if (!isspace((int) (unsigned char) cstr
[cstart
]))
749 while (cstart
< cend
)
751 if (!isspace((int) (unsigned char) cstr
[cend
- 1]))
756 else if (SCM_CHARP (char_pred
))
758 char chr
= SCM_CHAR (char_pred
);
759 while (cstart
< cend
)
761 if (chr
!= cstr
[cstart
])
765 while (cstart
< cend
)
767 if (chr
!= cstr
[cend
- 1])
772 else if (SCM_CHARSETP (char_pred
))
774 while (cstart
< cend
)
776 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
780 while (cstart
< cend
)
782 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
- 1]))
789 SCM_VALIDATE_PROC (2, char_pred
);
790 while (cstart
< cend
)
794 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
795 if (scm_is_false (res
))
799 while (cstart
< cend
)
803 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
- 1]));
804 if (scm_is_false (res
))
809 return scm_mem2string (cstr
+ cstart
, cend
- cstart
);
814 SCM_DEFINE (scm_string_fill_xS
, "string-fill!", 2, 2, 0,
815 (SCM str
, SCM chr
, SCM start
, SCM end
),
816 "Stores @var{chr} in every element of the given @var{str} and\n"
817 "returns an unspecified value.")
818 #define FUNC_NAME s_scm_string_fill_xS
825 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
828 SCM_VALIDATE_CHAR_COPY (2, chr
, c
);
829 for (k
= cstart
; k
< cend
; k
++)
831 return SCM_UNSPECIFIED
;
836 SCM_DEFINE (scm_string_compare
, "string-compare", 5, 4, 0,
837 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
838 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
839 "mismatch index, depending upon whether @var{s1} is less than,\n"
840 "equal to, or greater than @var{s2}. The mismatch index is the\n"
841 "largest index @var{i} such that for every 0 <= @var{j} <\n"
842 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
843 "@var{i} is the first position that does not match.")
844 #define FUNC_NAME s_scm_string_compare
846 char * cstr1
, * cstr2
;
847 int cstart1
, cend1
, cstart2
, cend2
;
849 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
852 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
855 SCM_VALIDATE_PROC (3, proc_lt
);
856 SCM_VALIDATE_PROC (4, proc_eq
);
857 SCM_VALIDATE_PROC (5, proc_gt
);
859 while (cstart1
< cend1
&& cstart2
< cend2
)
861 if (cstr1
[cstart1
] < cstr2
[cstart2
])
862 return scm_call_1 (proc_lt
, SCM_I_MAKINUM (cstart1
));
863 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
864 return scm_call_1 (proc_gt
, SCM_I_MAKINUM (cstart1
));
869 return scm_call_1 (proc_gt
, SCM_I_MAKINUM (cstart1
));
870 else if (cstart2
< cend2
)
871 return scm_call_1 (proc_lt
, SCM_I_MAKINUM (cstart1
));
873 return scm_call_1 (proc_eq
, SCM_I_MAKINUM (cstart1
));
878 SCM_DEFINE (scm_string_compare_ci
, "string-compare-ci", 5, 4, 0,
879 (SCM s1
, SCM s2
, SCM proc_lt
, SCM proc_eq
, SCM proc_gt
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
880 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
881 "mismatch index, depending upon whether @var{s1} is less than,\n"
882 "equal to, or greater than @var{s2}. The mismatch index is the\n"
883 "largest index @var{i} such that for every 0 <= @var{j} <\n"
884 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
885 "@var{i} is the first position that does not match. The\n"
886 "character comparison is done case-insensitively.")
887 #define FUNC_NAME s_scm_string_compare_ci
889 char * cstr1
, * cstr2
;
890 int cstart1
, cend1
, cstart2
, cend2
;
892 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
895 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
898 SCM_VALIDATE_PROC (3, proc_lt
);
899 SCM_VALIDATE_PROC (4, proc_eq
);
900 SCM_VALIDATE_PROC (5, proc_gt
);
902 while (cstart1
< cend1
&& cstart2
< cend2
)
904 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
905 return scm_call_1 (proc_lt
, SCM_I_MAKINUM (cstart1
));
906 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
907 return scm_call_1 (proc_gt
, SCM_I_MAKINUM (cstart1
));
912 return scm_call_1 (proc_gt
, SCM_I_MAKINUM (cstart1
));
913 else if (cstart2
< cend2
)
914 return scm_call_1 (proc_lt
, SCM_I_MAKINUM (cstart1
));
916 return scm_call_1 (proc_eq
, SCM_I_MAKINUM (cstart1
));
921 SCM_DEFINE (scm_string_eq
, "string=", 2, 4, 0,
922 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
923 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
925 #define FUNC_NAME s_scm_string_eq
927 char * cstr1
, * cstr2
;
928 int cstart1
, cend1
, cstart2
, cend2
;
930 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
933 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
937 while (cstart1
< cend1
&& cstart2
< cend2
)
939 if (cstr1
[cstart1
] < cstr2
[cstart2
])
941 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
948 else if (cstart2
< cend2
)
951 return SCM_I_MAKINUM (cstart1
);
956 SCM_DEFINE (scm_string_neq
, "string<>", 2, 4, 0,
957 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
958 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
960 #define FUNC_NAME s_scm_string_neq
962 char * cstr1
, * cstr2
;
963 int cstart1
, cend1
, cstart2
, cend2
;
965 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
968 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
972 while (cstart1
< cend1
&& cstart2
< cend2
)
974 if (cstr1
[cstart1
] < cstr2
[cstart2
])
975 return SCM_I_MAKINUM (cstart1
);
976 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
977 return SCM_I_MAKINUM (cstart1
);
982 return SCM_I_MAKINUM (cstart1
);
983 else if (cstart2
< cend2
)
984 return SCM_I_MAKINUM (cstart1
);
991 SCM_DEFINE (scm_string_lt
, "string<", 2, 4, 0,
992 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
993 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
994 "true value otherwise.")
995 #define FUNC_NAME s_scm_string_lt
997 char * cstr1
, * cstr2
;
998 int cstart1
, cend1
, cstart2
, cend2
;
1000 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1003 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1007 while (cstart1
< cend1
&& cstart2
< cend2
)
1009 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1010 return SCM_I_MAKINUM (cstart1
);
1011 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1016 if (cstart1
< cend1
)
1018 else if (cstart2
< cend2
)
1019 return SCM_I_MAKINUM (cstart1
);
1026 SCM_DEFINE (scm_string_gt
, "string>", 2, 4, 0,
1027 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1028 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1029 "true value otherwise.")
1030 #define FUNC_NAME s_scm_string_gt
1032 char * cstr1
, * cstr2
;
1033 int cstart1
, cend1
, cstart2
, cend2
;
1035 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1038 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1042 while (cstart1
< cend1
&& cstart2
< cend2
)
1044 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1046 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1047 return SCM_I_MAKINUM (cstart1
);
1051 if (cstart1
< cend1
)
1052 return SCM_I_MAKINUM (cstart1
);
1053 else if (cstart2
< cend2
)
1061 SCM_DEFINE (scm_string_le
, "string<=", 2, 4, 0,
1062 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1063 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1065 #define FUNC_NAME s_scm_string_le
1067 char * cstr1
, * cstr2
;
1068 int cstart1
, cend1
, cstart2
, cend2
;
1070 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1073 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1077 while (cstart1
< cend1
&& cstart2
< cend2
)
1079 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1080 return SCM_I_MAKINUM (cstart1
);
1081 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1086 if (cstart1
< cend1
)
1088 else if (cstart2
< cend2
)
1089 return SCM_I_MAKINUM (cstart1
);
1091 return SCM_I_MAKINUM (cstart1
);
1096 SCM_DEFINE (scm_string_ge
, "string>=", 2, 4, 0,
1097 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1098 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1100 #define FUNC_NAME s_scm_string_ge
1102 char * cstr1
, * cstr2
;
1103 int cstart1
, cend1
, cstart2
, cend2
;
1105 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1108 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1112 while (cstart1
< cend1
&& cstart2
< cend2
)
1114 if (cstr1
[cstart1
] < cstr2
[cstart2
])
1116 else if (cstr1
[cstart1
] > cstr2
[cstart2
])
1117 return SCM_I_MAKINUM (cstart1
);
1121 if (cstart1
< cend1
)
1122 return SCM_I_MAKINUM (cstart1
);
1123 else if (cstart2
< cend2
)
1126 return SCM_I_MAKINUM (cstart1
);
1131 SCM_DEFINE (scm_string_ci_eq
, "string-ci=", 2, 4, 0,
1132 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1133 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1134 "value otherwise. The character comparison is done\n"
1135 "case-insensitively.")
1136 #define FUNC_NAME s_scm_string_ci_eq
1138 char * cstr1
, * cstr2
;
1139 int cstart1
, cend1
, cstart2
, cend2
;
1141 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1144 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1148 while (cstart1
< cend1
&& cstart2
< cend2
)
1150 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1152 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1157 if (cstart1
< cend1
)
1159 else if (cstart2
< cend2
)
1162 return SCM_I_MAKINUM (cstart1
);
1167 SCM_DEFINE (scm_string_ci_neq
, "string-ci<>", 2, 4, 0,
1168 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1169 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1170 "value otherwise. The character comparison is done\n"
1171 "case-insensitively.")
1172 #define FUNC_NAME s_scm_string_ci_neq
1174 char * cstr1
, * cstr2
;
1175 int cstart1
, cend1
, cstart2
, cend2
;
1177 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1180 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1184 while (cstart1
< cend1
&& cstart2
< cend2
)
1186 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1187 return SCM_I_MAKINUM (cstart1
);
1188 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1189 return SCM_I_MAKINUM (cstart1
);
1193 if (cstart1
< cend1
)
1194 return SCM_I_MAKINUM (cstart1
);
1195 else if (cstart2
< cend2
)
1196 return SCM_I_MAKINUM (cstart1
);
1203 SCM_DEFINE (scm_string_ci_lt
, "string-ci<", 2, 4, 0,
1204 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1205 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1206 "true value otherwise. The character comparison is done\n"
1207 "case-insensitively.")
1208 #define FUNC_NAME s_scm_string_ci_lt
1210 char * cstr1
, * cstr2
;
1211 int cstart1
, cend1
, cstart2
, cend2
;
1213 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1216 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1220 while (cstart1
< cend1
&& cstart2
< cend2
)
1222 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1223 return SCM_I_MAKINUM (cstart1
);
1224 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1229 if (cstart1
< cend1
)
1231 else if (cstart2
< cend2
)
1232 return SCM_I_MAKINUM (cstart1
);
1239 SCM_DEFINE (scm_string_ci_gt
, "string-ci>", 2, 4, 0,
1240 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1241 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1242 "true value otherwise. The character comparison is done\n"
1243 "case-insensitively.")
1244 #define FUNC_NAME s_scm_string_ci_gt
1246 char * cstr1
, * cstr2
;
1247 int cstart1
, cend1
, cstart2
, cend2
;
1249 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1252 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1256 while (cstart1
< cend1
&& cstart2
< cend2
)
1258 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1260 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1261 return SCM_I_MAKINUM (cstart1
);
1265 if (cstart1
< cend1
)
1266 return SCM_I_MAKINUM (cstart1
);
1267 else if (cstart2
< cend2
)
1275 SCM_DEFINE (scm_string_ci_le
, "string-ci<=", 2, 4, 0,
1276 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1277 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1278 "value otherwise. The character comparison is done\n"
1279 "case-insensitively.")
1280 #define FUNC_NAME s_scm_string_ci_le
1282 char * cstr1
, * cstr2
;
1283 int cstart1
, cend1
, cstart2
, cend2
;
1285 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1288 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1292 while (cstart1
< cend1
&& cstart2
< cend2
)
1294 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1295 return SCM_I_MAKINUM (cstart1
);
1296 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1301 if (cstart1
< cend1
)
1303 else if (cstart2
< cend2
)
1304 return SCM_I_MAKINUM (cstart1
);
1306 return SCM_I_MAKINUM (cstart1
);
1311 SCM_DEFINE (scm_string_ci_ge
, "string-ci>=", 2, 4, 0,
1312 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1313 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1314 "otherwise. The character comparison is done\n"
1315 "case-insensitively.")
1316 #define FUNC_NAME s_scm_string_ci_ge
1318 char * cstr1
, * cstr2
;
1319 int cstart1
, cend1
, cstart2
, cend2
;
1321 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1324 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1328 while (cstart1
< cend1
&& cstart2
< cend2
)
1330 if (scm_c_downcase (cstr1
[cstart1
]) < scm_c_downcase (cstr2
[cstart2
]))
1332 else if (scm_c_downcase (cstr1
[cstart1
]) > scm_c_downcase (cstr2
[cstart2
]))
1333 return SCM_I_MAKINUM (cstart1
);
1337 if (cstart1
< cend1
)
1338 return SCM_I_MAKINUM (cstart1
);
1339 else if (cstart2
< cend2
)
1342 return SCM_I_MAKINUM (cstart1
);
1347 SCM_DEFINE (scm_string_prefix_length
, "string-prefix-length", 2, 4, 0,
1348 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1349 "Return the length of the longest common prefix of the two\n"
1351 #define FUNC_NAME s_scm_string_prefix_length
1353 char * cstr1
, * cstr2
;
1354 int cstart1
, cend1
, cstart2
, cend2
;
1357 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1360 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1363 while (cstart1
< cend1
&& cstart2
< cend2
)
1365 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1366 return SCM_I_MAKINUM (len
);
1371 return SCM_I_MAKINUM (len
);
1376 SCM_DEFINE (scm_string_prefix_length_ci
, "string-prefix-length-ci", 2, 4, 0,
1377 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1378 "Return the length of the longest common prefix of the two\n"
1379 "strings, ignoring character case.")
1380 #define FUNC_NAME s_scm_string_prefix_length_ci
1382 char * cstr1
, * cstr2
;
1383 int cstart1
, cend1
, cstart2
, cend2
;
1386 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1389 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1392 while (cstart1
< cend1
&& cstart2
< cend2
)
1394 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1395 return SCM_I_MAKINUM (len
);
1400 return SCM_I_MAKINUM (len
);
1405 SCM_DEFINE (scm_string_suffix_length
, "string-suffix-length", 2, 4, 0,
1406 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1407 "Return the length of the longest common suffix of the two\n"
1409 #define FUNC_NAME s_scm_string_suffix_length
1411 char * cstr1
, * cstr2
;
1412 int cstart1
, cend1
, cstart2
, cend2
;
1415 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1418 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1421 while (cstart1
< cend1
&& cstart2
< cend2
)
1425 if (cstr1
[cend1
] != cstr2
[cend2
])
1426 return SCM_I_MAKINUM (len
);
1429 return SCM_I_MAKINUM (len
);
1434 SCM_DEFINE (scm_string_suffix_length_ci
, "string-suffix-length-ci", 2, 4, 0,
1435 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1436 "Return the length of the longest common suffix of the two\n"
1437 "strings, ignoring character case.")
1438 #define FUNC_NAME s_scm_string_suffix_length_ci
1440 char * cstr1
, * cstr2
;
1441 int cstart1
, cend1
, cstart2
, cend2
;
1444 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1447 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1450 while (cstart1
< cend1
&& cstart2
< cend2
)
1454 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1455 return SCM_I_MAKINUM (len
);
1458 return SCM_I_MAKINUM (len
);
1463 SCM_DEFINE (scm_string_prefix_p
, "string-prefix?", 2, 4, 0,
1464 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1465 "Is @var{s1} a prefix of @var{s2}?")
1466 #define FUNC_NAME s_scm_string_prefix_p
1468 char * cstr1
, * cstr2
;
1469 int cstart1
, cend1
, cstart2
, cend2
;
1472 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1475 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1478 len1
= cend1
- cstart1
;
1479 while (cstart1
< cend1
&& cstart2
< cend2
)
1481 if (cstr1
[cstart1
] != cstr2
[cstart2
])
1482 return scm_from_bool (len
== len1
);
1487 return scm_from_bool (len
== len1
);
1492 SCM_DEFINE (scm_string_prefix_ci_p
, "string-prefix-ci?", 2, 4, 0,
1493 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1494 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1495 #define FUNC_NAME s_scm_string_prefix_ci_p
1497 char * cstr1
, * cstr2
;
1498 int cstart1
, cend1
, cstart2
, cend2
;
1501 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1504 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1507 len1
= cend1
- cstart1
;
1508 while (cstart1
< cend1
&& cstart2
< cend2
)
1510 if (scm_c_downcase (cstr1
[cstart1
]) != scm_c_downcase (cstr2
[cstart2
]))
1511 return scm_from_bool (len
== len1
);
1516 return scm_from_bool (len
== len1
);
1521 SCM_DEFINE (scm_string_suffix_p
, "string-suffix?", 2, 4, 0,
1522 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1523 "Is @var{s1} a suffix of @var{s2}?")
1524 #define FUNC_NAME s_scm_string_suffix_p
1526 char * cstr1
, * cstr2
;
1527 int cstart1
, cend1
, cstart2
, cend2
;
1530 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1533 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1536 len1
= cend1
- cstart1
;
1537 while (cstart1
< cend1
&& cstart2
< cend2
)
1541 if (cstr1
[cend1
] != cstr2
[cend2
])
1542 return scm_from_bool (len
== len1
);
1545 return scm_from_bool (len
== len1
);
1550 SCM_DEFINE (scm_string_suffix_ci_p
, "string-suffix-ci?", 2, 4, 0,
1551 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1552 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1553 #define FUNC_NAME s_scm_string_suffix_ci_p
1555 char * cstr1
, * cstr2
;
1556 int cstart1
, cend1
, cstart2
, cend2
;
1559 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
1562 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
1565 len1
= cend1
- cstart1
;
1566 while (cstart1
< cend1
&& cstart2
< cend2
)
1570 if (scm_c_downcase (cstr1
[cend1
]) != scm_c_downcase (cstr2
[cend2
]))
1571 return scm_from_bool (len
== len1
);
1574 return scm_from_bool (len
== len1
);
1579 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1580 in the core, which does not accept a predicate. */
1581 SCM_DEFINE (scm_string_indexS
, "string-index", 2, 2, 0,
1582 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1583 "Search through the string @var{s} from left to right, returning\n"
1584 "the index of the first occurence of a character which\n"
1586 "@itemize @bullet\n"
1588 "equals @var{char_pred}, if it is character,\n"
1591 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1594 "is in the set @var{char_pred}, if it is a character set.\n"
1596 #define FUNC_NAME s_scm_string_indexS
1601 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1604 if (SCM_CHARP (char_pred
))
1606 char cchr
= SCM_CHAR (char_pred
);
1607 while (cstart
< cend
)
1609 if (cchr
== cstr
[cstart
])
1610 return SCM_I_MAKINUM (cstart
);
1614 else if (SCM_CHARSETP (char_pred
))
1616 while (cstart
< cend
)
1618 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1619 return SCM_I_MAKINUM (cstart
);
1625 SCM_VALIDATE_PROC (2, char_pred
);
1626 while (cstart
< cend
)
1629 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1630 if (scm_is_true (res
))
1631 return SCM_I_MAKINUM (cstart
);
1640 SCM_DEFINE (scm_string_index_right
, "string-index-right", 2, 2, 0,
1641 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1642 "Search through the string @var{s} from right to left, returning\n"
1643 "the index of the last occurence of a character which\n"
1645 "@itemize @bullet\n"
1647 "equals @var{char_pred}, if it is character,\n"
1650 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1653 "is in the set if @var{char_pred} is a character set.\n"
1655 #define FUNC_NAME s_scm_string_index_right
1660 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1663 if (SCM_CHARP (char_pred
))
1665 char cchr
= SCM_CHAR (char_pred
);
1666 while (cstart
< cend
)
1669 if (cchr
== cstr
[cend
])
1670 return SCM_I_MAKINUM (cend
);
1673 else if (SCM_CHARSETP (char_pred
))
1675 while (cstart
< cend
)
1678 if (SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1679 return SCM_I_MAKINUM (cend
);
1684 SCM_VALIDATE_PROC (2, char_pred
);
1685 while (cstart
< cend
)
1689 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1690 if (scm_is_true (res
))
1691 return SCM_I_MAKINUM (cend
);
1699 SCM_DEFINE (scm_string_skip
, "string-skip", 2, 2, 0,
1700 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1701 "Search through the string @var{s} from left to right, returning\n"
1702 "the index of the first occurence of a character which\n"
1704 "@itemize @bullet\n"
1706 "does not equal @var{char_pred}, if it is character,\n"
1709 "does not satisify the predicate @var{char_pred}, if it is a\n"
1713 "is not in the set if @var{char_pred} is a character set.\n"
1715 #define FUNC_NAME s_scm_string_skip
1720 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1723 if (SCM_CHARP (char_pred
))
1725 char cchr
= SCM_CHAR (char_pred
);
1726 while (cstart
< cend
)
1728 if (cchr
!= cstr
[cstart
])
1729 return SCM_I_MAKINUM (cstart
);
1733 else if (SCM_CHARSETP (char_pred
))
1735 while (cstart
< cend
)
1737 if (!SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1738 return SCM_I_MAKINUM (cstart
);
1744 SCM_VALIDATE_PROC (2, char_pred
);
1745 while (cstart
< cend
)
1748 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1749 if (scm_is_false (res
))
1750 return SCM_I_MAKINUM (cstart
);
1759 SCM_DEFINE (scm_string_skip_right
, "string-skip-right", 2, 2, 0,
1760 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1761 "Search through the string @var{s} from right to left, returning\n"
1762 "the index of the last occurence of a character which\n"
1764 "@itemize @bullet\n"
1766 "does not equal @var{char_pred}, if it is character,\n"
1769 "does not satisifie the predicate @var{char_pred}, if it is a\n"
1773 "is not in the set if @var{char_pred} is a character set.\n"
1775 #define FUNC_NAME s_scm_string_skip_right
1780 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1783 if (SCM_CHARP (char_pred
))
1785 char cchr
= SCM_CHAR (char_pred
);
1786 while (cstart
< cend
)
1789 if (cchr
!= cstr
[cend
])
1790 return SCM_I_MAKINUM (cend
);
1793 else if (SCM_CHARSETP (char_pred
))
1795 while (cstart
< cend
)
1798 if (!SCM_CHARSET_GET (char_pred
, cstr
[cend
]))
1799 return SCM_I_MAKINUM (cend
);
1804 SCM_VALIDATE_PROC (2, char_pred
);
1805 while (cstart
< cend
)
1809 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cend
]));
1810 if (scm_is_false (res
))
1811 return SCM_I_MAKINUM (cend
);
1819 SCM_DEFINE (scm_string_count
, "string-count", 2, 2, 0,
1820 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
1821 "Return the count of the number of characters in the string\n"
1824 "@itemize @bullet\n"
1826 "equals @var{char_pred}, if it is character,\n"
1829 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1832 "is in the set @var{char_pred}, if it is a character set.\n"
1834 #define FUNC_NAME s_scm_string_count
1840 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
1843 if (SCM_CHARP (char_pred
))
1845 char cchr
= SCM_CHAR (char_pred
);
1846 while (cstart
< cend
)
1848 if (cchr
== cstr
[cstart
])
1853 else if (SCM_CHARSETP (char_pred
))
1855 while (cstart
< cend
)
1857 if (SCM_CHARSET_GET (char_pred
, cstr
[cstart
]))
1864 SCM_VALIDATE_PROC (2, char_pred
);
1865 while (cstart
< cend
)
1868 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[cstart
]));
1869 if (scm_is_true (res
))
1874 return SCM_I_MAKINUM (count
);
1879 /* FIXME::martin: This should definitely get implemented more
1880 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1882 SCM_DEFINE (scm_string_contains
, "string-contains", 2, 4, 0,
1883 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1884 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1885 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1886 "The optional start/end indices restrict the operation to the\n"
1887 "indicated substrings.")
1888 #define FUNC_NAME s_scm_string_contains
1891 int cstart1
, cend1
, cstart2
, cend2
;
1894 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1897 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1900 len2
= cend2
- cstart2
;
1901 while (cstart1
<= cend1
- len2
)
1905 while (i
< cend1
&& j
< cend2
&& cs1
[i
] == cs2
[j
])
1911 return SCM_I_MAKINUM (cstart1
);
1919 /* FIXME::martin: This should definitely get implemented more
1920 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1922 SCM_DEFINE (scm_string_contains_ci
, "string-contains-ci", 2, 4, 0,
1923 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
1924 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1925 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1926 "The optional start/end indices restrict the operation to the\n"
1927 "indicated substrings. Character comparison is done\n"
1928 "case-insensitively.")
1929 #define FUNC_NAME s_scm_string_contains_ci
1932 int cstart1
, cend1
, cstart2
, cend2
;
1935 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cs1
,
1938 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cs2
,
1941 len2
= cend2
- cstart2
;
1942 while (cstart1
<= cend1
- len2
)
1946 while (i
< cend1
&& j
< cend2
&&
1947 scm_c_downcase (cs1
[i
]) == scm_c_downcase (cs2
[j
]))
1953 return SCM_I_MAKINUM (cstart1
);
1961 /* Helper function for the string uppercase conversion functions.
1962 * No argument checking is performed. */
1964 string_upcase_x (SCM v
, int start
, int end
)
1968 for (k
= start
; k
< end
; ++k
)
1969 SCM_STRING_UCHARS (v
) [k
] = scm_c_upcase (SCM_STRING_UCHARS (v
) [k
]);
1975 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
1976 in the core, which does not accept start/end indices */
1977 SCM_DEFINE (scm_string_upcase_xS
, "string-upcase!", 1, 2, 0,
1978 (SCM str
, SCM start
, SCM end
),
1979 "Destructively upcase every character in @code{str}.\n"
1982 "(string-upcase! y)\n"
1983 "@result{} \"ARRDEFG\"\n"
1985 "@result{} \"ARRDEFG\"\n"
1987 #define FUNC_NAME s_scm_string_upcase_xS
1992 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
1995 return string_upcase_x (str
, cstart
, cend
);
2000 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2001 in the core, which does not accept start/end indices */
2002 SCM_DEFINE (scm_string_upcaseS
, "string-upcase", 1, 2, 0,
2003 (SCM str
, SCM start
, SCM end
),
2004 "Upcase every character in @code{str}.")
2005 #define FUNC_NAME s_scm_string_upcaseS
2010 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2013 return string_upcase_x (scm_string_copy (str
), cstart
, cend
);
2018 /* Helper function for the string lowercase conversion functions.
2019 * No argument checking is performed. */
2021 string_downcase_x (SCM v
, int start
, int end
)
2025 for (k
= start
; k
< end
; ++k
)
2026 SCM_STRING_UCHARS (v
) [k
] = scm_c_downcase (SCM_STRING_UCHARS (v
) [k
]);
2032 /* FIXME::martin: The `S' is to avoid a name clash with the procedure
2033 in the core, which does not accept start/end indices */
2034 SCM_DEFINE (scm_string_downcase_xS
, "string-downcase!", 1, 2, 0,
2035 (SCM str
, SCM start
, SCM end
),
2036 "Destructively downcase every character in @var{str}.\n"
2040 "@result{} \"ARRDEFG\"\n"
2041 "(string-downcase! y)\n"
2042 "@result{} \"arrdefg\"\n"
2044 "@result{} \"arrdefg\"\n"
2046 #define FUNC_NAME s_scm_string_downcase_xS
2051 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2054 return string_downcase_x (str
, cstart
, cend
);
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_downcaseS
, "string-downcase", 1, 2, 0,
2062 (SCM str
, SCM start
, SCM end
),
2063 "Downcase every character in @var{str}.")
2064 #define FUNC_NAME s_scm_string_downcaseS
2069 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2072 return string_downcase_x (scm_string_copy (str
), cstart
, cend
);
2077 /* Helper function for the string capitalization functions.
2078 * No argument checking is performed. */
2080 string_titlecase_x (SCM str
, int start
, int end
)
2085 sz
= SCM_STRING_UCHARS (str
);
2086 for(i
= start
; i
< end
; i
++)
2088 if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz
[i
]))))
2092 sz
[i
] = scm_c_upcase(sz
[i
]);
2097 sz
[i
] = scm_c_downcase(sz
[i
]);
2107 SCM_DEFINE (scm_string_titlecase_x
, "string-titlecase!", 1, 2, 0,
2108 (SCM str
, SCM start
, SCM end
),
2109 "Destructively titlecase every first character in a word in\n"
2111 #define FUNC_NAME s_scm_string_titlecase_x
2116 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2119 return string_titlecase_x (str
, cstart
, cend
);
2124 SCM_DEFINE (scm_string_titlecase
, "string-titlecase", 1, 2, 0,
2125 (SCM str
, SCM start
, SCM end
),
2126 "Titlecase every first character in a word in @var{str}.")
2127 #define FUNC_NAME s_scm_string_titlecase
2132 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2135 return string_titlecase_x (scm_string_copy (str
), cstart
, cend
);
2140 /* Reverse the portion of @var{str} between str[cstart] (including)
2141 and str[cend] excluding. */
2143 string_reverse_x (char * str
, int cstart
, int cend
)
2148 while (cstart
< cend
)
2151 str
[cstart
] = str
[cend
];
2159 SCM_DEFINE (scm_string_reverse
, "string-reverse", 1, 2, 0,
2160 (SCM str
, SCM start
, SCM end
),
2161 "Reverse the string @var{str}. The optional arguments\n"
2162 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2164 #define FUNC_NAME s_scm_string_reverse
2171 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2174 result
= scm_string_copy (str
);
2175 string_reverse_x (SCM_STRING_CHARS (result
), cstart
, cend
);
2181 SCM_DEFINE (scm_string_reverse_x
, "string-reverse!", 1, 2, 0,
2182 (SCM str
, SCM start
, SCM end
),
2183 "Reverse the string @var{str} in-place. The optional arguments\n"
2184 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2185 "operate on. The return value is unspecified.")
2186 #define FUNC_NAME s_scm_string_reverse_x
2192 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str
, cstr
,
2195 string_reverse_x (SCM_STRING_CHARS (str
), cstart
, cend
);
2196 return SCM_UNSPECIFIED
;
2201 SCM_DEFINE (scm_string_append_shared
, "string-append/shared", 0, 0, 1,
2203 "Like @code{string-append}, but the result may share memory\n"
2204 "with the argument strings.")
2205 #define FUNC_NAME s_scm_string_append_shared
2209 SCM_VALIDATE_REST_ARGUMENT (ls
);
2211 /* Optimize the one-argument case. */
2212 i
= scm_ilength (ls
);
2214 return SCM_CAR (ls
);
2216 return scm_string_append (ls
);
2221 SCM_DEFINE (scm_string_concatenate
, "string-concatenate", 1, 0, 0,
2223 "Append the elements of @var{ls} (which must be strings)\n"
2224 "together into a single string. Guaranteed to return a freshly\n"
2225 "allocated string.")
2226 #define FUNC_NAME s_scm_string_concatenate
2228 long strings
= scm_ilength (ls
);
2233 /* Validate the string list. */
2235 SCM_WRONG_TYPE_ARG (1, ls
);
2237 /* Calculate the size of the result string. */
2239 while (!SCM_NULLP (tmp
))
2241 SCM elt
= SCM_CAR (tmp
);
2242 SCM_VALIDATE_STRING (1, elt
);
2243 len
+= SCM_STRING_LENGTH (elt
);
2244 tmp
= SCM_CDR (tmp
);
2246 result
= scm_allocate_string (len
);
2248 /* Copy the list elements into the result. */
2249 p
= SCM_STRING_CHARS (result
);
2251 while (!SCM_NULLP (tmp
))
2253 SCM elt
= SCM_CAR (tmp
);
2254 memmove (p
, SCM_STRING_CHARS (elt
),
2255 SCM_STRING_LENGTH (elt
) * sizeof (char));
2256 p
+= SCM_STRING_LENGTH (elt
);
2257 tmp
= SCM_CDR (tmp
);
2264 SCM_DEFINE (scm_string_concatenate_reverse
, "string-concatenate-reverse", 1, 2, 0,
2265 (SCM ls
, SCM final_string
, SCM end
),
2266 "Without optional arguments, this procedure is equivalent to\n"
2269 "(string-concatenate (reverse ls))\n"
2272 "If the optional argument @var{final_string} is specified, it is\n"
2273 "consed onto the beginning to @var{ls} before performing the\n"
2274 "list-reverse and string-concatenate operations. If @var{end}\n"
2275 "is given, only the characters of @var{final_string} up to index\n"
2276 "@var{end} are used.\n"
2278 "Guaranteed to return a freshly allocated string.")
2279 #define FUNC_NAME s_scm_string_concatenate_reverse
2287 /* Check the optional arguments and calculate the additional length
2288 of the result string. */
2289 if (!SCM_UNBNDP (final_string
))
2291 SCM_VALIDATE_STRING (2, final_string
);
2292 if (!SCM_UNBNDP (end
))
2294 cend
= scm_to_unsigned_integer (end
,
2295 0, SCM_STRING_LENGTH (final_string
));
2299 cend
= SCM_STRING_LENGTH (final_string
);
2303 strings
= scm_ilength (ls
);
2304 /* Validate the string list. */
2306 SCM_WRONG_TYPE_ARG (1, ls
);
2308 /* Calculate the length of the result string. */
2310 while (!SCM_NULLP (tmp
))
2312 SCM elt
= SCM_CAR (tmp
);
2313 SCM_VALIDATE_STRING (1, elt
);
2314 len
+= SCM_STRING_LENGTH (elt
);
2315 tmp
= SCM_CDR (tmp
);
2318 result
= scm_allocate_string (len
);
2320 p
= SCM_STRING_CHARS (result
) + len
;
2322 /* Construct the result string, possibly by using the optional final
2324 if (!SCM_UNBNDP (final_string
))
2327 memmove (p
, SCM_STRING_CHARS (final_string
), cend
* sizeof (char));
2330 while (!SCM_NULLP (tmp
))
2332 SCM elt
= SCM_CAR (tmp
);
2333 p
-= SCM_STRING_LENGTH (elt
);
2334 memmove (p
, SCM_STRING_CHARS (elt
),
2335 SCM_STRING_LENGTH (elt
) * sizeof (char));
2336 tmp
= SCM_CDR (tmp
);
2343 SCM_DEFINE (scm_string_concatenate_shared
, "string-concatenate/shared", 1, 0, 0,
2345 "Like @code{string-concatenate}, but the result may share memory\n"
2346 "with the strings in the list @var{ls}.")
2347 #define FUNC_NAME s_scm_string_concatenate_shared
2349 /* Optimize the one-string case. */
2350 long i
= scm_ilength (ls
);
2353 SCM_VALIDATE_STRING (1, SCM_CAR (ls
));
2354 return SCM_CAR (ls
);
2356 return scm_string_concatenate (ls
);
2361 SCM_DEFINE (scm_string_concatenate_reverse_shared
, "string-concatenate-reverse/shared", 1, 2, 0,
2362 (SCM ls
, SCM final_string
, SCM end
),
2363 "Like @code{string-concatenate-reverse}, but the result may\n"
2364 "share memory with the the strings in the @var{ls} arguments.")
2365 #define FUNC_NAME s_scm_string_concatenate_reverse_shared
2367 /* Just call the non-sharing version. */
2368 return scm_string_concatenate_reverse (ls
, final_string
, end
);
2373 SCM_DEFINE (scm_string_map
, "string-map", 2, 2, 0,
2374 (SCM proc
, SCM s
, SCM start
, SCM end
),
2375 "@var{proc} is a char->char procedure, it is mapped over\n"
2376 "@var{s}. The order in which the procedure is applied to the\n"
2377 "string elements is not specified.")
2378 #define FUNC_NAME s_scm_string_map
2384 SCM_VALIDATE_PROC (1, proc
);
2385 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2388 result
= scm_allocate_string (cend
- cstart
);
2389 p
= SCM_STRING_CHARS (result
);
2390 while (cstart
< cend
)
2392 unsigned int c
= (unsigned char) cstr
[cstart
];
2393 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2394 if (!SCM_CHARP (ch
))
2395 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2397 *p
++ = SCM_CHAR (ch
);
2404 SCM_DEFINE (scm_string_map_x
, "string-map!", 2, 2, 0,
2405 (SCM proc
, SCM s
, SCM start
, SCM end
),
2406 "@var{proc} is a char->char procedure, it is mapped over\n"
2407 "@var{s}. The order in which the procedure is applied to the\n"
2408 "string elements is not specified. The string @var{s} is\n"
2409 "modified in-place, the return value is not specified.")
2410 #define FUNC_NAME s_scm_string_map_x
2415 SCM_VALIDATE_PROC (1, proc
);
2416 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2419 p
= SCM_STRING_CHARS (s
) + cstart
;
2420 while (cstart
< cend
)
2422 unsigned int c
= (unsigned char) cstr
[cstart
];
2423 SCM ch
= scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2424 if (!SCM_CHARP (ch
))
2425 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc
));
2427 *p
++ = SCM_CHAR (ch
);
2429 return SCM_UNSPECIFIED
;
2434 SCM_DEFINE (scm_string_fold
, "string-fold", 3, 2, 0,
2435 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2436 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2437 "as the terminating element, from left to right. @var{kons}\n"
2438 "must expect two arguments: The actual character and the last\n"
2439 "result of @var{kons}' application.")
2440 #define FUNC_NAME s_scm_string_fold
2446 SCM_VALIDATE_PROC (1, kons
);
2447 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2451 while (cstart
< cend
)
2453 unsigned int c
= (unsigned char) cstr
[cstart
];
2454 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2462 SCM_DEFINE (scm_string_fold_right
, "string-fold-right", 3, 2, 0,
2463 (SCM kons
, SCM knil
, SCM s
, SCM start
, SCM end
),
2464 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2465 "as the terminating element, from right to left. @var{kons}\n"
2466 "must expect two arguments: The actual character and the last\n"
2467 "result of @var{kons}' application.")
2468 #define FUNC_NAME s_scm_string_fold_right
2474 SCM_VALIDATE_PROC (1, kons
);
2475 SCM_VALIDATE_SUBSTRING_SPEC_COPY (3, s
, cstr
,
2479 while (cstart
< cend
)
2481 unsigned int c
= (unsigned char) cstr
[cend
- 1];
2482 result
= scm_call_2 (kons
, SCM_MAKE_CHAR (c
), result
);
2490 SCM_DEFINE (scm_string_unfold
, "string-unfold", 4, 2, 0,
2491 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2492 "@itemize @bullet\n"
2493 "@item @var{g} is used to generate a series of @emph{seed}\n"
2494 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2495 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2497 "@item @var{p} tells us when to stop -- when it returns true\n"
2498 "when applied to one of these seed values.\n"
2499 "@item @var{f} maps each seed value to the corresponding\n"
2500 "character in the result string. These chars are assembled\n"
2501 "into the string in a left-to-right order.\n"
2502 "@item @var{base} is the optional initial/leftmost portion\n"
2503 "of the constructed string; it default to the empty\n"
2505 "@item @var{make_final} is applied to the terminal seed\n"
2506 "value (on which @var{p} returns true) to produce\n"
2507 "the final/rightmost portion of the constructed string.\n"
2508 "It defaults to @code{(lambda (x) "")}.\n"
2510 #define FUNC_NAME s_scm_string_unfold
2514 SCM_VALIDATE_PROC (1, p
);
2515 SCM_VALIDATE_PROC (2, f
);
2516 SCM_VALIDATE_PROC (3, g
);
2517 if (!SCM_UNBNDP (base
))
2519 SCM_VALIDATE_STRING (5, base
);
2523 ans
= scm_allocate_string (0);
2524 if (!SCM_UNBNDP (make_final
))
2525 SCM_VALIDATE_PROC (6, make_final
);
2527 res
= scm_call_1 (p
, seed
);
2528 while (scm_is_false (res
))
2531 SCM ch
= scm_call_1 (f
, seed
);
2532 if (!SCM_CHARP (ch
))
2533 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2534 str
= scm_allocate_string (1);
2535 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2537 ans
= scm_string_append (scm_list_2 (ans
, str
));
2538 seed
= scm_call_1 (g
, seed
);
2539 res
= scm_call_1 (p
, seed
);
2541 if (!SCM_UNBNDP (make_final
))
2543 res
= scm_call_1 (make_final
, seed
);
2544 return scm_string_append (scm_list_2 (ans
, res
));
2552 SCM_DEFINE (scm_string_unfold_right
, "string-unfold-right", 4, 2, 0,
2553 (SCM p
, SCM f
, SCM g
, SCM seed
, SCM base
, SCM make_final
),
2554 "@itemize @bullet\n"
2555 "@item @var{g} is used to generate a series of @emph{seed}\n"
2556 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2557 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2559 "@item @var{p} tells us when to stop -- when it returns true\n"
2560 "when applied to one of these seed values.\n"
2561 "@item @var{f} maps each seed value to the corresponding\n"
2562 "character in the result string. These chars are assembled\n"
2563 "into the string in a right-to-left order.\n"
2564 "@item @var{base} is the optional initial/rightmost portion\n"
2565 "of the constructed string; it default to the empty\n"
2567 "@item @var{make_final} is applied to the terminal seed\n"
2568 "value (on which @var{p} returns true) to produce\n"
2569 "the final/leftmost portion of the constructed string.\n"
2570 "It defaults to @code{(lambda (x) "")}.\n"
2572 #define FUNC_NAME s_scm_string_unfold_right
2576 SCM_VALIDATE_PROC (1, p
);
2577 SCM_VALIDATE_PROC (2, f
);
2578 SCM_VALIDATE_PROC (3, g
);
2579 if (!SCM_UNBNDP (base
))
2581 SCM_VALIDATE_STRING (5, base
);
2585 ans
= scm_allocate_string (0);
2586 if (!SCM_UNBNDP (make_final
))
2587 SCM_VALIDATE_PROC (6, make_final
);
2589 res
= scm_call_1 (p
, seed
);
2590 while (scm_is_false (res
))
2593 SCM ch
= scm_call_1 (f
, seed
);
2594 if (!SCM_CHARP (ch
))
2595 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f
));
2596 str
= scm_allocate_string (1);
2597 *SCM_STRING_CHARS (str
) = SCM_CHAR (ch
);
2599 ans
= scm_string_append (scm_list_2 (str
, ans
));
2600 seed
= scm_call_1 (g
, seed
);
2601 res
= scm_call_1 (p
, seed
);
2603 if (!SCM_UNBNDP (make_final
))
2605 res
= scm_call_1 (make_final
, seed
);
2606 return scm_string_append (scm_list_2 (res
, ans
));
2614 SCM_DEFINE (scm_string_for_each
, "string-for-each", 2, 2, 0,
2615 (SCM proc
, SCM s
, SCM start
, SCM end
),
2616 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2617 "return value is not specified.")
2618 #define FUNC_NAME s_scm_string_for_each
2623 SCM_VALIDATE_PROC (1, proc
);
2624 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2627 while (cstart
< cend
)
2629 unsigned int c
= (unsigned char) cstr
[cstart
];
2630 scm_call_1 (proc
, SCM_MAKE_CHAR (c
));
2633 return SCM_UNSPECIFIED
;
2637 SCM_DEFINE (scm_string_for_each_index
, "string-for-each-index", 2, 2, 0,
2638 (SCM proc
, SCM s
, SCM start
, SCM end
),
2639 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2640 "return value is not specified.")
2641 #define FUNC_NAME s_scm_string_for_each
2646 SCM_VALIDATE_PROC (1, proc
);
2647 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s
, cstr
,
2650 while (cstart
< cend
)
2652 scm_call_1 (proc
, SCM_I_MAKINUM (cstart
));
2655 return SCM_UNSPECIFIED
;
2659 SCM_DEFINE (scm_xsubstring
, "xsubstring", 2, 3, 0,
2660 (SCM s
, SCM from
, SCM to
, SCM start
, SCM end
),
2661 "This is the @emph{extended substring} procedure that implements\n"
2662 "replicated copying of a substring of some string.\n"
2664 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2665 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2666 "0 and the length of @var{s}. Replicate this substring up and\n"
2667 "down index space, in both the positive and negative directions.\n"
2668 "@code{xsubstring} returns the substring of this string\n"
2669 "beginning at index @var{from}, and ending at @var{to}, which\n"
2670 "defaults to @var{from} + (@var{end} - @var{start}).")
2671 #define FUNC_NAME s_scm_xsubstring
2674 size_t cstart
, cend
, cfrom
, cto
;
2677 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cs
,
2680 cfrom
= scm_to_size_t (from
);
2681 if (SCM_UNBNDP (to
))
2682 cto
= cfrom
+ (cend
- cstart
);
2684 cto
= scm_to_size_t (to
);
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 size_t 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 csfrom
= scm_to_size_t (sfrom
);
2727 if (SCM_UNBNDP (sto
))
2728 csto
= csfrom
+ (cend
- cstart
);
2730 csto
= scm_to_size_t (sto
);
2731 if (cstart
== cend
&& csfrom
!= csto
)
2732 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL
);
2733 SCM_ASSERT_RANGE (1, tstart
,
2734 ctstart
+ (csto
- csfrom
) <= SCM_STRING_LENGTH (target
));
2736 p
= ctarget
+ ctstart
;
2737 while (csfrom
< csto
)
2739 int t
= ((csfrom
< 0) ? -csfrom
: csfrom
) % (cend
- cstart
);
2741 *p
= cs
[(cend
- cstart
) - t
];
2747 return SCM_UNSPECIFIED
;
2752 SCM_DEFINE (scm_string_replace
, "string-replace", 2, 4, 0,
2753 (SCM s1
, SCM s2
, SCM start1
, SCM end1
, SCM start2
, SCM end2
),
2754 "Return the string @var{s1}, but with the characters\n"
2755 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2756 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2757 #define FUNC_NAME s_scm_string_replace
2759 char * cstr1
, * cstr2
, * p
;
2760 size_t cstart1
, cend1
, cstart2
, cend2
;
2763 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s1
, cstr1
,
2766 SCM_VALIDATE_SUBSTRING_SPEC_COPY (2, s2
, cstr2
,
2769 result
= scm_allocate_string (cstart1
+ (cend2
- cstart2
) +
2770 SCM_STRING_LENGTH (s1
) - cend1
);
2771 p
= SCM_STRING_CHARS (result
);
2772 memmove (p
, cstr1
, cstart1
* sizeof (char));
2773 memmove (p
+ cstart1
, cstr2
+ cstart2
, (cend2
- cstart2
) * sizeof (char));
2774 memmove (p
+ cstart1
+ (cend2
- cstart2
),
2776 (SCM_STRING_LENGTH (s1
) - cend1
) * sizeof (char));
2782 SCM_DEFINE (scm_string_tokenize
, "string-tokenize", 1, 3, 0,
2783 (SCM s
, SCM token_set
, SCM start
, SCM end
),
2784 "Split the string @var{s} into a list of substrings, where each\n"
2785 "substring is a maximal non-empty contiguous sequence of\n"
2786 "characters from the character set @var{token_set}, which\n"
2787 "defaults to @code{char-set:graphic} from module (srfi srfi-14).\n"
2788 "If @var{start} or @var{end} indices are provided, they restrict\n"
2789 "@code{string-tokenize} to operating on the indicated substring\n"
2791 #define FUNC_NAME s_scm_string_tokenize
2794 size_t cstart
, cend
;
2795 SCM result
= SCM_EOL
;
2797 static SCM charset_graphic
= SCM_BOOL_F
;
2799 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2803 if (SCM_UNBNDP (token_set
))
2805 if (charset_graphic
== SCM_BOOL_F
)
2807 SCM srfi_14_module
= scm_c_resolve_module ("srfi srfi-14");
2808 SCM charset_graphic_var
= scm_c_module_lookup (srfi_14_module
,
2809 "char-set:graphic");
2811 scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var
));
2813 token_set
= charset_graphic
;
2816 if (SCM_CHARSETP (token_set
))
2820 while (cstart
< cend
)
2822 while (cstart
< cend
)
2824 if (SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2831 while (cstart
< cend
)
2833 if (!SCM_CHARSET_GET (token_set
, cstr
[cend
- 1]))
2837 result
= scm_cons (scm_mem2string (cstr
+ cend
, idx
- cend
), result
);
2840 else SCM_WRONG_TYPE_ARG (2, token_set
);
2846 SCM_DEFINE (scm_string_filter
, "string-filter", 2, 2, 0,
2847 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2848 "Filter the string @var{s}, retaining only those characters that\n"
2849 "satisfy the @var{char_pred} argument. If the argument is a\n"
2850 "procedure, it is applied to each character as a predicate, if\n"
2851 "it is a character, it is tested for equality and if it is a\n"
2852 "character set, it is tested for membership.")
2853 #define FUNC_NAME s_scm_string_filter
2856 size_t cstart
, cend
;
2860 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2863 if (SCM_CHARP (char_pred
))
2868 chr
= SCM_CHAR (char_pred
);
2872 if (cstr
[idx
] == chr
)
2873 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2876 result
= scm_reverse_list_to_string (ls
);
2878 else if (SCM_CHARSETP (char_pred
))
2885 if (SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2886 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2889 result
= scm_reverse_list_to_string (ls
);
2895 SCM_VALIDATE_PROC (2, char_pred
);
2900 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2901 if (scm_is_true (res
))
2902 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2905 result
= scm_reverse_list_to_string (ls
);
2912 SCM_DEFINE (scm_string_delete
, "string-delete", 2, 2, 0,
2913 (SCM s
, SCM char_pred
, SCM start
, SCM end
),
2914 "Filter the string @var{s}, retaining only those characters that\n"
2915 "do not satisfy the @var{char_pred} argument. If the argument\n"
2916 "is a procedure, it is applied to each character as a predicate,\n"
2917 "if it is a character, it is tested for equality and if it is a\n"
2918 "character set, it is tested for membership.")
2919 #define FUNC_NAME s_scm_string_delete
2922 size_t cstart
, cend
;
2926 SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, s
, cstr
,
2929 if (SCM_CHARP (char_pred
))
2934 chr
= SCM_CHAR (char_pred
);
2938 if (cstr
[idx
] != chr
)
2939 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2942 result
= scm_reverse_list_to_string (ls
);
2944 else if (SCM_CHARSETP (char_pred
))
2951 if (!SCM_CHARSET_GET (char_pred
, cstr
[idx
]))
2952 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2955 result
= scm_reverse_list_to_string (ls
);
2961 SCM_VALIDATE_PROC (2, char_pred
);
2966 res
= scm_call_1 (char_pred
, SCM_MAKE_CHAR (cstr
[idx
]));
2967 if (scm_is_false (res
))
2968 ls
= scm_cons (SCM_MAKE_CHAR (cstr
[idx
]), ls
);
2971 result
= scm_reverse_list_to_string (ls
);
2978 /* Initialize the SRFI-13 module. This function will be called by the
2979 loading Scheme module. */
2981 scm_init_srfi_13 (void)
2983 /* We initialize the SRFI-14 module here, because the string
2984 primitives need the charset smob type created by that module. */
2985 scm_c_init_srfi_14 ();
2987 /* Install the string primitives. */
2988 #include "srfi/srfi-13.x"
2991 /* End of srfi-13.c. */