HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Implementation for the R6RS (rnrs sorting) library.
[bpt/guile.git] / libguile / srfi-13.c
CommitLineData
63181a97
MV		 1/* srfi-13.c --- SRFI-13 procedures for Guile
2 *
f846bd1a 3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
63181a97
MV		 4 *
5 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
63181a97 9 *
53befeb7
NJ		 10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
63181a97
MV		 12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
14 *
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
53befeb7
NJ		 17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18 * 02110-1301 USA
63181a97
MV		 19 */
20
21
dbb605f5
LC		 22#ifdef HAVE_CONFIG_H
23# include <config.h>
24#endif
25
63181a97 26#include <string.h>
f846bd1a
MG		 27#include <unicase.h>
28#include <unictype.h>
63181a97
MV		 29
30#include "libguile.h"
31
32#include "libguile/srfi-13.h"
33#include "libguile/srfi-14.h"
34
63181a97
MV		 35#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
36 pos_start, start, c_start, \
37 pos_end, end, c_end) \
38 do { \
39 SCM_VALIDATE_STRING (pos_str, str); \
40 scm_i_get_substring_spec (scm_i_string_length (str), \
41 start, &c_start, end, &c_end); \
42 } while (0)
43
f846bd1a
MG		 44#define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
45 pos_start, start, c_start, \
46 pos_end, end, c_end) \
47 do { \
48 SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
49 scm_i_get_substring_spec (scm_i_string_length (str), \
50 start, &c_start, end, &c_end); \
51 } while (0)
52
53#define REF_IN_CHARSET(s, i, cs) \
54 (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
55
63181a97
MV		 56SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
57 (SCM str),
58 "Return @code{#t} if @var{str}'s length is zero, and\n"
59 "@code{#f} otherwise.\n"
60 "@lisp\n"
61 "(string-null? \"\") @result{} #t\n"
62 "y @result{} \"foo\"\n"
63 "(string-null? y) @result{} #f\n"
64 "@end lisp")
65#define FUNC_NAME s_scm_string_null_p
66{
67 SCM_VALIDATE_STRING (1, str);
68 return scm_from_bool (scm_i_string_length (str) == 0);
69}
70#undef FUNC_NAME
71
3731fc67
MV		 72#if 0
73static void
74race_error ()
75{
76 scm_misc_error (NULL, "race condition detected", SCM_EOL);
77}
78#endif
79
fdc6aebf 80SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
63181a97 81 (SCM char_pred, SCM s, SCM start, SCM end),
69d2000d
MV		 82"Check if @var{char_pred} is true for any character in string @var{s}.\n"
83"\n"
84"@var{char_pred} can be a character to check for any equal to that, or\n"
85"a character set (@pxref{Character Sets}) to check for any in that set,\n"
86"or a predicate procedure to call.\n"
87"\n"
88"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
89"successively on the characters from @var{start} to @var{end}. If\n"
90"@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
91"stops and that return value is the return from @code{string-any}. The\n"
92"call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
93"point is reached, is a tail call.\n"
94"\n"
95"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
96"@var{end}) then the return is @code{#f}.\n")
63181a97
MV		 97#define FUNC_NAME s_scm_string_any
98{
3731fc67
MV		 99 size_t cstart, cend;
100 SCM res = SCM_BOOL_F;
63181a97 101
f846bd1a
MG		 102 MY_VALIDATE_SUBSTRING_SPEC (2, s,
103 3, start, cstart,
104 4, end, cend);
63181a97
MV		 105
106 if (SCM_CHARP (char_pred))
107 {
f846bd1a
MG		 108 size_t i;
109 for (i = cstart; i < cend; i ++)
110 if (scm_i_string_ref (s, i) == SCM_CHAR (char_pred))
111 {
112 res = SCM_BOOL_T;
113 break;
114 }
63181a97
MV		 115 }
116 else if (SCM_CHARSETP (char_pred))
117 {
1a82a460 118 size_t i;
63181a97 119 for (i = cstart; i < cend; i++)
f846bd1a 120 if (REF_IN_CHARSET (s, i, char_pred))
3731fc67
MV		 121 {
122 res = SCM_BOOL_T;
123 break;
124 }
63181a97
MV		 125 }
126 else
127 {
6c9e8a53
AW		 128 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
129 char_pred, SCM_ARG1, FUNC_NAME);
63181a97 130
63181a97
MV		 131 while (cstart < cend)
132 {
6c9e8a53 133 res = scm_call_1 (char_pred,
f846bd1a 134 SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 135 if (scm_is_true (res))
3731fc67 136 break;
63181a97
MV		 137 cstart++;
138 }
139 }
3731fc67
MV		 140
141 scm_remember_upto_here_1 (s);
142 return res;
63181a97
MV		 143}
144#undef FUNC_NAME
145
146
fdc6aebf 147SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
63181a97 148 (SCM char_pred, SCM s, SCM start, SCM end),
69d2000d
MV		 149"Check if @var{char_pred} is true for every character in string\n"
150"@var{s}.\n"
151"\n"
152"@var{char_pred} can be a character to check for every character equal\n"
153"to that, or a character set (@pxref{Character Sets}) to check for\n"
154"every character being in that set, or a predicate procedure to call.\n"
155"\n"
156"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
157"successively on the characters from @var{start} to @var{end}. If\n"
158"@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
159"returns @code{#f}. The call on the last character (ie.@: at\n"
160"@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
161"return from that call is the return from @code{string-every}.\n"
162"\n"
163"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
164"@var{end}) then the return is @code{#t}.\n")
63181a97
MV		 165#define FUNC_NAME s_scm_string_every
166{
3731fc67
MV		 167 size_t cstart, cend;
168 SCM res = SCM_BOOL_T;
63181a97 169
f846bd1a
MG		 170 MY_VALIDATE_SUBSTRING_SPEC (2, s,
171 3, start, cstart,
172 4, end, cend);
63181a97
MV		 173 if (SCM_CHARP (char_pred))
174 {
1a82a460 175 size_t i;
63181a97 176 for (i = cstart; i < cend; i++)
f846bd1a 177 if (scm_i_string_ref (s, i) != SCM_CHAR (char_pred))
3731fc67
MV		 178 {
179 res = SCM_BOOL_F;
180 break;
181 }
63181a97
MV		 182 }
183 else if (SCM_CHARSETP (char_pred))
184 {
1a82a460 185 size_t i;
63181a97 186 for (i = cstart; i < cend; i++)
f846bd1a 187 if (!REF_IN_CHARSET (s, i, char_pred))
3731fc67
MV		 188 {
189 res = SCM_BOOL_F;
190 break;
191 }
63181a97
MV		 192 }
193 else
194 {
6c9e8a53
AW		 195 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
196 char_pred, SCM_ARG1, FUNC_NAME);
63181a97 197
63181a97
MV		 198 while (cstart < cend)
199 {
6c9e8a53 200 res = scm_call_1 (char_pred,
f846bd1a 201 SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 202 if (scm_is_false (res))
3731fc67 203 break;
63181a97
MV		 204 cstart++;
205 }
63181a97 206 }
3731fc67
MV		 207
208 scm_remember_upto_here_1 (s);
209 return res;
63181a97
MV		 210}
211#undef FUNC_NAME
212
213
214SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
215 (SCM proc, SCM len),
216 "@var{proc} is an integer->char procedure. Construct a string\n"
217 "of size @var{len} by applying @var{proc} to each index to\n"
218 "produce the corresponding string element. The order in which\n"
219 "@var{proc} is applied to the indices is not specified.")
220#define FUNC_NAME s_scm_string_tabulate
221{
222 size_t clen, i;
223 SCM res;
224 SCM ch;
3540b915 225
6c9e8a53
AW		 226 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
227 proc, SCM_ARG1, FUNC_NAME);
63181a97 228
53a468dd 229 SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0);
63181a97 230 clen = scm_to_size_t (len);
63181a97 231
f846bd1a
MG		 232 {
233 /* This function is more complicated than necessary for the sake
234 of speed. */
235 scm_t_wchar *buf = scm_malloc (clen * sizeof (scm_t_wchar));
236 int wide = 0;
237 i = 0;
238 while (i < clen)
239 {
6c9e8a53 240 ch = scm_call_1 (proc, scm_from_size_t (i));
f846bd1a
MG		 241 if (!SCM_CHARP (ch))
242 {
243 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
244 }
245 if (SCM_CHAR (ch) > 255)
246 wide = 1;
247 buf[i] = SCM_CHAR (ch);
248 i++;
249 }
250 if (wide)
251 {
252 scm_t_wchar *wbuf = NULL;
253 res = scm_i_make_wide_string (clen, &wbuf);
254 memcpy (wbuf, buf, clen * sizeof (scm_t_wchar));
255 free (buf);
256 }
257 else
258 {
259 char *nbuf = NULL;
260 res = scm_i_make_string (clen, &nbuf);
261 for (i = 0; i < clen; i ++)
262 nbuf[i] = (unsigned char) buf[i];
263 free (buf);
264 }
265 }
266
63181a97
MV		 267 return res;
268}
269#undef FUNC_NAME
270
271
272SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0,
273 (SCM str, SCM start, SCM end),
274 "Convert the string @var{str} into a list of characters.")
275#define FUNC_NAME s_scm_substring_to_list
276{
3731fc67 277 size_t cstart, cend;
f846bd1a 278 int narrow;
63181a97
MV		 279 SCM result = SCM_EOL;
280
f846bd1a
MG		 281 MY_VALIDATE_SUBSTRING_SPEC (1, str,
282 2, start, cstart,
283 3, end, cend);
284
285 /* This explicit narrow/wide logic (instead of just using
286 scm_i_string_ref) is for speed optimizaion. */
287 narrow = scm_i_is_narrow_string (str);
288 if (narrow)
63181a97 289 {
f846bd1a
MG		 290 const char *buf = scm_i_string_chars (str);
291 while (cstart < cend)
292 {
293 cend--;
294 result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
295 }
296 }
297 else
298 {
299 const scm_t_wchar *buf = scm_i_string_wide_chars (str);
300 while (cstart < cend)
301 {
302 cend--;
303 result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
304 }
63181a97 305 }
3731fc67 306 scm_remember_upto_here_1 (str);
63181a97
MV		 307 return result;
308}
309#undef FUNC_NAME
310
311/* We export scm_substring_to_list as "string->list" since it is
312 compatible and more general. This function remains for the benefit
313 of C code that used it.
314*/
315
316SCM
317scm_string_to_list (SCM str)
318{
319 return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED);
320}
321
322SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
323 (SCM chrs),
324 "An efficient implementation of @code{(compose string->list\n"
325 "reverse)}:\n"
326 "\n"
327 "@smalllisp\n"
328 "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
329 "@end smalllisp")
330#define FUNC_NAME s_scm_reverse_list_to_string
331{
332 SCM result;
f846bd1a 333 long i = scm_ilength (chrs), j;
63181a97
MV		 334 char *data;
335
336 if (i < 0)
337 SCM_WRONG_TYPE_ARG (1, chrs);
338 result = scm_i_make_string (i, &data);
339
340 {
f846bd1a
MG		 341 SCM rest;
342 rest = chrs;
343 j = 0;
344 while (j < i && scm_is_pair (rest))
63181a97 345 {
f846bd1a
MG		 346 SCM elt = SCM_CAR (rest);
347 SCM_VALIDATE_CHAR (SCM_ARGn, elt);
348 j++;
349 rest = SCM_CDR (rest);
350 }
351 rest = chrs;
352 j = i;
353 result = scm_i_string_start_writing (result);
354 while (j > 0 && scm_is_pair (rest))
355 {
356 SCM elt = SCM_CAR (rest);
357 scm_i_string_set_x (result, j-1, SCM_CHAR (elt));
358 rest = SCM_CDR (rest);
359 j--;
63181a97 360 }
f846bd1a 361 scm_i_string_stop_writing ();
63181a97 362 }
3731fc67 363
63181a97
MV		 364 return result;
365}
366#undef FUNC_NAME
367
368
369SCM_SYMBOL (scm_sym_infix, "infix");
370SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
371SCM_SYMBOL (scm_sym_suffix, "suffix");
372SCM_SYMBOL (scm_sym_prefix, "prefix");
373
374SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
375 (SCM ls, SCM delimiter, SCM grammar),
376 "Append the string in the string list @var{ls}, using the string\n"
377 "@var{delim} as a delimiter between the elements of @var{ls}.\n"
378 "@var{grammar} is a symbol which specifies how the delimiter is\n"
379 "placed between the strings, and defaults to the symbol\n"
380 "@code{infix}.\n"
381 "\n"
382 "@table @code\n"
383 "@item infix\n"
384 "Insert the separator between list elements. An empty string\n"
385 "will produce an empty list.\n"
386 "@item string-infix\n"
387 "Like @code{infix}, but will raise an error if given the empty\n"
388 "list.\n"
389 "@item suffix\n"
390 "Insert the separator after every list element.\n"
391 "@item prefix\n"
392 "Insert the separator before each list element.\n"
393 "@end table")
394#define FUNC_NAME s_scm_string_join
395{
396#define GRAM_INFIX 0
397#define GRAM_STRICT_INFIX 1
398#define GRAM_SUFFIX 2
399#define GRAM_PREFIX 3
400 SCM tmp;
401 SCM result;
402 int gram = GRAM_INFIX;
3731fc67 403 size_t del_len = 0;
63181a97
MV		 404 long strings = scm_ilength (ls);
405
406 /* Validate the string list. */
407 if (strings < 0)
408 SCM_WRONG_TYPE_ARG (1, ls);
409
410 /* Validate the delimiter and record its length. */
411 if (SCM_UNBNDP (delimiter))
412 {
413 delimiter = scm_from_locale_string (" ");
414 del_len = 1;
415 }
416 else
f846bd1a
MG		 417 {
418 SCM_VALIDATE_STRING (2, delimiter);
419 del_len = scm_i_string_length (delimiter);
420 }
63181a97
MV		 421
422 /* Validate the grammar symbol and remember the grammar. */
423 if (SCM_UNBNDP (grammar))
424 gram = GRAM_INFIX;
425 else if (scm_is_eq (grammar, scm_sym_infix))
426 gram = GRAM_INFIX;
427 else if (scm_is_eq (grammar, scm_sym_strict_infix))
428 gram = GRAM_STRICT_INFIX;
429 else if (scm_is_eq (grammar, scm_sym_suffix))
430 gram = GRAM_SUFFIX;
431 else if (scm_is_eq (grammar, scm_sym_prefix))
432 gram = GRAM_PREFIX;
433 else
434 SCM_WRONG_TYPE_ARG (3, grammar);
435
f846bd1a
MG		 436 /* Check grammar constraints. */
437 if (strings == 0 && gram == GRAM_STRICT_INFIX)
438 SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
439 SCM_EOL);
63181a97 440
f846bd1a 441 result = scm_i_make_string (0, NULL);
63181a97
MV		 442
443 tmp = ls;
444 switch (gram)
445 {
446 case GRAM_INFIX:
447 case GRAM_STRICT_INFIX:
d2e53ed6 448 while (scm_is_pair (tmp))
63181a97 449 {
f846bd1a 450 result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
d2e53ed6 451 if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
f846bd1a 452 result = scm_string_append (scm_list_2 (result, delimiter));
63181a97
MV		 453 tmp = SCM_CDR (tmp);
454 }
455 break;
456 case GRAM_SUFFIX:
d2e53ed6 457 while (scm_is_pair (tmp))
63181a97 458 {
f846bd1a 459 result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
63181a97 460 if (del_len > 0)
f846bd1a 461 result = scm_string_append (scm_list_2 (result, delimiter));
63181a97
MV		 462 tmp = SCM_CDR (tmp);
463 }
464 break;
465 case GRAM_PREFIX:
d2e53ed6 466 while (scm_is_pair (tmp))
63181a97 467 {
63181a97 468 if (del_len > 0)
f846bd1a
MG		 469 result = scm_string_append (scm_list_2 (result, delimiter));
470 result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
63181a97
MV		 471 tmp = SCM_CDR (tmp);
472 }
473 break;
474 }
3731fc67 475
63181a97
MV		 476 return result;
477#undef GRAM_INFIX
478#undef GRAM_STRICT_INFIX
479#undef GRAM_SUFFIX
480#undef GRAM_PREFIX
481}
482#undef FUNC_NAME
483
484
485/* There are a number of functions to consider here for Scheme and C:
486
487 string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
488 substring/copy STR start [end] ;; Guile variant of R5RS substring
489
490 scm_string_copy (str) ;; Old function from Guile
491 scm_substring_copy (str, [start, [end]])
492 ;; C version of SRFI-13 string-copy
493 ;; and C version of substring/copy
494
495 The C function underlying string-copy is not exported to C
496 programs. scm_substring_copy is defined in strings.c as the
497 underlying function of substring/copy and allows an optional START
498 argument.
499*/
500
501SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end);
502
503SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0,
504 (SCM str, SCM start, SCM end),
505 "Return a freshly allocated copy of the string @var{str}. If\n"
506 "given, @var{start} and @var{end} delimit the portion of\n"
507 "@var{str} which is copied.")
508#define FUNC_NAME s_scm_srfi13_substring_copy
509{
63181a97
MV		 510 size_t cstart, cend;
511
f846bd1a
MG		 512 MY_VALIDATE_SUBSTRING_SPEC (1, str,
513 2, start, cstart,
514 3, end, cend);
515 return scm_i_substring_copy (str, cstart, cend);
63181a97
MV		 516}
517#undef FUNC_NAME
518
519SCM
520scm_string_copy (SCM str)
521{
f846bd1a
MG		 522 if (!scm_is_string (str))
523 scm_wrong_type_arg ("scm_string_copy", 0, str);
524
525 return scm_i_substring (str, 0, scm_i_string_length (str));
63181a97
MV		 526}
527
528SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
529 (SCM target, SCM tstart, SCM s, SCM start, SCM end),
530 "Copy the sequence of characters from index range [@var{start},\n"
531 "@var{end}) in string @var{s} to string @var{target}, beginning\n"
532 "at index @var{tstart}. The characters are copied left-to-right\n"
533 "or right-to-left as needed -- the copy is guaranteed to work,\n"
534 "even if @var{target} and @var{s} are the same string. It is an\n"
535 "error if the copy operation runs off the end of the target\n"
536 "string.")
537#define FUNC_NAME s_scm_string_copy_x
538{
f846bd1a 539 size_t cstart, cend, ctstart, dummy, len, i;
63181a97
MV		 540 SCM sdummy = SCM_UNDEFINED;
541
542 MY_VALIDATE_SUBSTRING_SPEC (1, target,
543 2, tstart, ctstart,
544 2, sdummy, dummy);
f846bd1a
MG		 545 MY_VALIDATE_SUBSTRING_SPEC (3, s,
546 4, start, cstart,
547 5, end, cend);
63181a97
MV		 548 len = cend - cstart;
549 SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
550
9c44cd45 551 target = scm_i_string_start_writing (target);
f846bd1a
MG		 552 for (i = 0; i < cend - cstart; i++)
553 {
554 scm_i_string_set_x (target, ctstart + i,
555 scm_i_string_ref (s, cstart + i));
556 }
63181a97 557 scm_i_string_stop_writing ();
3731fc67 558 scm_remember_upto_here_1 (target);
63181a97
MV		 559
560 return SCM_UNSPECIFIED;
561}
562#undef FUNC_NAME
563
564SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
565 (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
566 "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
567 "into @var{str2} beginning at position @var{start2}.\n"
568 "@var{str1} and @var{str2} can be the same string.")
569#define FUNC_NAME s_scm_substring_move_x
570{
571 return scm_string_copy_x (str2, start2, str1, start1, end1);
572}
573#undef FUNC_NAME
574
575SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
576 (SCM s, SCM n),
577 "Return the @var{n} first characters of @var{s}.")
578#define FUNC_NAME s_scm_string_take
579{
580 return scm_substring (s, SCM_INUM0, n);
581}
582#undef FUNC_NAME
583
584
585SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
586 (SCM s, SCM n),
587 "Return all but the first @var{n} characters of @var{s}.")
588#define FUNC_NAME s_scm_string_drop
589{
590 return scm_substring (s, n, SCM_UNDEFINED);
591}
592#undef FUNC_NAME
593
594
595SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
596 (SCM s, SCM n),
597 "Return the @var{n} last characters of @var{s}.")
598#define FUNC_NAME s_scm_string_take_right
599{
600 return scm_substring (s,
601 scm_difference (scm_string_length (s), n),
602 SCM_UNDEFINED);
603}
604#undef FUNC_NAME
605
606
607SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
608 (SCM s, SCM n),
609 "Return all but the last @var{n} characters of @var{s}.")
610#define FUNC_NAME s_scm_string_drop_right
611{
612 return scm_substring (s,
613 SCM_INUM0,
614 scm_difference (scm_string_length (s), n));
615}
616#undef FUNC_NAME
617
618
619SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
620 (SCM s, SCM len, SCM chr, SCM start, SCM end),
621 "Take that characters from @var{start} to @var{end} from the\n"
622 "string @var{s} and return a new string, right-padded by the\n"
623 "character @var{chr} to length @var{len}. If the resulting\n"
624 "string is longer than @var{len}, it is truncated on the right.")
625#define FUNC_NAME s_scm_string_pad
626{
63181a97
MV		 627 size_t cstart, cend, clen;
628
3731fc67
MV		 629 MY_VALIDATE_SUBSTRING_SPEC (1, s,
630 4, start, cstart,
631 5, end, cend);
63181a97
MV		 632 clen = scm_to_size_t (len);
633
634 if (SCM_UNBNDP (chr))
f846bd1a 635 chr = SCM_MAKE_CHAR (' ');
63181a97
MV		 636 else
637 {
638 SCM_VALIDATE_CHAR (3, chr);
63181a97
MV		 639 }
640 if (clen < (cend - cstart))
f846bd1a 641 return scm_i_substring (s, cend - clen, cend);
63181a97
MV		 642 else
643 {
644 SCM result;
f846bd1a
MG		 645 result = (scm_string_append
646 (scm_list_2 (scm_c_make_string (clen - (cend - cstart), chr),
647 scm_i_substring (s, cstart, cend))));
63181a97
MV		 648 return result;
649 }
650}
651#undef FUNC_NAME
652
653
654SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
655 (SCM s, SCM len, SCM chr, SCM start, SCM end),
656 "Take that characters from @var{start} to @var{end} from the\n"
657 "string @var{s} and return a new string, left-padded by the\n"
658 "character @var{chr} to length @var{len}. If the resulting\n"
659 "string is longer than @var{len}, it is truncated on the left.")
660#define FUNC_NAME s_scm_string_pad_right
661{
63181a97
MV		 662 size_t cstart, cend, clen;
663
3731fc67
MV		 664 MY_VALIDATE_SUBSTRING_SPEC (1, s,
665 4, start, cstart,
666 5, end, cend);
63181a97
MV		 667 clen = scm_to_size_t (len);
668
669 if (SCM_UNBNDP (chr))
f846bd1a 670 chr = SCM_MAKE_CHAR (' ');
63181a97
MV		 671 else
672 {
673 SCM_VALIDATE_CHAR (3, chr);
63181a97
MV		 674 }
675 if (clen < (cend - cstart))
f846bd1a 676 return scm_i_substring (s, cstart, cstart + clen);
63181a97
MV		 677 else
678 {
679 SCM result;
63181a97 680
f846bd1a
MG		 681 result = (scm_string_append
682 (scm_list_2 (scm_i_substring (s, cstart, cend),
683 scm_c_make_string (clen - (cend - cstart), chr))));
684
63181a97
MV		 685 return result;
686 }
687}
688#undef FUNC_NAME
689
690
691SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
692 (SCM s, SCM char_pred, SCM start, SCM end),
693 "Trim @var{s} by skipping over all characters on the left\n"
694 "that satisfy the parameter @var{char_pred}:\n"
695 "\n"
696 "@itemize @bullet\n"
697 "@item\n"
698 "if it is the character @var{ch}, characters equal to\n"
699 "@var{ch} are trimmed,\n"
700 "\n"
701 "@item\n"
702 "if it is a procedure @var{pred} characters that\n"
703 "satisfy @var{pred} are trimmed,\n"
704 "\n"
705 "@item\n"
706 "if it is a character set, characters in that set are trimmed.\n"
707 "@end itemize\n"
708 "\n"
709 "If called without a @var{char_pred} argument, all whitespace is\n"
710 "trimmed.")
711#define FUNC_NAME s_scm_string_trim
712{
63181a97
MV		 713 size_t cstart, cend;
714
f846bd1a
MG		 715 MY_VALIDATE_SUBSTRING_SPEC (1, s,
716 3, start, cstart,
717 4, end, cend);
63181a97
MV		 718 if (SCM_UNBNDP (char_pred))
719 {
720 while (cstart < cend)
721 {
f846bd1a 722 if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
63181a97
MV		 723 break;
724 cstart++;
725 }
726 }
727 else if (SCM_CHARP (char_pred))
728 {
63181a97
MV		 729 while (cstart < cend)
730 {
f846bd1a 731 if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
63181a97
MV		 732 break;
733 cstart++;
734 }
735 }
736 else if (SCM_CHARSETP (char_pred))
737 {
738 while (cstart < cend)
739 {
f846bd1a 740 if (!REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 741 break;
742 cstart++;
743 }
744 }
745 else
746 {
6c9e8a53
AW		 747 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
748 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 749
63181a97
MV		 750 while (cstart < cend)
751 {
752 SCM res;
753
6c9e8a53 754 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 755 if (scm_is_false (res))
756 break;
63181a97
MV		 757 cstart++;
758 }
759 }
f846bd1a 760 return scm_i_substring (s, cstart, cend);
63181a97
MV		 761}
762#undef FUNC_NAME
763
764
765SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
766 (SCM s, SCM char_pred, SCM start, SCM end),
f846bd1a 767 "Trim @var{s} by skipping over all characters on the right\n"
63181a97
MV		 768 "that satisfy the parameter @var{char_pred}:\n"
769 "\n"
770 "@itemize @bullet\n"
771 "@item\n"
772 "if it is the character @var{ch}, characters equal to @var{ch}\n"
773 "are trimmed,\n"
774 "\n"
775 "@item\n"
776 "if it is a procedure @var{pred} characters that satisfy\n"
777 "@var{pred} are trimmed,\n"
778 "\n"
779 "@item\n"
780 "if it is a character sets, all characters in that set are\n"
781 "trimmed.\n"
782 "@end itemize\n"
783 "\n"
784 "If called without a @var{char_pred} argument, all whitespace is\n"
785 "trimmed.")
786#define FUNC_NAME s_scm_string_trim_right
787{
616775ed 788 size_t cstart, cend;
63181a97 789
f846bd1a
MG		 790 MY_VALIDATE_SUBSTRING_SPEC (1, s,
791 3, start, cstart,
792 4, end, cend);
63181a97
MV		 793 if (SCM_UNBNDP (char_pred))
794 {
795 while (cstart < cend)
796 {
f846bd1a 797 if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
63181a97
MV		 798 break;
799 cend--;
800 }
801 }
802 else if (SCM_CHARP (char_pred))
803 {
63181a97
MV		 804 while (cstart < cend)
805 {
f846bd1a 806 if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
63181a97
MV		 807 break;
808 cend--;
809 }
810 }
811 else if (SCM_CHARSETP (char_pred))
812 {
813 while (cstart < cend)
814 {
f846bd1a 815 if (!REF_IN_CHARSET (s, cend-1, char_pred))
63181a97
MV		 816 break;
817 cend--;
818 }
819 }
820 else
821 {
6c9e8a53
AW		 822 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
823 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 824
63181a97
MV		 825 while (cstart < cend)
826 {
827 SCM res;
828
6c9e8a53 829 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
63181a97
MV		 830 if (scm_is_false (res))
831 break;
63181a97
MV		 832 cend--;
833 }
834 }
f846bd1a 835 return scm_i_substring (s, cstart, cend);
63181a97
MV		 836}
837#undef FUNC_NAME
838
839
840SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
841 (SCM s, SCM char_pred, SCM start, SCM end),
842 "Trim @var{s} by skipping over all characters on both sides of\n"
843 "the string that satisfy the parameter @var{char_pred}:\n"
844 "\n"
845 "@itemize @bullet\n"
846 "@item\n"
847 "if it is the character @var{ch}, characters equal to @var{ch}\n"
848 "are trimmed,\n"
849 "\n"
850 "@item\n"
851 "if it is a procedure @var{pred} characters that satisfy\n"
852 "@var{pred} are trimmed,\n"
853 "\n"
854 "@item\n"
855 "if it is a character set, the characters in the set are\n"
856 "trimmed.\n"
857 "@end itemize\n"
858 "\n"
859 "If called without a @var{char_pred} argument, all whitespace is\n"
860 "trimmed.")
861#define FUNC_NAME s_scm_string_trim_both
862{
63181a97
MV		 863 size_t cstart, cend;
864
f846bd1a
MG		 865 MY_VALIDATE_SUBSTRING_SPEC (1, s,
866 3, start, cstart,
867 4, end, cend);
63181a97
MV		 868 if (SCM_UNBNDP (char_pred))
869 {
870 while (cstart < cend)
871 {
f846bd1a 872 if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
63181a97
MV		 873 break;
874 cstart++;
875 }
876 while (cstart < cend)
877 {
f846bd1a 878 if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
63181a97
MV		 879 break;
880 cend--;
881 }
882 }
883 else if (SCM_CHARP (char_pred))
884 {
63181a97
MV		 885 while (cstart < cend)
886 {
f846bd1a 887 if (scm_i_string_ref (s, cstart) != SCM_CHAR(char_pred))
63181a97
MV		 888 break;
889 cstart++;
890 }
891 while (cstart < cend)
892 {
f846bd1a 893 if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
63181a97
MV		 894 break;
895 cend--;
896 }
897 }
898 else if (SCM_CHARSETP (char_pred))
899 {
900 while (cstart < cend)
901 {
f846bd1a 902 if (!REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 903 break;
904 cstart++;
905 }
906 while (cstart < cend)
907 {
f846bd1a 908 if (!REF_IN_CHARSET (s, cend-1, char_pred))
63181a97
MV		 909 break;
910 cend--;
911 }
912 }
913 else
914 {
6c9e8a53
AW		 915 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
916 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 917
63181a97
MV		 918 while (cstart < cend)
919 {
920 SCM res;
921
6c9e8a53 922 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 923 if (scm_is_false (res))
924 break;
63181a97
MV		 925 cstart++;
926 }
927 while (cstart < cend)
928 {
929 SCM res;
930
6c9e8a53 931 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
63181a97
MV		 932 if (scm_is_false (res))
933 break;
63181a97
MV		 934 cend--;
935 }
936 }
f846bd1a 937 return scm_i_substring (s, cstart, cend);
63181a97
MV		 938}
939#undef FUNC_NAME
940
941
942SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
943 (SCM str, SCM chr, SCM start, SCM end),
944 "Stores @var{chr} in every element of the given @var{str} and\n"
945 "returns an unspecified value.")
946#define FUNC_NAME s_scm_substring_fill_x
947{
63181a97 948 size_t cstart, cend;
63181a97
MV		 949 size_t k;
950
951 /* Older versions of Guile provided the function
952 scm_substring_fill_x with the following order of arguments:
953
954 str, start, end, chr
955
956 We accomodate this here by detecting such a usage and reordering
957 the arguments.
958 */
959 if (SCM_CHARP (end))
960 {
961 SCM tmp = end;
962 end = start;
963 start = chr;
964 chr = tmp;
965 }
966
967 MY_VALIDATE_SUBSTRING_SPEC (1, str,
968 3, start, cstart,
969 4, end, cend);
f846bd1a
MG		 970 SCM_VALIDATE_CHAR (2, chr);
971
63181a97 972
9c44cd45 973 str = scm_i_string_start_writing (str);
63181a97 974 for (k = cstart; k < cend; k++)
f846bd1a 975 scm_i_string_set_x (str, k, SCM_CHAR (chr));
63181a97 976 scm_i_string_stop_writing ();
3731fc67 977
63181a97
MV		 978 return SCM_UNSPECIFIED;
979}
980#undef FUNC_NAME
981
982SCM
983scm_string_fill_x (SCM str, SCM chr)
984{
985 return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED);
986}
987
988SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
989 (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
990 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
991 "mismatch index, depending upon whether @var{s1} is less than,\n"
992 "equal to, or greater than @var{s2}. The mismatch index is the\n"
993 "largest index @var{i} such that for every 0 <= @var{j} <\n"
994 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
995 "@var{i} is the first position that does not match.")
996#define FUNC_NAME s_scm_string_compare
997{
63181a97 998 size_t cstart1, cend1, cstart2, cend2;
3731fc67 999 SCM proc;
63181a97 1000
f846bd1a
MG		 1001 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1002 6, start1, cstart1,
1003 7, end1, cend1);
1004 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1005 8, start2, cstart2,
1006 9, end2, cend2);
63181a97
MV		 1007 SCM_VALIDATE_PROC (3, proc_lt);
1008 SCM_VALIDATE_PROC (4, proc_eq);
1009 SCM_VALIDATE_PROC (5, proc_gt);
1010
1011 while (cstart1 < cend1 && cstart2 < cend2)
1012 {
f846bd1a
MG		 1013 if (scm_i_string_ref (s1, cstart1)
1014 < scm_i_string_ref (s2, cstart2))
3731fc67
MV		 1015 {
1016 proc = proc_lt;
1017 goto ret;
1018 }
f846bd1a
MG		 1019 else if (scm_i_string_ref (s1, cstart1)
1020 > scm_i_string_ref (s2, cstart2))
3731fc67
MV		 1021 {
1022 proc = proc_gt;
1023 goto ret;
1024 }
63181a97
MV		 1025 cstart1++;
1026 cstart2++;
1027 }
1028 if (cstart1 < cend1)
3731fc67 1029 proc = proc_gt;
63181a97 1030 else if (cstart2 < cend2)
3731fc67 1031 proc = proc_lt;
63181a97 1032 else
3731fc67
MV		 1033 proc = proc_eq;
1034
1035 ret:
1036 scm_remember_upto_here_2 (s1, s2);
1037 return scm_call_1 (proc, scm_from_size_t (cstart1));
63181a97
MV		 1038}
1039#undef FUNC_NAME
1040
1041
1042SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
1043 (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
1044 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1045 "mismatch index, depending upon whether @var{s1} is less than,\n"
1046 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1047 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1048 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
f846bd1a
MG		 1049 "@var{i} is the first position where the lowercased letters \n"
1050 "do not match.\n")
63181a97
MV		 1051#define FUNC_NAME s_scm_string_compare_ci
1052{
63181a97 1053 size_t cstart1, cend1, cstart2, cend2;
3731fc67 1054 SCM proc;
63181a97 1055
f846bd1a
MG		 1056 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1057 6, start1, cstart1,
1058 7, end1, cend1);
1059 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1060 8, start2, cstart2,
1061 9, end2, cend2);
63181a97
MV		 1062 SCM_VALIDATE_PROC (3, proc_lt);
1063 SCM_VALIDATE_PROC (4, proc_eq);
1064 SCM_VALIDATE_PROC (5, proc_gt);
1065
1066 while (cstart1 < cend1 && cstart2 < cend2)
1067 {
f846bd1a
MG		 1068 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1069 < uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67
MV		 1070 {
1071 proc = proc_lt;
1072 goto ret;
1073 }
f846bd1a
MG		 1074 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1075 > uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67
MV		 1076 {
1077 proc = proc_gt;
1078 goto ret;
1079 }
63181a97
MV		 1080 cstart1++;
1081 cstart2++;
1082 }
3731fc67 1083
63181a97 1084 if (cstart1 < cend1)
3731fc67 1085 proc = proc_gt;
63181a97 1086 else if (cstart2 < cend2)
3731fc67 1087 proc = proc_lt;
63181a97 1088 else
3731fc67
MV		 1089 proc = proc_eq;
1090
1091 ret:
1092 scm_remember_upto_here (s1, s2);
1093 return scm_call_1 (proc, scm_from_size_t (cstart1));
63181a97
MV		 1094}
1095#undef FUNC_NAME
1096
f846bd1a
MG		 1097/* This function compares two substrings, S1 from START1 to END1 and
1098 S2 from START2 to END2, possibly case insensitively, and returns
4b1c3f0e
AW		 1099 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1100 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1101 longer, or equal. */
f846bd1a
MG		 1102static SCM
1103compare_strings (const char *fname, int case_insensitive,
1104 SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2,
4b1c3f0e 1105 SCM lessthan, SCM greaterthan, SCM shorter, SCM longer, SCM equal)
63181a97 1106{
63181a97 1107 size_t cstart1, cend1, cstart2, cend2;
f846bd1a
MG		 1108 SCM ret;
1109 scm_t_wchar a, b;
63181a97 1110
f846bd1a 1111 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 1, s1,
63181a97
MV		 1112 3, start1, cstart1,
1113 4, end1, cend1);
f846bd1a 1114 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 2, s2,
63181a97
MV		 1115 5, start2, cstart2,
1116 6, end2, cend2);
1117
f846bd1a 1118 while (cstart1 < cend1 && cstart2 < cend2)
63181a97 1119 {
f846bd1a
MG		 1120 if (case_insensitive)
1121 {
1122 a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
1123 b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
1124 }
1125 else
1126 {
1127 a = scm_i_string_ref (s1, cstart1);
1128 b = scm_i_string_ref (s2, cstart2);
1129 }
1130 if (a < b)
1131 {
1132 ret = lessthan;
1133 goto done;
1134 }
1135 else if (a > b)
1136 {
1137 ret = greaterthan;
1138 goto done;
1139 }
63181a97
MV		 1140 cstart1++;
1141 cstart2++;
1142 }
f846bd1a
MG		 1143 if (cstart1 < cend1)
1144 {
1145 ret = longer;
1146 goto done;
1147 }
1148 else if (cstart2 < cend2)
1149 {
1150 ret = shorter;
1151 goto done;
1152 }
1153 else
1154 {
1155 ret = equal;
1156 goto done;
1157 }
63181a97 1158
f846bd1a 1159 done:
63181a97 1160 scm_remember_upto_here_2 (s1, s2);
f846bd1a
MG		 1161 return ret;
1162}
1163
1164
1165SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
1166 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1167 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1168 "value otherwise.")
1169#define FUNC_NAME s_scm_string_eq
1170{
1171 return compare_strings (FUNC_NAME, 0,
1172 s1, s2, start1, end1, start2, end2,
1173 SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1174}
1175#undef FUNC_NAME
1176
1177
1178SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
1179 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1180 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1181 "value otherwise.")
1182#define FUNC_NAME s_scm_string_neq
1183{
f846bd1a
MG		 1184 return compare_strings (FUNC_NAME, 0,
1185 s1, s2, start1, end1, start2, end2,
1186 SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1187}
1188#undef FUNC_NAME
1189
1190
1191SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
1192 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1193 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1194 "true value otherwise.")
1195#define FUNC_NAME s_scm_string_lt
1196{
f846bd1a
MG		 1197 return compare_strings (FUNC_NAME, 0,
1198 s1, s2, start1, end1, start2, end2,
1199 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
63181a97
MV		 1200}
1201#undef FUNC_NAME
1202
1203
1204SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
1205 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1206 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1207 "true value otherwise.")
1208#define FUNC_NAME s_scm_string_gt
1209{
f846bd1a
MG		 1210 return compare_strings (FUNC_NAME, 0,
1211 s1, s2, start1, end1, start2, end2,
1212 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1213}
1214#undef FUNC_NAME
1215
1216
1217SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
1218 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1219 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1220 "value otherwise.")
1221#define FUNC_NAME s_scm_string_le
1222{
f846bd1a
MG		 1223 return compare_strings (FUNC_NAME, 0,
1224 s1, s2, start1, end1, start2, end2,
1225 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1226}
1227#undef FUNC_NAME
1228
1229
1230SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
1231 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1232 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1233 "otherwise.")
1234#define FUNC_NAME s_scm_string_ge
1235{
f846bd1a
MG		 1236 return compare_strings (FUNC_NAME, 0,
1237 s1, s2, start1, end1, start2, end2,
1238 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
63181a97
MV		 1239}
1240#undef FUNC_NAME
1241
1242
1243SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
1244 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1245 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1246 "value otherwise. The character comparison is done\n"
1247 "case-insensitively.")
1248#define FUNC_NAME s_scm_string_ci_eq
1249{
f846bd1a
MG		 1250 return compare_strings (FUNC_NAME, 1,
1251 s1, s2, start1, end1, start2, end2,
1252 SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1253}
1254#undef FUNC_NAME
1255
1256
1257SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
1258 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
f846bd1a
MG		 1259 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1260 "value otherwise. The character comparison is done\n"
1261 "case-insensitively.")
1262#define FUNC_NAME s_scm_string_ci_neq
1263{
1264 return compare_strings (FUNC_NAME, 1,
1265 s1, s2, start1, end1, start2, end2,
1266 SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1267}
1268#undef FUNC_NAME
1269
1270
1271SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
1272 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1273 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1274 "true value otherwise. The character comparison is done\n"
1275 "case-insensitively.")
1276#define FUNC_NAME s_scm_string_ci_lt
1277{
f846bd1a
MG		 1278 return compare_strings (FUNC_NAME, 1,
1279 s1, s2, start1, end1, start2, end2,
1280 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
63181a97
MV		 1281}
1282#undef FUNC_NAME
1283
1284
1285SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
1286 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1287 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1288 "true value otherwise. The character comparison is done\n"
1289 "case-insensitively.")
1290#define FUNC_NAME s_scm_string_ci_gt
1291{
f846bd1a
MG		 1292 return compare_strings (FUNC_NAME, 1,
1293 s1, s2, start1, end1, start2, end2,
1294 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1295}
1296#undef FUNC_NAME
1297
1298
1299SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
1300 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1301 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1302 "value otherwise. The character comparison is done\n"
1303 "case-insensitively.")
1304#define FUNC_NAME s_scm_string_ci_le
1305{
f846bd1a
MG		 1306 return compare_strings (FUNC_NAME, 1,
1307 s1, s2, start1, end1, start2, end2,
1308 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1309}
1310#undef FUNC_NAME
1311
1312
1313SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
1314 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1315 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1316 "otherwise. The character comparison is done\n"
1317 "case-insensitively.")
1318#define FUNC_NAME s_scm_string_ci_ge
1319{
f846bd1a
MG		 1320 return compare_strings (FUNC_NAME, 1,
1321 s1, s2, start1, end1, start2, end2,
1322 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
63181a97
MV		 1323}
1324#undef FUNC_NAME
1325
1326SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
1327 (SCM s, SCM bound, SCM start, SCM end),
1328 "Compute a hash value for @var{S}. the optional argument "
1329 "@var{bound} is a non-negative exact "
1330 "integer specifying the range of the hash function. "
1331 "A positive value restricts the return value to the "
1332 "range [0,bound).")
1333#define FUNC_NAME s_scm_substring_hash
1334{
1335 if (SCM_UNBNDP (bound))
1336 bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM);
1337 if (SCM_UNBNDP (start))
1338 start = SCM_INUM0;
1339 return scm_hash (scm_substring_shared (s, start, end), bound);
1340}
1341#undef FUNC_NAME
1342
1343SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
1344 (SCM s, SCM bound, SCM start, SCM end),
1345 "Compute a hash value for @var{S}. the optional argument "
1346 "@var{bound} is a non-negative exact "
1347 "integer specifying the range of the hash function. "
1348 "A positive value restricts the return value to the "
1349 "range [0,bound).")
1350#define FUNC_NAME s_scm_substring_hash_ci
1351{
1352 return scm_substring_hash (scm_substring_downcase (s, start, end),
1353 bound,
1354 SCM_UNDEFINED, SCM_UNDEFINED);
1355}
1356#undef FUNC_NAME
1357
1358SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
1359 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1360 "Return the length of the longest common prefix of the two\n"
1361 "strings.")
1362#define FUNC_NAME s_scm_string_prefix_length
1363{
63181a97
MV		 1364 size_t cstart1, cend1, cstart2, cend2;
1365 size_t len = 0;
1366
f846bd1a
MG		 1367 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1368 3, start1, cstart1,
1369 4, end1, cend1);
1370 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1371 5, start2, cstart2,
1372 6, end2, cend2);
1373
63181a97
MV		 1374 while (cstart1 < cend1 && cstart2 < cend2)
1375 {
f846bd1a
MG		 1376 if (scm_i_string_ref (s1, cstart1)
1377 != scm_i_string_ref (s2, cstart2))
3731fc67 1378 goto ret;
63181a97
MV		 1379 len++;
1380 cstart1++;
1381 cstart2++;
1382 }
3731fc67
MV		 1383
1384 ret:
1385 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1386 return scm_from_size_t (len);
1387}
1388#undef FUNC_NAME
1389
1390
1391SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
1392 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1393 "Return the length of the longest common prefix of the two\n"
1394 "strings, ignoring character case.")
1395#define FUNC_NAME s_scm_string_prefix_length_ci
1396{
63181a97
MV		 1397 size_t cstart1, cend1, cstart2, cend2;
1398 size_t len = 0;
1399
f846bd1a
MG		 1400 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1401 3, start1, cstart1,
1402 4, end1, cend1);
1403 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1404 5, start2, cstart2,
1405 6, end2, cend2);
63181a97
MV		 1406 while (cstart1 < cend1 && cstart2 < cend2)
1407 {
f846bd1a
MG		 1408 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1409 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67 1410 goto ret;
63181a97
MV		 1411 len++;
1412 cstart1++;
1413 cstart2++;
1414 }
3731fc67
MV		 1415
1416 ret:
1417 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1418 return scm_from_size_t (len);
1419}
1420#undef FUNC_NAME
1421
1422
1423SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
1424 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1425 "Return the length of the longest common suffix of the two\n"
1426 "strings.")
1427#define FUNC_NAME s_scm_string_suffix_length
1428{
63181a97
MV		 1429 size_t cstart1, cend1, cstart2, cend2;
1430 size_t len = 0;
1431
f846bd1a
MG		 1432 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1433 3, start1, cstart1,
1434 4, end1, cend1);
1435 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1436 5, start2, cstart2,
1437 6, end2, cend2);
63181a97
MV		 1438 while (cstart1 < cend1 && cstart2 < cend2)
1439 {
1440 cend1--;
1441 cend2--;
f846bd1a
MG		 1442 if (scm_i_string_ref (s1, cend1)
1443 != scm_i_string_ref (s2, cend2))
3731fc67 1444 goto ret;
63181a97
MV		 1445 len++;
1446 }
3731fc67
MV		 1447
1448 ret:
1449 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1450 return scm_from_size_t (len);
1451}
1452#undef FUNC_NAME
1453
1454
1455SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
1456 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1457 "Return the length of the longest common suffix of the two\n"
1458 "strings, ignoring character case.")
1459#define FUNC_NAME s_scm_string_suffix_length_ci
1460{
63181a97
MV		 1461 size_t cstart1, cend1, cstart2, cend2;
1462 size_t len = 0;
1463
f846bd1a
MG		 1464 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1465 3, start1, cstart1,
1466 4, end1, cend1);
1467 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1468 5, start2, cstart2,
1469 6, end2, cend2);
63181a97
MV		 1470 while (cstart1 < cend1 && cstart2 < cend2)
1471 {
1472 cend1--;
1473 cend2--;
f846bd1a
MG		 1474 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
1475 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
3731fc67 1476 goto ret;
63181a97
MV		 1477 len++;
1478 }
3731fc67
MV		 1479
1480 ret:
1481 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1482 return scm_from_size_t (len);
1483}
1484#undef FUNC_NAME
1485
1486
1487SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
1488 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1489 "Is @var{s1} a prefix of @var{s2}?")
1490#define FUNC_NAME s_scm_string_prefix_p
1491{
63181a97
MV		 1492 size_t cstart1, cend1, cstart2, cend2;
1493 size_t len = 0, len1;
1494
f846bd1a
MG		 1495 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1496 3, start1, cstart1,
1497 4, end1, cend1);
1498 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1499 5, start2, cstart2,
1500 6, end2, cend2);
63181a97
MV		 1501 len1 = cend1 - cstart1;
1502 while (cstart1 < cend1 && cstart2 < cend2)
1503 {
f846bd1a
MG		 1504 if (scm_i_string_ref (s1, cstart1)
1505 != scm_i_string_ref (s2, cstart2))
3731fc67 1506 goto ret;
63181a97
MV		 1507 len++;
1508 cstart1++;
1509 cstart2++;
1510 }
3731fc67
MV		 1511
1512 ret:
1513 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1514 return scm_from_bool (len == len1);
1515}
1516#undef FUNC_NAME
1517
1518
1519SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
1520 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1521 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1522#define FUNC_NAME s_scm_string_prefix_ci_p
1523{
63181a97
MV		 1524 size_t cstart1, cend1, cstart2, cend2;
1525 size_t len = 0, len1;
1526
f846bd1a
MG		 1527 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1528 3, start1, cstart1,
1529 4, end1, cend1);
1530 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1531 5, start2, cstart2,
1532 6, end2, cend2);
63181a97
MV		 1533 len1 = cend1 - cstart1;
1534 while (cstart1 < cend1 && cstart2 < cend2)
1535 {
f846bd1a
MG		 1536 scm_t_wchar a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
1537 scm_t_wchar b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
1538 if (a != b)
3731fc67 1539 goto ret;
63181a97
MV		 1540 len++;
1541 cstart1++;
1542 cstart2++;
1543 }
3731fc67
MV		 1544
1545 ret:
1546 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1547 return scm_from_bool (len == len1);
1548}
1549#undef FUNC_NAME
1550
1551
1552SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
1553 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1554 "Is @var{s1} a suffix of @var{s2}?")
1555#define FUNC_NAME s_scm_string_suffix_p
1556{
63181a97
MV		 1557 size_t cstart1, cend1, cstart2, cend2;
1558 size_t len = 0, len1;
1559
f846bd1a
MG		 1560 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1561 3, start1, cstart1,
1562 4, end1, cend1);
1563 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1564 5, start2, cstart2,
1565 6, end2, cend2);
63181a97
MV		 1566 len1 = cend1 - cstart1;
1567 while (cstart1 < cend1 && cstart2 < cend2)
1568 {
1569 cend1--;
1570 cend2--;
f846bd1a
MG		 1571 if (scm_i_string_ref (s1, cend1)
1572 != scm_i_string_ref (s2, cend2))
3731fc67 1573 goto ret;
63181a97
MV		 1574 len++;
1575 }
3731fc67
MV		 1576
1577 ret:
1578 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1579 return scm_from_bool (len == len1);
1580}
1581#undef FUNC_NAME
1582
1583
1584SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
1585 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1586 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1587#define FUNC_NAME s_scm_string_suffix_ci_p
1588{
63181a97
MV		 1589 size_t cstart1, cend1, cstart2, cend2;
1590 size_t len = 0, len1;
1591
f846bd1a
MG		 1592 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1593 3, start1, cstart1,
1594 4, end1, cend1);
1595 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1596 5, start2, cstart2,
1597 6, end2, cend2);
63181a97
MV		 1598 len1 = cend1 - cstart1;
1599 while (cstart1 < cend1 && cstart2 < cend2)
1600 {
1601 cend1--;
1602 cend2--;
f846bd1a
MG		 1603 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
1604 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
3731fc67 1605 goto ret;
63181a97
MV		 1606 len++;
1607 }
3731fc67
MV		 1608
1609 ret:
1610 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1611 return scm_from_bool (len == len1);
1612}
1613#undef FUNC_NAME
1614
1615
1616SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
1617 (SCM s, SCM char_pred, SCM start, SCM end),
1618 "Search through the string @var{s} from left to right, returning\n"
1619 "the index of the first occurence of a character which\n"
1620 "\n"
1621 "@itemize @bullet\n"
1622 "@item\n"
1623 "equals @var{char_pred}, if it is character,\n"
1624 "\n"
1625 "@item\n"
1626 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1627 "\n"
1628 "@item\n"
1629 "is in the set @var{char_pred}, if it is a character set.\n"
1630 "@end itemize")
1631#define FUNC_NAME s_scm_string_index
1632{
63181a97
MV		 1633 size_t cstart, cend;
1634
f846bd1a
MG		 1635 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1636 3, start, cstart,
1637 4, end, cend);
63181a97
MV		 1638 if (SCM_CHARP (char_pred))
1639 {
63181a97
MV		 1640 while (cstart < cend)
1641 {
f846bd1a 1642 if (scm_i_string_ref (s, cstart) == SCM_CHAR (char_pred))
3731fc67 1643 goto found;
63181a97
MV		 1644 cstart++;
1645 }
1646 }
1647 else if (SCM_CHARSETP (char_pred))
1648 {
1649 while (cstart < cend)
1650 {
f846bd1a 1651 if (REF_IN_CHARSET (s, cstart, char_pred))
3731fc67 1652 goto found;
63181a97
MV		 1653 cstart++;
1654 }
1655 }
1656 else
1657 {
6c9e8a53
AW		 1658 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1659 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1660
63181a97
MV		 1661 while (cstart < cend)
1662 {
1663 SCM res;
6c9e8a53 1664 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 1665 if (scm_is_true (res))
3731fc67 1666 goto found;
63181a97
MV		 1667 cstart++;
1668 }
1669 }
3731fc67
MV		 1670
1671 scm_remember_upto_here_1 (s);
63181a97 1672 return SCM_BOOL_F;
3731fc67
MV		 1673
1674 found:
1675 scm_remember_upto_here_1 (s);
1676 return scm_from_size_t (cstart);
63181a97
MV		 1677}
1678#undef FUNC_NAME
1679
1680SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
1681 (SCM s, SCM char_pred, SCM start, SCM end),
1682 "Search through the string @var{s} from right to left, returning\n"
1683 "the index of the last occurence of a character which\n"
1684 "\n"
1685 "@itemize @bullet\n"
1686 "@item\n"
1687 "equals @var{char_pred}, if it is character,\n"
1688 "\n"
1689 "@item\n"
1690 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1691 "\n"
1692 "@item\n"
1693 "is in the set if @var{char_pred} is a character set.\n"
1694 "@end itemize")
1695#define FUNC_NAME s_scm_string_index_right
1696{
63181a97
MV		 1697 size_t cstart, cend;
1698
f846bd1a
MG		 1699 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1700 3, start, cstart,
1701 4, end, cend);
63181a97
MV		 1702 if (SCM_CHARP (char_pred))
1703 {
63181a97
MV		 1704 while (cstart < cend)
1705 {
1706 cend--;
f846bd1a 1707 if (scm_i_string_ref (s, cend) == SCM_CHAR (char_pred))
3731fc67 1708 goto found;
63181a97
MV		 1709 }
1710 }
1711 else if (SCM_CHARSETP (char_pred))
1712 {
1713 while (cstart < cend)
1714 {
1715 cend--;
f846bd1a 1716 if (REF_IN_CHARSET (s, cend, char_pred))
3731fc67 1717 goto found;
63181a97
MV		 1718 }
1719 }
1720 else
1721 {
6c9e8a53
AW		 1722 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1723 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1724
63181a97
MV		 1725 while (cstart < cend)
1726 {
1727 SCM res;
1728 cend--;
6c9e8a53 1729 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
63181a97 1730 if (scm_is_true (res))
3731fc67 1731 goto found;
63181a97
MV		 1732 }
1733 }
3731fc67
MV		 1734
1735 scm_remember_upto_here_1 (s);
63181a97 1736 return SCM_BOOL_F;
3731fc67
MV		 1737
1738 found:
1739 scm_remember_upto_here_1 (s);
1740 return scm_from_size_t (cend);
63181a97
MV		 1741}
1742#undef FUNC_NAME
1743
2562032b
MV		 1744SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
1745 (SCM s, SCM char_pred, SCM start, SCM end),
1746 "Search through the string @var{s} from right to left, returning\n"
1747 "the index of the last occurence of a character which\n"
1748 "\n"
1749 "@itemize @bullet\n"
1750 "@item\n"
1751 "equals @var{char_pred}, if it is character,\n"
1752 "\n"
1753 "@item\n"
1754 "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
1755 "\n"
1756 "@item\n"
1757 "is in the set if @var{char_pred} is a character set.\n"
1758 "@end itemize")
3731fc67 1759#define FUNC_NAME s_scm_string_rindex
63181a97 1760{
2562032b 1761 return scm_string_index_right (s, char_pred, start, end);
63181a97 1762}
3731fc67 1763#undef FUNC_NAME
63181a97
MV		 1764
1765SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
1766 (SCM s, SCM char_pred, SCM start, SCM end),
1767 "Search through the string @var{s} from left to right, returning\n"
1768 "the index of the first occurence of a character which\n"
1769 "\n"
1770 "@itemize @bullet\n"
1771 "@item\n"
1772 "does not equal @var{char_pred}, if it is character,\n"
1773 "\n"
1774 "@item\n"
1775 "does not satisify the predicate @var{char_pred}, if it is a\n"
1776 "procedure,\n"
1777 "\n"
1778 "@item\n"
1779 "is not in the set if @var{char_pred} is a character set.\n"
1780 "@end itemize")
1781#define FUNC_NAME s_scm_string_skip
1782{
63181a97
MV		 1783 size_t cstart, cend;
1784
f846bd1a
MG		 1785 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1786 3, start, cstart,
1787 4, end, cend);
63181a97
MV		 1788 if (SCM_CHARP (char_pred))
1789 {
63181a97
MV		 1790 while (cstart < cend)
1791 {
f846bd1a 1792 if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
3731fc67 1793 goto found;
63181a97
MV		 1794 cstart++;
1795 }
1796 }
1797 else if (SCM_CHARSETP (char_pred))
1798 {
1799 while (cstart < cend)
1800 {
f846bd1a 1801 if (!REF_IN_CHARSET (s, cstart, char_pred))
3731fc67 1802 goto found;
63181a97
MV		 1803 cstart++;
1804 }
1805 }
1806 else
1807 {
6c9e8a53
AW		 1808 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1809 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1810
63181a97
MV		 1811 while (cstart < cend)
1812 {
1813 SCM res;
6c9e8a53 1814 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 1815 if (scm_is_false (res))
3731fc67 1816 goto found;
63181a97
MV		 1817 cstart++;
1818 }
1819 }
3731fc67
MV		 1820
1821 scm_remember_upto_here_1 (s);
63181a97 1822 return SCM_BOOL_F;
3731fc67
MV		 1823
1824 found:
1825 scm_remember_upto_here_1 (s);
1826 return scm_from_size_t (cstart);
63181a97
MV		 1827}
1828#undef FUNC_NAME
1829
1830
1831SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
1832 (SCM s, SCM char_pred, SCM start, SCM end),
1833 "Search through the string @var{s} from right to left, returning\n"
1834 "the index of the last occurence of a character which\n"
1835 "\n"
1836 "@itemize @bullet\n"
1837 "@item\n"
1838 "does not equal @var{char_pred}, if it is character,\n"
1839 "\n"
1840 "@item\n"
1841 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1842 "procedure,\n"
1843 "\n"
1844 "@item\n"
1845 "is not in the set if @var{char_pred} is a character set.\n"
1846 "@end itemize")
1847#define FUNC_NAME s_scm_string_skip_right
1848{
63181a97
MV		 1849 size_t cstart, cend;
1850
f846bd1a
MG		 1851 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1852 3, start, cstart,
1853 4, end, cend);
63181a97
MV		 1854 if (SCM_CHARP (char_pred))
1855 {
63181a97
MV		 1856 while (cstart < cend)
1857 {
1858 cend--;
f846bd1a 1859 if (scm_i_string_ref (s, cend) != SCM_CHAR (char_pred))
3731fc67 1860 goto found;
63181a97
MV		 1861 }
1862 }
1863 else if (SCM_CHARSETP (char_pred))
1864 {
1865 while (cstart < cend)
1866 {
1867 cend--;
f846bd1a 1868 if (!REF_IN_CHARSET (s, cend, char_pred))
3731fc67 1869 goto found;
63181a97
MV		 1870 }
1871 }
1872 else
1873 {
6c9e8a53
AW		 1874 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1875 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1876
63181a97
MV		 1877 while (cstart < cend)
1878 {
1879 SCM res;
1880 cend--;
6c9e8a53 1881 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
63181a97 1882 if (scm_is_false (res))
3731fc67 1883 goto found;
63181a97
MV		 1884 }
1885 }
3731fc67
MV		 1886
1887 scm_remember_upto_here_1 (s);
63181a97 1888 return SCM_BOOL_F;
3731fc67
MV		 1889
1890 found:
1891 scm_remember_upto_here_1 (s);
1892 return scm_from_size_t (cend);
1893
63181a97
MV		 1894}
1895#undef FUNC_NAME
1896
1897
1898SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
1899 (SCM s, SCM char_pred, SCM start, SCM end),
1900 "Return the count of the number of characters in the string\n"
1901 "@var{s} which\n"
1902 "\n"
1903 "@itemize @bullet\n"
1904 "@item\n"
1905 "equals @var{char_pred}, if it is character,\n"
1906 "\n"
1907 "@item\n"
1908 "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
1909 "\n"
1910 "@item\n"
1911 "is in the set @var{char_pred}, if it is a character set.\n"
1912 "@end itemize")
1913#define FUNC_NAME s_scm_string_count
1914{
63181a97
MV		 1915 size_t cstart, cend;
1916 size_t count = 0;
1917
f846bd1a
MG		 1918 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1919 3, start, cstart,
1920 4, end, cend);
63181a97
MV		 1921 if (SCM_CHARP (char_pred))
1922 {
63181a97
MV		 1923 while (cstart < cend)
1924 {
f846bd1a 1925 if (scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
63181a97
MV		 1926 count++;
1927 cstart++;
1928 }
1929 }
1930 else if (SCM_CHARSETP (char_pred))
1931 {
1932 while (cstart < cend)
1933 {
f846bd1a 1934 if (REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 1935 count++;
1936 cstart++;
1937 }
1938 }
1939 else
1940 {
6c9e8a53
AW		 1941 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1942 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1943
63181a97
MV		 1944 while (cstart < cend)
1945 {
1946 SCM res;
6c9e8a53 1947 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 1948 if (scm_is_true (res))
1949 count++;
63181a97
MV		 1950 cstart++;
1951 }
1952 }
3731fc67
MV		 1953
1954 scm_remember_upto_here_1 (s);
63181a97
MV		 1955 return scm_from_size_t (count);
1956}
1957#undef FUNC_NAME
1958
1959
1960/* FIXME::martin: This should definitely get implemented more
1961 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1962 implementation. */
1963SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
1964 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1965 "Does string @var{s1} contain string @var{s2}? Return the index\n"
1966 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
1967 "The optional start/end indices restrict the operation to the\n"
1968 "indicated substrings.")
1969#define FUNC_NAME s_scm_string_contains
1970{
63181a97
MV		 1971 size_t cstart1, cend1, cstart2, cend2;
1972 size_t len2, i, j;
1973
f846bd1a
MG		 1974 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1975 3, start1, cstart1,
1976 4, end1, cend1);
1977 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1978 5, start2, cstart2,
1979 6, end2, cend2);
63181a97 1980 len2 = cend2 - cstart2;
4a310f1c
MV		 1981 if (cend1 - cstart1 >= len2)
1982 while (cstart1 <= cend1 - len2)
1983 {
1984 i = cstart1;
1985 j = cstart2;
f846bd1a
MG		 1986 while (i < cend1
1987 && j < cend2
1988 && (scm_i_string_ref (s1, i)
1989 == scm_i_string_ref (s2, j)))
4a310f1c
MV		 1990 {
1991 i++;
1992 j++;
1993 }
1994 if (j == cend2)
1995 {
1996 scm_remember_upto_here_2 (s1, s2);
1997 return scm_from_size_t (cstart1);
1998 }
1999 cstart1++;
2000 }
3731fc67
MV		 2001
2002 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 2003 return SCM_BOOL_F;
2004}
2005#undef FUNC_NAME
2006
2007
2008/* FIXME::martin: This should definitely get implemented more
2009 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2010 implementation. */
2011SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
2012 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2013 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2014 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2015 "The optional start/end indices restrict the operation to the\n"
2016 "indicated substrings. Character comparison is done\n"
2017 "case-insensitively.")
2018#define FUNC_NAME s_scm_string_contains_ci
2019{
63181a97
MV		 2020 size_t cstart1, cend1, cstart2, cend2;
2021 size_t len2, i, j;
2022
f846bd1a
MG		 2023 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
2024 3, start1, cstart1,
2025 4, end1, cend1);
2026 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
2027 5, start2, cstart2,
2028 6, end2, cend2);
63181a97 2029 len2 = cend2 - cstart2;
4a310f1c
MV		 2030 if (cend1 - cstart1 >= len2)
2031 while (cstart1 <= cend1 - len2)
2032 {
2033 i = cstart1;
2034 j = cstart2;
f846bd1a
MG		 2035 while (i < cend1
2036 && j < cend2
2037 && (uc_tolower (uc_toupper (scm_i_string_ref (s1, i)))
2038 == uc_tolower (uc_toupper (scm_i_string_ref (s2, j)))))
4a310f1c
MV		 2039 {
2040 i++;
2041 j++;
2042 }
2043 if (j == cend2)
2044 {
2045 scm_remember_upto_here_2 (s1, s2);
2046 return scm_from_size_t (cstart1);
2047 }
2048 cstart1++;
2049 }
3731fc67
MV		 2050
2051 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 2052 return SCM_BOOL_F;
2053}
2054#undef FUNC_NAME
2055
2056
f846bd1a 2057/* Helper function for the string uppercase conversion functions. */
63181a97 2058static SCM
1a82a460 2059string_upcase_x (SCM v, size_t start, size_t end)
63181a97
MV		 2060{
2061 size_t k;
63181a97 2062
9c44cd45 2063 v = scm_i_string_start_writing (v);
63181a97 2064 for (k = start; k < end; ++k)
f846bd1a 2065 scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
63181a97 2066 scm_i_string_stop_writing ();
3731fc67 2067 scm_remember_upto_here_1 (v);
63181a97
MV		 2068
2069 return v;
2070}
2071
2072SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
2073 (SCM str, SCM start, SCM end),
2074 "Destructively upcase every character in @code{str}.\n"
2075 "\n"
2076 "@lisp\n"
2077 "(string-upcase! y)\n"
2078 "@result{} \"ARRDEFG\"\n"
2079 "y\n"
2080 "@result{} \"ARRDEFG\"\n"
2081 "@end lisp")
2082#define FUNC_NAME s_scm_substring_upcase_x
2083{
63181a97
MV		 2084 size_t cstart, cend;
2085
f846bd1a
MG		 2086 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2087 2, start, cstart,
2088 3, end, cend);
63181a97
MV		 2089 return string_upcase_x (str, cstart, cend);
2090}
2091#undef FUNC_NAME
2092
2093SCM
2094scm_string_upcase_x (SCM str)
2095{
2096 return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2097}
2098
2099SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
2100 (SCM str, SCM start, SCM end),
2101 "Upcase every character in @code{str}.")
2102#define FUNC_NAME s_scm_substring_upcase
2103{
63181a97
MV		 2104 size_t cstart, cend;
2105
f846bd1a
MG		 2106 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2107 2, start, cstart,
2108 3, end, cend);
63181a97
MV		 2109 return string_upcase_x (scm_string_copy (str), cstart, cend);
2110}
2111#undef FUNC_NAME
2112
2113SCM
2114scm_string_upcase (SCM str)
2115{
2116 return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2117}
2118
2119/* Helper function for the string lowercase conversion functions.
2120 * No argument checking is performed. */
2121static SCM
1a82a460 2122string_downcase_x (SCM v, size_t start, size_t end)
63181a97
MV		 2123{
2124 size_t k;
63181a97 2125
9c44cd45 2126 v = scm_i_string_start_writing (v);
63181a97 2127 for (k = start; k < end; ++k)
f846bd1a 2128 scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
63181a97 2129 scm_i_string_stop_writing ();
3731fc67 2130 scm_remember_upto_here_1 (v);
63181a97
MV		 2131
2132 return v;
2133}
2134
2135SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
2136 (SCM str, SCM start, SCM end),
2137 "Destructively downcase every character in @var{str}.\n"
2138 "\n"
2139 "@lisp\n"
2140 "y\n"
2141 "@result{} \"ARRDEFG\"\n"
2142 "(string-downcase! y)\n"
2143 "@result{} \"arrdefg\"\n"
2144 "y\n"
2145 "@result{} \"arrdefg\"\n"
2146 "@end lisp")
2147#define FUNC_NAME s_scm_substring_downcase_x
2148{
63181a97
MV		 2149 size_t cstart, cend;
2150
f846bd1a
MG		 2151 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2152 2, start, cstart,
2153 3, end, cend);
63181a97
MV		 2154 return string_downcase_x (str, cstart, cend);
2155}
2156#undef FUNC_NAME
2157
2158SCM
2159scm_string_downcase_x (SCM str)
2160{
2161 return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2162}
2163
2164SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
2165 (SCM str, SCM start, SCM end),
2166 "Downcase every character in @var{str}.")
2167#define FUNC_NAME s_scm_substring_downcase
2168{
63181a97
MV		 2169 size_t cstart, cend;
2170
f846bd1a
MG		 2171 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2172 2, start, cstart,
2173 3, end, cend);
63181a97
MV		 2174 return string_downcase_x (scm_string_copy (str), cstart, cend);
2175}
2176#undef FUNC_NAME
2177
2178SCM
2179scm_string_downcase (SCM str)
2180{
2181 return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2182}
2183
2184/* Helper function for the string capitalization functions.
2185 * No argument checking is performed. */
2186static SCM
1a82a460 2187string_titlecase_x (SCM str, size_t start, size_t end)
63181a97 2188{
f846bd1a 2189 SCM ch;
63181a97
MV		 2190 size_t i;
2191 int in_word = 0;
2192
9c44cd45 2193 str = scm_i_string_start_writing (str);
63181a97
MV		 2194 for(i = start; i < end; i++)
2195 {
f846bd1a
MG		 2196 ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
2197 if (scm_is_true (scm_char_alphabetic_p (ch)))
63181a97
MV		 2198 {
2199 if (!in_word)
2200 {
820f33aa 2201 scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
63181a97
MV		 2202 in_word = 1;
2203 }
2204 else
2205 {
f846bd1a 2206 scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
63181a97
MV		 2207 }
2208 }
2209 else
2210 in_word = 0;
2211 }
2212 scm_i_string_stop_writing ();
3731fc67 2213 scm_remember_upto_here_1 (str);
63181a97
MV		 2214
2215 return str;
2216}
2217
2218
2219SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
2220 (SCM str, SCM start, SCM end),
2221 "Destructively titlecase every first character in a word in\n"
2222 "@var{str}.")
2223#define FUNC_NAME s_scm_string_titlecase_x
2224{
63181a97
MV		 2225 size_t cstart, cend;
2226
f846bd1a
MG		 2227 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2228 2, start, cstart,
2229 3, end, cend);
63181a97
MV		 2230 return string_titlecase_x (str, cstart, cend);
2231}
2232#undef FUNC_NAME
2233
2234
2235SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
2236 (SCM str, SCM start, SCM end),
2237 "Titlecase every first character in a word in @var{str}.")
2238#define FUNC_NAME s_scm_string_titlecase
2239{
63181a97
MV		 2240 size_t cstart, cend;
2241
f846bd1a
MG		 2242 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2243 2, start, cstart,
2244 3, end, cend);
63181a97
MV		 2245 return string_titlecase_x (scm_string_copy (str), cstart, cend);
2246}
2247#undef FUNC_NAME
2248
63181a97
MV		 2249SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
2250 (SCM str),
2251 "Upcase the first character of every word in @var{str}\n"
2252 "destructively and return @var{str}.\n"
2253 "\n"
2254 "@lisp\n"
2255 "y @result{} \"hello world\"\n"
2256 "(string-capitalize! y) @result{} \"Hello World\"\n"
2257 "y @result{} \"Hello World\"\n"
2258 "@end lisp")
2259#define FUNC_NAME s_scm_string_capitalize_x
2260{
2261 return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2262}
2263#undef FUNC_NAME
2264
2265
2266SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
2267 (SCM str),
2268 "Return a freshly allocated string with the characters in\n"
2269 "@var{str}, where the first character of every word is\n"
2270 "capitalized.")
2271#define FUNC_NAME s_scm_string_capitalize
2272{
2273 return scm_string_capitalize_x (scm_string_copy (str));
2274}
2275#undef FUNC_NAME
2276
2277
2278/* Reverse the portion of @var{str} between str[cstart] (including)
2279 and str[cend] excluding. */
2280static void
f846bd1a 2281string_reverse_x (SCM str, size_t cstart, size_t cend)
63181a97 2282{
f846bd1a 2283 SCM tmp;
63181a97 2284
f846bd1a 2285 str = scm_i_string_start_writing (str);
1a82a460 2286 if (cend > 0)
63181a97 2287 {
63181a97 2288 cend--;
1a82a460
MV		 2289 while (cstart < cend)
2290 {
f846bd1a
MG		 2291 tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
2292 scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
2293 scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
1a82a460
MV		 2294 cstart++;
2295 cend--;
2296 }
63181a97 2297 }
f846bd1a 2298 scm_i_string_stop_writing ();
63181a97
MV		 2299}
2300
2301
2302SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
2303 (SCM str, SCM start, SCM end),
2304 "Reverse the string @var{str}. The optional arguments\n"
2305 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2306 "operate on.")
2307#define FUNC_NAME s_scm_string_reverse
2308{
63181a97
MV		 2309 size_t cstart, cend;
2310 SCM result;
2311
f846bd1a
MG		 2312 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2313 2, start, cstart,
2314 3, end, cend);
63181a97 2315 result = scm_string_copy (str);
f846bd1a 2316 string_reverse_x (result, cstart, cend);
3731fc67 2317 scm_remember_upto_here_1 (str);
63181a97
MV		 2318 return result;
2319}
2320#undef FUNC_NAME
2321
2322
2323SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
2324 (SCM str, SCM start, SCM end),
2325 "Reverse the string @var{str} in-place. The optional arguments\n"
2326 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2327 "operate on. The return value is unspecified.")
2328#define FUNC_NAME s_scm_string_reverse_x
2329{
63181a97
MV		 2330 size_t cstart, cend;
2331
2332 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2333 2, start, cstart,
2334 3, end, cend);
2335
f846bd1a 2336 string_reverse_x (str, cstart, cend);
63181a97
MV		 2337 scm_remember_upto_here_1 (str);
2338 return SCM_UNSPECIFIED;
2339}
2340#undef FUNC_NAME
2341
2342
2343SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
a003f3eb 2344 (SCM rest),
63181a97
MV		 2345 "Like @code{string-append}, but the result may share memory\n"
2346 "with the argument strings.")
2347#define FUNC_NAME s_scm_string_append_shared
2348{
a003f3eb
KR		 2349 /* If "rest" contains just one non-empty string, return that.
2350 If it's entirely empty strings, then return scm_nullstr.
2351 Otherwise use scm_string_concatenate. */
63181a97 2352
a003f3eb
KR		 2353 SCM ret = scm_nullstr;
2354 int seen_nonempty = 0;
2355 SCM l, s;
63181a97 2356
a003f3eb
KR		 2357 SCM_VALIDATE_REST_ARGUMENT (rest);
2358
2359 for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
2360 {
2361 s = SCM_CAR (l);
f846bd1a
MG		 2362 if (!scm_is_string (s))
2363 scm_wrong_type_arg (FUNC_NAME, 0, s);
2364 if (scm_i_string_length (s) != 0)
a003f3eb
KR		 2365 {
2366 if (seen_nonempty)
2367 /* two or more non-empty strings, need full concat */
2368 return scm_string_append (rest);
2369
2370 seen_nonempty = 1;
2371 ret = s;
2372 }
2373 }
2374 return ret;
63181a97
MV		 2375}
2376#undef FUNC_NAME
2377
2378
2379SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
2380 (SCM ls),
2381 "Append the elements of @var{ls} (which must be strings)\n"
2382 "together into a single string. Guaranteed to return a freshly\n"
2383 "allocated string.")
2384#define FUNC_NAME s_scm_string_concatenate
2385{
57d98034 2386 SCM_VALIDATE_LIST (SCM_ARG1, ls);
63181a97
MV		 2387 return scm_string_append (ls);
2388}
2389#undef FUNC_NAME
2390
2391
2392SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
2393 (SCM ls, SCM final_string, SCM end),
2394 "Without optional arguments, this procedure is equivalent to\n"
2395 "\n"
2396 "@smalllisp\n"
2397 "(string-concatenate (reverse ls))\n"
2398 "@end smalllisp\n"
2399 "\n"
2400 "If the optional argument @var{final_string} is specified, it is\n"
2401 "consed onto the beginning to @var{ls} before performing the\n"
2402 "list-reverse and string-concatenate operations. If @var{end}\n"
2403 "is given, only the characters of @var{final_string} up to index\n"
2404 "@var{end} are used.\n"
2405 "\n"
2406 "Guaranteed to return a freshly allocated string.")
2407#define FUNC_NAME s_scm_string_concatenate_reverse
2408{
3731fc67
MV		 2409 if (!SCM_UNBNDP (end))
2410 final_string = scm_substring (final_string, SCM_INUM0, end);
63181a97 2411
63181a97 2412 if (!SCM_UNBNDP (final_string))
3731fc67 2413 ls = scm_cons (final_string, ls);
63181a97 2414
3731fc67 2415 return scm_string_concatenate (scm_reverse (ls));
63181a97
MV		 2416}
2417#undef FUNC_NAME
2418
2419
2420SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
2421 (SCM ls),
2422 "Like @code{string-concatenate}, but the result may share memory\n"
2423 "with the strings in the list @var{ls}.")
2424#define FUNC_NAME s_scm_string_concatenate_shared
2425{
57d98034 2426 SCM_VALIDATE_LIST (SCM_ARG1, ls);
63181a97
MV		 2427 return scm_string_append_shared (ls);
2428}
2429#undef FUNC_NAME
2430
2431
2432SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
2433 (SCM ls, SCM final_string, SCM end),
2434 "Like @code{string-concatenate-reverse}, but the result may\n"
2435 "share memory with the the strings in the @var{ls} arguments.")
2436#define FUNC_NAME s_scm_string_concatenate_reverse_shared
2437{
2438 /* Just call the non-sharing version. */
2439 return scm_string_concatenate_reverse (ls, final_string, end);
2440}
2441#undef FUNC_NAME
2442
2443
2444SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
2445 (SCM proc, SCM s, SCM start, SCM end),
2446 "@var{proc} is a char->char procedure, it is mapped over\n"
2447 "@var{s}. The order in which the procedure is applied to the\n"
2448 "string elements is not specified.")
2449#define FUNC_NAME s_scm_string_map
2450{
f846bd1a 2451 size_t p;
63181a97
MV		 2452 size_t cstart, cend;
2453 SCM result;
2454
6c9e8a53
AW		 2455 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2456 proc, SCM_ARG1, FUNC_NAME);
3731fc67
MV		 2457 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2458 3, start, cstart,
2459 4, end, cend);
f846bd1a
MG		 2460 result = scm_i_make_string (cend - cstart, NULL);
2461 p = 0;
63181a97
MV		 2462 while (cstart < cend)
2463 {
6c9e8a53 2464 SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
63181a97
MV		 2465 if (!SCM_CHARP (ch))
2466 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
63181a97 2467 cstart++;
f846bd1a
MG		 2468 result = scm_i_string_start_writing (result);
2469 scm_i_string_set_x (result, p, SCM_CHAR (ch));
2470 scm_i_string_stop_writing ();
2471 p++;
63181a97 2472 }
f846bd1a 2473
63181a97
MV		 2474 return result;
2475}
2476#undef FUNC_NAME
2477
2478
2479SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
2480 (SCM proc, SCM s, SCM start, SCM end),
2481 "@var{proc} is a char->char procedure, it is mapped over\n"
2482 "@var{s}. The order in which the procedure is applied to the\n"
2483 "string elements is not specified. The string @var{s} is\n"
2484 "modified in-place, the return value is not specified.")
2485#define FUNC_NAME s_scm_string_map_x
2486{
2487 size_t cstart, cend;
2488
6c9e8a53
AW		 2489 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2490 proc, SCM_ARG1, FUNC_NAME);
63181a97
MV		 2491 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2492 3, start, cstart,
2493 4, end, cend);
2494 while (cstart < cend)
2495 {
6c9e8a53 2496 SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
63181a97
MV		 2497 if (!SCM_CHARP (ch))
2498 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
f846bd1a
MG		 2499 s = scm_i_string_start_writing (s);
2500 scm_i_string_set_x (s, cstart, SCM_CHAR (ch));
2501 scm_i_string_stop_writing ();
63181a97
MV		 2502 cstart++;
2503 }
2504 return SCM_UNSPECIFIED;
2505}
2506#undef FUNC_NAME
2507
2508
2509SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
2510 (SCM kons, SCM knil, SCM s, SCM start, SCM end),
2511 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2512 "as the terminating element, from left to right. @var{kons}\n"
2513 "must expect two arguments: The actual character and the last\n"
2514 "result of @var{kons}' application.")
2515#define FUNC_NAME s_scm_string_fold
2516{
63181a97
MV		 2517 size_t cstart, cend;
2518 SCM result;
2519
2520 SCM_VALIDATE_PROC (1, kons);
f846bd1a
MG		 2521 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2522 4, start, cstart,
2523 5, end, cend);
63181a97
MV		 2524 result = knil;
2525 while (cstart < cend)
2526 {
f846bd1a 2527 result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result);
63181a97
MV		 2528 cstart++;
2529 }
3731fc67
MV		 2530
2531 scm_remember_upto_here_1 (s);
63181a97
MV		 2532 return result;
2533}
2534#undef FUNC_NAME
2535
2536
2537SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
2538 (SCM kons, SCM knil, SCM s, SCM start, SCM end),
2539 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2540 "as the terminating element, from right to left. @var{kons}\n"
2541 "must expect two arguments: The actual character and the last\n"
2542 "result of @var{kons}' application.")
2543#define FUNC_NAME s_scm_string_fold_right
2544{
63181a97
MV		 2545 size_t cstart, cend;
2546 SCM result;
2547
2548 SCM_VALIDATE_PROC (1, kons);
f846bd1a
MG		 2549 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2550 4, start, cstart,
2551 5, end, cend);
63181a97
MV		 2552 result = knil;
2553 while (cstart < cend)
2554 {
f846bd1a 2555 result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result);
63181a97
MV		 2556 cend--;
2557 }
3731fc67
MV		 2558
2559 scm_remember_upto_here_1 (s);
63181a97
MV		 2560 return result;
2561}
2562#undef FUNC_NAME
2563
2564
2565SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
2566 (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2567 "@itemize @bullet\n"
2568 "@item @var{g} is used to generate a series of @emph{seed}\n"
2569 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2570 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2571 "@dots{}\n"
2572 "@item @var{p} tells us when to stop -- when it returns true\n"
2573 "when applied to one of these seed values.\n"
2574 "@item @var{f} maps each seed value to the corresponding\n"
2575 "character in the result string. These chars are assembled\n"
2576 "into the string in a left-to-right order.\n"
2577 "@item @var{base} is the optional initial/leftmost portion\n"
2578 "of the constructed string; it default to the empty\n"
2579 "string.\n"
2580 "@item @var{make_final} is applied to the terminal seed\n"
2581 "value (on which @var{p} returns true) to produce\n"
2582 "the final/rightmost portion of the constructed string.\n"
2583 "It defaults to @code{(lambda (x) "")}.\n"
2584 "@end itemize")
2585#define FUNC_NAME s_scm_string_unfold
2586{
2587 SCM res, ans;
2588
2589 SCM_VALIDATE_PROC (1, p);
2590 SCM_VALIDATE_PROC (2, f);
2591 SCM_VALIDATE_PROC (3, g);
2592 if (!SCM_UNBNDP (base))
2593 {
2594 SCM_VALIDATE_STRING (5, base);
2595 ans = base;
2596 }
2597 else
2598 ans = scm_i_make_string (0, NULL);
2599 if (!SCM_UNBNDP (make_final))
2600 SCM_VALIDATE_PROC (6, make_final);
2601
2602 res = scm_call_1 (p, seed);
2603 while (scm_is_false (res))
2604 {
2605 SCM str;
f846bd1a 2606 size_t i = 0;
63181a97
MV		 2607 SCM ch = scm_call_1 (f, seed);
2608 if (!SCM_CHARP (ch))
2609 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
f846bd1a
MG		 2610 str = scm_i_make_string (1, NULL);
2611 str = scm_i_string_start_writing (str);
2612 scm_i_string_set_x (str, i, SCM_CHAR (ch));
2613 scm_i_string_stop_writing ();
2614 i++;
63181a97
MV		 2615
2616 ans = scm_string_append (scm_list_2 (ans, str));
2617 seed = scm_call_1 (g, seed);
2618 res = scm_call_1 (p, seed);
2619 }
2620 if (!SCM_UNBNDP (make_final))
2621 {
2622 res = scm_call_1 (make_final, seed);
2623 return scm_string_append (scm_list_2 (ans, res));
2624 }
2625 else
2626 return ans;
2627}
2628#undef FUNC_NAME
2629
2630
2631SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
2632 (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2633 "@itemize @bullet\n"
2634 "@item @var{g} is used to generate a series of @emph{seed}\n"
2635 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2636 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2637 "@dots{}\n"
2638 "@item @var{p} tells us when to stop -- when it returns true\n"
2639 "when applied to one of these seed values.\n"
2640 "@item @var{f} maps each seed value to the corresponding\n"
2641 "character in the result string. These chars are assembled\n"
2642 "into the string in a right-to-left order.\n"
2643 "@item @var{base} is the optional initial/rightmost portion\n"
2644 "of the constructed string; it default to the empty\n"
2645 "string.\n"
2646 "@item @var{make_final} is applied to the terminal seed\n"
2647 "value (on which @var{p} returns true) to produce\n"
2648 "the final/leftmost portion of the constructed string.\n"
2649 "It defaults to @code{(lambda (x) "")}.\n"
2650 "@end itemize")
2651#define FUNC_NAME s_scm_string_unfold_right
2652{
2653 SCM res, ans;
2654
2655 SCM_VALIDATE_PROC (1, p);
2656 SCM_VALIDATE_PROC (2, f);
2657 SCM_VALIDATE_PROC (3, g);
2658 if (!SCM_UNBNDP (base))
2659 {
2660 SCM_VALIDATE_STRING (5, base);
2661 ans = base;
2662 }
2663 else
2664 ans = scm_i_make_string (0, NULL);
2665 if (!SCM_UNBNDP (make_final))
2666 SCM_VALIDATE_PROC (6, make_final);
2667
2668 res = scm_call_1 (p, seed);
2669 while (scm_is_false (res))
2670 {
2671 SCM str;
f846bd1a 2672 size_t i = 0;
63181a97
MV		 2673 SCM ch = scm_call_1 (f, seed);
2674 if (!SCM_CHARP (ch))
2675 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
f846bd1a
MG		 2676 str = scm_i_make_string (1, NULL);
2677 str = scm_i_string_start_writing (str);
2678 scm_i_string_set_x (str, i, SCM_CHAR (ch));
2679 scm_i_string_stop_writing ();
2680 i++;
63181a97
MV		 2681
2682 ans = scm_string_append (scm_list_2 (str, ans));
2683 seed = scm_call_1 (g, seed);
2684 res = scm_call_1 (p, seed);
2685 }
2686 if (!SCM_UNBNDP (make_final))
2687 {
2688 res = scm_call_1 (make_final, seed);
2689 return scm_string_append (scm_list_2 (res, ans));
2690 }
2691 else
2692 return ans;
2693}
2694#undef FUNC_NAME
2695
2696
2697SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
2698 (SCM proc, SCM s, SCM start, SCM end),
2699 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2700 "return value is not specified.")
2701#define FUNC_NAME s_scm_string_for_each
2702{
63181a97
MV		 2703 size_t cstart, cend;
2704
6c9e8a53
AW		 2705 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2706 proc, SCM_ARG1, FUNC_NAME);
9c44cd45
MG		 2707 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2708 3, start, cstart,
2709 4, end, cend);
63181a97
MV		 2710 while (cstart < cend)
2711 {
6c9e8a53 2712 scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 2713 cstart++;
2714 }
3731fc67
MV		 2715
2716 scm_remember_upto_here_1 (s);
63181a97
MV		 2717 return SCM_UNSPECIFIED;
2718}
2719#undef FUNC_NAME
2720
2721SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
2722 (SCM proc, SCM s, SCM start, SCM end),
1729055b
KR		 2723 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2724 "left to right.\n"
2725 "\n"
2726 "For example, to change characters to alternately upper and\n"
2727 "lower case,\n"
2728 "\n"
2729 "@example\n"
2730 "(define str (string-copy \"studly\"))\n"
2731 "(string-for-each-index\n"
2732 " (lambda (i)\n"
2733 " (string-set! str i\n"
2734 " ((if (even? i) char-upcase char-downcase)\n"
2735 " (string-ref str i))))\n"
2736 " str)\n"
2737 "str @result{} \"StUdLy\"\n"
2738 "@end example")
63181a97
MV		 2739#define FUNC_NAME s_scm_string_for_each_index
2740{
63181a97
MV		 2741 size_t cstart, cend;
2742
6c9e8a53
AW		 2743 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2744 proc, SCM_ARG1, FUNC_NAME);
3731fc67
MV		 2745 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2746 3, start, cstart,
2747 4, end, cend);
2748
63181a97
MV		 2749 while (cstart < cend)
2750 {
6c9e8a53 2751 scm_call_1 (proc, scm_from_size_t (cstart));
63181a97
MV		 2752 cstart++;
2753 }
3731fc67
MV		 2754
2755 scm_remember_upto_here_1 (s);
63181a97
MV		 2756 return SCM_UNSPECIFIED;
2757}
2758#undef FUNC_NAME
2759
2760SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
2761 (SCM s, SCM from, SCM to, SCM start, SCM end),
2762 "This is the @emph{extended substring} procedure that implements\n"
2763 "replicated copying of a substring of some string.\n"
2764 "\n"
2765 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2766 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2767 "0 and the length of @var{s}. Replicate this substring up and\n"
2768 "down index space, in both the positive and negative directions.\n"
2769 "@code{xsubstring} returns the substring of this string\n"
2770 "beginning at index @var{from}, and ending at @var{to}, which\n"
2771 "defaults to @var{from} + (@var{end} - @var{start}).")
2772#define FUNC_NAME s_scm_xsubstring
2773{
f846bd1a 2774 size_t p;
1a82a460
MV		 2775 size_t cstart, cend;
2776 int cfrom, cto;
63181a97
MV		 2777 SCM result;
2778
3731fc67
MV		 2779 MY_VALIDATE_SUBSTRING_SPEC (1, s,
2780 4, start, cstart,
2781 5, end, cend);
2782
1a82a460 2783 cfrom = scm_to_int (from);
63181a97
MV		 2784 if (SCM_UNBNDP (to))
2785 cto = cfrom + (cend - cstart);
2786 else
1a82a460 2787 cto = scm_to_int (to);
63181a97
MV		 2788 if (cstart == cend && cfrom != cto)
2789 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
2790
f846bd1a
MG		 2791 result = scm_i_make_string (cto - cfrom, NULL);
2792 result = scm_i_string_start_writing (result);
63181a97 2793
f846bd1a 2794 p = 0;
63181a97
MV		 2795 while (cfrom < cto)
2796 {
1a82a460 2797 size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
63181a97 2798 if (cfrom < 0)
f846bd1a
MG		 2799 scm_i_string_set_x (result, p,
2800 scm_i_string_ref (s, (cend - cstart) - t));
63181a97 2801 else
f846bd1a 2802 scm_i_string_set_x (result, p, scm_i_string_ref (s, t));
63181a97
MV		 2803 cfrom++;
2804 p++;
2805 }
f846bd1a 2806 scm_i_string_stop_writing ();
3731fc67 2807
63181a97
MV		 2808 scm_remember_upto_here_1 (s);
2809 return result;
2810}
2811#undef FUNC_NAME
2812
2813
2814SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
2815 (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
2816 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2817 "is written into the string @var{target} starting at index\n"
2818 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2819 "@var{target} @var{s})} or these arguments share storage -- you\n"
2820 "cannot copy a string on top of itself.")
2821#define FUNC_NAME s_scm_string_xcopy_x
2822{
f846bd1a 2823 size_t p;
1a82a460
MV		 2824 size_t ctstart, cstart, cend;
2825 int csfrom, csto;
63181a97 2826 SCM dummy = SCM_UNDEFINED;
616775ed 2827 size_t cdummy;
63181a97
MV		 2828
2829 MY_VALIDATE_SUBSTRING_SPEC (1, target,
2830 2, tstart, ctstart,
2831 2, dummy, cdummy);
3731fc67
MV		 2832 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2833 6, start, cstart,
2834 7, end, cend);
1a82a460 2835 csfrom = scm_to_int (sfrom);
63181a97
MV		 2836 if (SCM_UNBNDP (sto))
2837 csto = csfrom + (cend - cstart);
2838 else
1a82a460 2839 csto = scm_to_int (sto);
63181a97
MV		 2840 if (cstart == cend && csfrom != csto)
2841 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
2842 SCM_ASSERT_RANGE (1, tstart,
2843 ctstart + (csto - csfrom) <= scm_i_string_length (target));
2844
f846bd1a 2845 p = 0;
9c44cd45 2846 target = scm_i_string_start_writing (target);
63181a97
MV		 2847 while (csfrom < csto)
2848 {
1a82a460 2849 size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
63181a97 2850 if (csfrom < 0)
f846bd1a 2851 scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
63181a97 2852 else
f846bd1a 2853 scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
63181a97
MV		 2854 csfrom++;
2855 p++;
2856 }
2857 scm_i_string_stop_writing ();
2858
2859 scm_remember_upto_here_2 (target, s);
2860 return SCM_UNSPECIFIED;
2861}
2862#undef FUNC_NAME
2863
2864
2865SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
2866 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2867 "Return the string @var{s1}, but with the characters\n"
2868 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2869 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2870#define FUNC_NAME s_scm_string_replace
2871{
63181a97
MV		 2872 size_t cstart1, cend1, cstart2, cend2;
2873 SCM result;
2874
3731fc67
MV		 2875 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
2876 3, start1, cstart1,
2877 4, end1, cend1);
2878 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
2879 5, start2, cstart2,
2880 6, end2, cend2);
f846bd1a
MG		 2881 return (scm_string_append
2882 (scm_list_3 (scm_i_substring (s1, 0, cstart1),
2883 scm_i_substring (s2, cstart2, cend2),
2884 scm_i_substring (s1, cend1, scm_i_string_length (s1)))));
63181a97
MV		 2885 return result;
2886}
2887#undef FUNC_NAME
2888
2889
2890SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
2891 (SCM s, SCM token_set, SCM start, SCM end),
2892 "Split the string @var{s} into a list of substrings, where each\n"
2893 "substring is a maximal non-empty contiguous sequence of\n"
2894 "characters from the character set @var{token_set}, which\n"
2895 "defaults to @code{char-set:graphic}.\n"
2896 "If @var{start} or @var{end} indices are provided, they restrict\n"
2897 "@code{string-tokenize} to operating on the indicated substring\n"
2898 "of @var{s}.")
2899#define FUNC_NAME s_scm_string_tokenize
2900{
63181a97
MV		 2901 size_t cstart, cend;
2902 SCM result = SCM_EOL;
2903
f846bd1a
MG		 2904 MY_VALIDATE_SUBSTRING_SPEC (1, s,
2905 3, start, cstart,
2906 4, end, cend);
63181a97
MV		 2907
2908 if (SCM_UNBNDP (token_set))
2909 token_set = scm_char_set_graphic;
2910
2911 if (SCM_CHARSETP (token_set))
2912 {
1a82a460 2913 size_t idx;
63181a97
MV		 2914
2915 while (cstart < cend)
2916 {
2917 while (cstart < cend)
2918 {
f846bd1a 2919 if (REF_IN_CHARSET (s, cend-1, token_set))
63181a97
MV		 2920 break;
2921 cend--;
2922 }
2923 if (cstart >= cend)
2924 break;
2925 idx = cend;
2926 while (cstart < cend)
2927 {
f846bd1a 2928 if (!REF_IN_CHARSET (s, cend-1, token_set))
63181a97
MV		 2929 break;
2930 cend--;
2931 }
f846bd1a 2932 result = scm_cons (scm_i_substring (s, cend, idx), result);
63181a97
MV		 2933 }
2934 }
3731fc67
MV		 2935 else
2936 SCM_WRONG_TYPE_ARG (2, token_set);
2937
63181a97
MV		 2938 scm_remember_upto_here_1 (s);
2939 return result;
2940}
2941#undef FUNC_NAME
2942
2943SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
2944 (SCM str, SCM chr),
2945 "Split the string @var{str} into the a list of the substrings delimited\n"
2946 "by appearances of the character @var{chr}. Note that an empty substring\n"
2947 "between separator characters will result in an empty string in the\n"
2948 "result list.\n"
2949 "\n"
2950 "@lisp\n"
2951 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
2952 "@result{}\n"
2953 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
2954 "\n"
2955 "(string-split \"::\" #\\:)\n"
2956 "@result{}\n"
2957 "(\"\" \"\" \"\")\n"
2958 "\n"
2959 "(string-split \"\" #\\:)\n"
2960 "@result{}\n"
2961 "(\"\")\n"
2962 "@end lisp")
2963#define FUNC_NAME s_scm_string_split
2964{
2965 long idx, last_idx;
f846bd1a 2966 int narrow;
63181a97
MV		 2967 SCM res = SCM_EOL;
2968
2969 SCM_VALIDATE_STRING (1, str);
2970 SCM_VALIDATE_CHAR (2, chr);
f846bd1a
MG		 2971
2972 /* This is explicit wide/narrow logic (instead of using
2973 scm_i_string_ref) is a speed optimization. */
63181a97 2974 idx = scm_i_string_length (str);
f846bd1a
MG		 2975 narrow = scm_i_is_narrow_string (str);
2976 if (narrow)
2977 {
2978 const char *buf = scm_i_string_chars (str);
2979 while (idx >= 0)
2980 {
2981 last_idx = idx;
2982 while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
2983 idx--;
2984 if (idx >= 0)
2985 {
2986 res = scm_cons (scm_i_substring (str, idx, last_idx), res);
2987 idx--;
2988 }
2989 }
2990 }
2991 else
2992 {
2993 const scm_t_wchar *buf = scm_i_string_wide_chars (str);
2994 while (idx >= 0)
2995 {
2996 last_idx = idx;
2997 while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
2998 idx--;
2999 if (idx >= 0)
3000 {
3001 res = scm_cons (scm_i_substring (str, idx, last_idx), res);
3002 idx--;
3003 }
3004 }
63181a97
MV		 3005 }
3006 scm_remember_upto_here_1 (str);
3007 return res;
3008}
3009#undef FUNC_NAME
3010
3011
3012SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
3013 (SCM s, SCM char_pred, SCM start, SCM end),
8753a993 3014 "Filter the string @var{s}, retaining only those characters\n"
85912343 3015 "which satisfy @var{char_pred}.\n"
8753a993
KR		 3016 "\n"
3017 "If @var{char_pred} is a procedure, it is applied to each\n"
3018 "character as a predicate, if it is a character, it is tested\n"
3019 "for equality and if it is a character set, it is tested for\n"
3020 "membership.")
63181a97
MV		 3021#define FUNC_NAME s_scm_string_filter
3022{
63181a97
MV		 3023 size_t cstart, cend;
3024 SCM result;
3025 size_t idx;
3026
f846bd1a
MG		 3027 MY_VALIDATE_SUBSTRING_SPEC (1, s,
3028 3, start, cstart,
3029 4, end, cend);
85912343
KR		 3030
3031 /* The explicit loops below stripping leading and trailing non-matches
3032 mean we can return a substring if those are the only deletions, making
3033 string-filter as efficient as string-trim-both in that case. */
3034
63181a97
MV		 3035 if (SCM_CHARP (char_pred))
3036 {
8753a993 3037 size_t count;
85912343
KR		 3038
3039 /* strip leading non-matches by incrementing cstart */
f846bd1a 3040 while (cstart < cend && scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
85912343
KR		 3041 cstart++;
3042
3043 /* strip trailing non-matches by decrementing cend */
f846bd1a 3044 while (cend > cstart && scm_i_string_ref (s, cend-1) != SCM_CHAR (char_pred))
85912343
KR		 3045 cend--;
3046
3047 /* count chars to keep */
8753a993
KR		 3048 count = 0;
3049 for (idx = cstart; idx < cend; idx++)
f846bd1a 3050 if (scm_i_string_ref (s, idx) == SCM_CHAR (char_pred))
8753a993
KR		 3051 count++;
3052
8753a993 3053 if (count == cend - cstart)
8230ee41 3054 {
85912343
KR		 3055 /* whole of cstart to cend is to be kept, return a copy-on-write
3056 substring */
8230ee41
KR		 3057 result_substring:
3058 result = scm_i_substring (s, cstart, cend);
3059 }
8753a993
KR		 3060 else
3061 result = scm_c_make_string (count, char_pred);
63181a97
MV		 3062 }
3063 else if (SCM_CHARSETP (char_pred))
3064 {
8753a993 3065 size_t count;
63181a97 3066
85912343 3067 /* strip leading non-matches by incrementing cstart */
f846bd1a 3068 while (cstart < cend && ! REF_IN_CHARSET (s, cstart, char_pred))
85912343
KR		 3069 cstart++;
3070
3071 /* strip trailing non-matches by decrementing cend */
f846bd1a 3072 while (cend > cstart && ! REF_IN_CHARSET (s, cend-1, char_pred))
85912343
KR		 3073 cend--;
3074
8753a993
KR		 3075 /* count chars to be kept */
3076 count = 0;
3077 for (idx = cstart; idx < cend; idx++)
f846bd1a 3078 if (REF_IN_CHARSET (s, idx, char_pred))
8753a993
KR		 3079 count++;
3080
8230ee41 3081 /* if whole of start to end kept then return substring */
8753a993 3082 if (count == cend - cstart)
8230ee41 3083 goto result_substring;
8753a993
KR		 3084 else
3085 {
f846bd1a
MG		 3086 size_t dst = 0;
3087 result = scm_i_make_string (count, NULL);
3088 result = scm_i_string_start_writing (result);
8753a993
KR		 3089
3090 /* decrement "count" in this loop as well as using idx, so that if
3091 another thread is simultaneously changing "s" there's no chance
3092 it'll make us copy more than count characters */
3093 for (idx = cstart; idx < cend && count != 0; idx++)
3094 {
f846bd1a 3095 if (REF_IN_CHARSET (s, idx, char_pred))
8753a993 3096 {
f846bd1a
MG		 3097 scm_i_string_set_x (result, dst, scm_i_string_ref (s, idx));
3098 dst ++;
8753a993
KR		 3099 count--;
3100 }
3101 }
f846bd1a 3102 scm_i_string_stop_writing ();
8753a993 3103 }
63181a97
MV		 3104 }
3105 else
3106 {
3107 SCM ls = SCM_EOL;
3108
6c9e8a53
AW		 3109 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
3110 char_pred, SCM_ARG2, FUNC_NAME);
63181a97
MV		 3111 idx = cstart;
3112 while (idx < cend)
3113 {
3731fc67 3114 SCM res, ch;
f846bd1a 3115 ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
6c9e8a53 3116 res = scm_call_1 (char_pred, ch);
63181a97 3117 if (scm_is_true (res))
3731fc67 3118 ls = scm_cons (ch, ls);
63181a97
MV		 3119 idx++;
3120 }
3121 result = scm_reverse_list_to_string (ls);
3122 }
3731fc67 3123
63181a97
MV		 3124 scm_remember_upto_here_1 (s);
3125 return result;
3126}
3127#undef FUNC_NAME
3128
3129
3130SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
3131 (SCM s, SCM char_pred, SCM start, SCM end),
85912343 3132 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
8753a993
KR		 3133 "\n"
3134 "If @var{char_pred} is a procedure, it is applied to each\n"
3135 "character as a predicate, if it is a character, it is tested\n"
3136 "for equality and if it is a character set, it is tested for\n"
3137 "membership.")
63181a97
MV		 3138#define FUNC_NAME s_scm_string_delete
3139{
63181a97
MV		 3140 size_t cstart, cend;
3141 SCM result;
3142 size_t idx;
3143
f846bd1a
MG		 3144 MY_VALIDATE_SUBSTRING_SPEC (1, s,
3145 3, start, cstart,
3146 4, end, cend);
85912343
KR		 3147
3148 /* The explicit loops below stripping leading and trailing matches mean we
3149 can return a substring if those are the only deletions, making
3150 string-delete as efficient as string-trim-both in that case. */
3151
63181a97
MV		 3152 if (SCM_CHARP (char_pred))
3153 {
8753a993 3154 size_t count;
8753a993 3155
85912343 3156 /* strip leading matches by incrementing cstart */
f846bd1a 3157 while (cstart < cend && scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
85912343
KR		 3158 cstart++;
3159
3160 /* strip trailing matches by decrementing cend */
f846bd1a 3161 while (cend > cstart && scm_i_string_ref (s, cend-1) == SCM_CHAR (char_pred))
85912343
KR		 3162 cend--;
3163
8753a993
KR		 3164 /* count chars to be kept */
3165 count = 0;
3166 for (idx = cstart; idx < cend; idx++)
f846bd1a 3167 if (scm_i_string_ref (s, idx) != SCM_CHAR (char_pred))
8753a993
KR		 3168 count++;
3169
8753a993
KR		 3170 if (count == cend - cstart)
3171 {
85912343
KR		 3172 /* whole of cstart to cend is to be kept, return a copy-on-write
3173 substring */
8753a993 3174 result_substring:
8230ee41 3175 result = scm_i_substring (s, cstart, cend);
8753a993
KR		 3176 }
3177 else
3178 {
f846bd1a 3179 int i = 0;
8753a993 3180 /* new string for retained portion */
f846bd1a
MG		 3181 result = scm_i_make_string (count, NULL);
3182 result = scm_i_string_start_writing (result);
8753a993
KR		 3183 /* decrement "count" in this loop as well as using idx, so that if
3184 another thread is simultaneously changing "s" there's no chance
3185 it'll make us copy more than count characters */
3186 for (idx = cstart; idx < cend && count != 0; idx++)
3187 {
f846bd1a
MG		 3188 scm_t_wchar c = scm_i_string_ref (s, idx);
3189 if (c != SCM_CHAR (char_pred))
8753a993 3190 {
f846bd1a
MG		 3191 scm_i_string_set_x (result, i, c);
3192 i++;
8753a993
KR		 3193 count--;
3194 }
3195 }
f846bd1a 3196 scm_i_string_stop_writing ();
8753a993 3197 }
63181a97
MV		 3198 }
3199 else if (SCM_CHARSETP (char_pred))
3200 {
8753a993 3201 size_t count;
63181a97 3202
85912343 3203 /* strip leading matches by incrementing cstart */
f846bd1a 3204 while (cstart < cend && REF_IN_CHARSET (s, cstart, char_pred))
85912343
KR		 3205 cstart++;
3206
3207 /* strip trailing matches by decrementing cend */
f846bd1a 3208 while (cend > cstart && REF_IN_CHARSET (s, cend-1, char_pred))
85912343
KR		 3209 cend--;
3210
8753a993
KR		 3211 /* count chars to be kept */
3212 count = 0;
3213 for (idx = cstart; idx < cend; idx++)
f846bd1a 3214 if (!REF_IN_CHARSET (s, idx, char_pred))
8753a993
KR		 3215 count++;
3216
8753a993
KR		 3217 if (count == cend - cstart)
3218 goto result_substring;
3219 else
3220 {
f846bd1a 3221 size_t i = 0;
8753a993 3222 /* new string for retained portion */
f846bd1a
MG		 3223 result = scm_i_make_string (count, NULL);
3224 result = scm_i_string_start_writing (result);
8753a993
KR		 3225
3226 /* decrement "count" in this loop as well as using idx, so that if
3227 another thread is simultaneously changing "s" there's no chance
3228 it'll make us copy more than count characters */
3229 for (idx = cstart; idx < cend && count != 0; idx++)
3230 {
f846bd1a 3231 if (!REF_IN_CHARSET (s, idx, char_pred))
8753a993 3232 {
f846bd1a
MG		 3233 scm_i_string_set_x (result, i, scm_i_string_ref (s, idx));
3234 i++;
8753a993
KR		 3235 count--;
3236 }
3237 }
f846bd1a 3238 scm_i_string_stop_writing ();
8753a993 3239 }
63181a97
MV		 3240 }
3241 else
3242 {
3243 SCM ls = SCM_EOL;
6c9e8a53
AW		 3244 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
3245 char_pred, SCM_ARG2, FUNC_NAME);
63181a97 3246
63181a97
MV		 3247 idx = cstart;
3248 while (idx < cend)
3249 {
f846bd1a 3250 SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
6c9e8a53 3251 res = scm_call_1 (char_pred, ch);
63181a97 3252 if (scm_is_false (res))
3731fc67 3253 ls = scm_cons (ch, ls);
63181a97
MV		 3254 idx++;
3255 }
3256 result = scm_reverse_list_to_string (ls);
3257 }
3731fc67
MV		 3258
3259 scm_remember_upto_here_1 (s);
63181a97
MV		 3260 return result;
3261}
3262#undef FUNC_NAME
3263
63181a97
MV		 3264void
3265scm_init_srfi_13 (void)
3266{
3267#include "libguile/srfi-13.x"
3268}
3269
3270/* End of srfi-13.c. */
Unnamed repository; edit this file 'description' to name the repository.