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