HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
simplify inline function infrastructure
[bpt/guile.git] / libguile / srfi-13.c
CommitLineData
63181a97
MV		 1/* srfi-13.c --- SRFI-13 procedures for Guile
2 *
bf7c2e96 3 * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 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);
63181a97
MV		 722 if (SCM_UNBNDP (char_pred))
723 {
724 while (cstart < cend)
725 {
f846bd1a 726 if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
63181a97
MV		 727 break;
728 cstart++;
729 }
730 }
731 else if (SCM_CHARP (char_pred))
732 {
63181a97
MV		 733 while (cstart < cend)
734 {
f846bd1a 735 if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
63181a97
MV		 736 break;
737 cstart++;
738 }
739 }
740 else if (SCM_CHARSETP (char_pred))
741 {
742 while (cstart < cend)
743 {
f846bd1a 744 if (!REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 745 break;
746 cstart++;
747 }
748 }
749 else
750 {
6c9e8a53
AW		 751 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
752 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 753
63181a97
MV		 754 while (cstart < cend)
755 {
756 SCM res;
757
6c9e8a53 758 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 759 if (scm_is_false (res))
760 break;
63181a97
MV		 761 cstart++;
762 }
763 }
f846bd1a 764 return scm_i_substring (s, cstart, cend);
63181a97
MV		 765}
766#undef FUNC_NAME
767
768
769SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
770 (SCM s, SCM char_pred, SCM start, SCM end),
f846bd1a 771 "Trim @var{s} by skipping over all characters on the right\n"
63181a97
MV		 772 "that satisfy the parameter @var{char_pred}:\n"
773 "\n"
774 "@itemize @bullet\n"
775 "@item\n"
776 "if it is the character @var{ch}, characters equal to @var{ch}\n"
777 "are trimmed,\n"
778 "\n"
779 "@item\n"
780 "if it is a procedure @var{pred} characters that satisfy\n"
781 "@var{pred} are trimmed,\n"
782 "\n"
783 "@item\n"
784 "if it is a character sets, all characters in that set are\n"
785 "trimmed.\n"
786 "@end itemize\n"
787 "\n"
788 "If called without a @var{char_pred} argument, all whitespace is\n"
789 "trimmed.")
790#define FUNC_NAME s_scm_string_trim_right
791{
616775ed 792 size_t cstart, cend;
63181a97 793
f846bd1a
MG		 794 MY_VALIDATE_SUBSTRING_SPEC (1, s,
795 3, start, cstart,
796 4, end, cend);
63181a97
MV		 797 if (SCM_UNBNDP (char_pred))
798 {
799 while (cstart < cend)
800 {
f846bd1a 801 if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
63181a97
MV		 802 break;
803 cend--;
804 }
805 }
806 else if (SCM_CHARP (char_pred))
807 {
63181a97
MV		 808 while (cstart < cend)
809 {
f846bd1a 810 if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
63181a97
MV		 811 break;
812 cend--;
813 }
814 }
815 else if (SCM_CHARSETP (char_pred))
816 {
817 while (cstart < cend)
818 {
f846bd1a 819 if (!REF_IN_CHARSET (s, cend-1, char_pred))
63181a97
MV		 820 break;
821 cend--;
822 }
823 }
824 else
825 {
6c9e8a53
AW		 826 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
827 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 828
63181a97
MV		 829 while (cstart < cend)
830 {
831 SCM res;
832
6c9e8a53 833 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
63181a97
MV		 834 if (scm_is_false (res))
835 break;
63181a97
MV		 836 cend--;
837 }
838 }
f846bd1a 839 return scm_i_substring (s, cstart, cend);
63181a97
MV		 840}
841#undef FUNC_NAME
842
843
844SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
845 (SCM s, SCM char_pred, SCM start, SCM end),
846 "Trim @var{s} by skipping over all characters on both sides of\n"
847 "the string that satisfy the parameter @var{char_pred}:\n"
848 "\n"
849 "@itemize @bullet\n"
850 "@item\n"
851 "if it is the character @var{ch}, characters equal to @var{ch}\n"
852 "are trimmed,\n"
853 "\n"
854 "@item\n"
855 "if it is a procedure @var{pred} characters that satisfy\n"
856 "@var{pred} are trimmed,\n"
857 "\n"
858 "@item\n"
859 "if it is a character set, the characters in the set are\n"
860 "trimmed.\n"
861 "@end itemize\n"
862 "\n"
863 "If called without a @var{char_pred} argument, all whitespace is\n"
864 "trimmed.")
865#define FUNC_NAME s_scm_string_trim_both
866{
63181a97
MV		 867 size_t cstart, cend;
868
f846bd1a
MG		 869 MY_VALIDATE_SUBSTRING_SPEC (1, s,
870 3, start, cstart,
871 4, end, cend);
63181a97
MV		 872 if (SCM_UNBNDP (char_pred))
873 {
874 while (cstart < cend)
875 {
f846bd1a 876 if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
63181a97
MV		 877 break;
878 cstart++;
879 }
880 while (cstart < cend)
881 {
f846bd1a 882 if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
63181a97
MV		 883 break;
884 cend--;
885 }
886 }
887 else if (SCM_CHARP (char_pred))
888 {
63181a97
MV		 889 while (cstart < cend)
890 {
f846bd1a 891 if (scm_i_string_ref (s, cstart) != SCM_CHAR(char_pred))
63181a97
MV		 892 break;
893 cstart++;
894 }
895 while (cstart < cend)
896 {
f846bd1a 897 if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
63181a97
MV		 898 break;
899 cend--;
900 }
901 }
902 else if (SCM_CHARSETP (char_pred))
903 {
904 while (cstart < cend)
905 {
f846bd1a 906 if (!REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 907 break;
908 cstart++;
909 }
910 while (cstart < cend)
911 {
f846bd1a 912 if (!REF_IN_CHARSET (s, cend-1, char_pred))
63181a97
MV		 913 break;
914 cend--;
915 }
916 }
917 else
918 {
6c9e8a53
AW		 919 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
920 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 921
63181a97
MV		 922 while (cstart < cend)
923 {
924 SCM res;
925
6c9e8a53 926 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 927 if (scm_is_false (res))
928 break;
63181a97
MV		 929 cstart++;
930 }
931 while (cstart < cend)
932 {
933 SCM res;
934
6c9e8a53 935 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
63181a97
MV		 936 if (scm_is_false (res))
937 break;
63181a97
MV		 938 cend--;
939 }
940 }
f846bd1a 941 return scm_i_substring (s, cstart, cend);
63181a97
MV		 942}
943#undef FUNC_NAME
944
945
946SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
947 (SCM str, SCM chr, SCM start, SCM end),
948 "Stores @var{chr} in every element of the given @var{str} and\n"
949 "returns an unspecified value.")
950#define FUNC_NAME s_scm_substring_fill_x
951{
63181a97 952 size_t cstart, cend;
63181a97
MV		 953 size_t k;
954
955 /* Older versions of Guile provided the function
956 scm_substring_fill_x with the following order of arguments:
957
958 str, start, end, chr
959
960 We accomodate this here by detecting such a usage and reordering
961 the arguments.
962 */
963 if (SCM_CHARP (end))
964 {
965 SCM tmp = end;
966 end = start;
967 start = chr;
968 chr = tmp;
969 }
970
971 MY_VALIDATE_SUBSTRING_SPEC (1, str,
972 3, start, cstart,
973 4, end, cend);
f846bd1a
MG		 974 SCM_VALIDATE_CHAR (2, chr);
975
b2fb40a9
MW		 976 if (cstart < cend)
977 {
978 str = scm_i_string_start_writing (str);
979 for (k = cstart; k < cend; k++)
980 scm_i_string_set_x (str, k, SCM_CHAR (chr));
981 scm_i_string_stop_writing ();
982 }
3731fc67 983
63181a97
MV		 984 return SCM_UNSPECIFIED;
985}
986#undef FUNC_NAME
987
988SCM
989scm_string_fill_x (SCM str, SCM chr)
990{
991 return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED);
992}
993
994SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
995 (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
996 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
997 "mismatch index, depending upon whether @var{s1} is less than,\n"
998 "equal to, or greater than @var{s2}. The mismatch index is the\n"
999 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1000 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
1001 "@var{i} is the first position that does not match.")
1002#define FUNC_NAME s_scm_string_compare
1003{
63181a97 1004 size_t cstart1, cend1, cstart2, cend2;
3731fc67 1005 SCM proc;
63181a97 1006
f846bd1a
MG		 1007 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1008 6, start1, cstart1,
1009 7, end1, cend1);
1010 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1011 8, start2, cstart2,
1012 9, end2, cend2);
63181a97
MV		 1013 SCM_VALIDATE_PROC (3, proc_lt);
1014 SCM_VALIDATE_PROC (4, proc_eq);
1015 SCM_VALIDATE_PROC (5, proc_gt);
1016
1017 while (cstart1 < cend1 && cstart2 < cend2)
1018 {
f846bd1a
MG		 1019 if (scm_i_string_ref (s1, cstart1)
1020 < scm_i_string_ref (s2, cstart2))
3731fc67
MV		 1021 {
1022 proc = proc_lt;
1023 goto ret;
1024 }
f846bd1a
MG		 1025 else if (scm_i_string_ref (s1, cstart1)
1026 > scm_i_string_ref (s2, cstart2))
3731fc67
MV		 1027 {
1028 proc = proc_gt;
1029 goto ret;
1030 }
63181a97
MV		 1031 cstart1++;
1032 cstart2++;
1033 }
1034 if (cstart1 < cend1)
3731fc67 1035 proc = proc_gt;
63181a97 1036 else if (cstart2 < cend2)
3731fc67 1037 proc = proc_lt;
63181a97 1038 else
3731fc67
MV		 1039 proc = proc_eq;
1040
1041 ret:
1042 scm_remember_upto_here_2 (s1, s2);
1043 return scm_call_1 (proc, scm_from_size_t (cstart1));
63181a97
MV		 1044}
1045#undef FUNC_NAME
1046
1047
1048SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
1049 (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
1050 "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
1051 "mismatch index, depending upon whether @var{s1} is less than,\n"
1052 "equal to, or greater than @var{s2}. The mismatch index is the\n"
1053 "largest index @var{i} such that for every 0 <= @var{j} <\n"
1054 "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
f846bd1a
MG		 1055 "@var{i} is the first position where the lowercased letters \n"
1056 "do not match.\n")
63181a97
MV		 1057#define FUNC_NAME s_scm_string_compare_ci
1058{
63181a97 1059 size_t cstart1, cend1, cstart2, cend2;
3731fc67 1060 SCM proc;
63181a97 1061
f846bd1a
MG		 1062 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1063 6, start1, cstart1,
1064 7, end1, cend1);
1065 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1066 8, start2, cstart2,
1067 9, end2, cend2);
63181a97
MV		 1068 SCM_VALIDATE_PROC (3, proc_lt);
1069 SCM_VALIDATE_PROC (4, proc_eq);
1070 SCM_VALIDATE_PROC (5, proc_gt);
1071
1072 while (cstart1 < cend1 && cstart2 < cend2)
1073 {
f846bd1a
MG		 1074 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1075 < uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67
MV		 1076 {
1077 proc = proc_lt;
1078 goto ret;
1079 }
f846bd1a
MG		 1080 else if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1081 > uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67
MV		 1082 {
1083 proc = proc_gt;
1084 goto ret;
1085 }
63181a97
MV		 1086 cstart1++;
1087 cstart2++;
1088 }
3731fc67 1089
63181a97 1090 if (cstart1 < cend1)
3731fc67 1091 proc = proc_gt;
63181a97 1092 else if (cstart2 < cend2)
3731fc67 1093 proc = proc_lt;
63181a97 1094 else
3731fc67
MV		 1095 proc = proc_eq;
1096
1097 ret:
1098 scm_remember_upto_here (s1, s2);
1099 return scm_call_1 (proc, scm_from_size_t (cstart1));
63181a97
MV		 1100}
1101#undef FUNC_NAME
1102
f846bd1a
MG		 1103/* This function compares two substrings, S1 from START1 to END1 and
1104 S2 from START2 to END2, possibly case insensitively, and returns
4b1c3f0e
AW		 1105 one of the parameters LESSTHAN, GREATERTHAN, SHORTER, LONGER, or
1106 EQUAL depending if S1 is less than S2, greater than S2, shorter,
1107 longer, or equal. */
f846bd1a
MG		 1108static SCM
1109compare_strings (const char *fname, int case_insensitive,
1110 SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2,
4b1c3f0e 1111 SCM lessthan, SCM greaterthan, SCM shorter, SCM longer, SCM equal)
63181a97 1112{
63181a97 1113 size_t cstart1, cend1, cstart2, cend2;
f846bd1a
MG		 1114 SCM ret;
1115 scm_t_wchar a, b;
63181a97 1116
f846bd1a 1117 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 1, s1,
63181a97
MV		 1118 3, start1, cstart1,
1119 4, end1, cend1);
f846bd1a 1120 MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 2, s2,
63181a97
MV		 1121 5, start2, cstart2,
1122 6, end2, cend2);
1123
f846bd1a 1124 while (cstart1 < cend1 && cstart2 < cend2)
63181a97 1125 {
f846bd1a
MG		 1126 if (case_insensitive)
1127 {
1128 a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
1129 b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
1130 }
1131 else
1132 {
1133 a = scm_i_string_ref (s1, cstart1);
1134 b = scm_i_string_ref (s2, cstart2);
1135 }
1136 if (a < b)
1137 {
1138 ret = lessthan;
1139 goto done;
1140 }
1141 else if (a > b)
1142 {
1143 ret = greaterthan;
1144 goto done;
1145 }
63181a97
MV		 1146 cstart1++;
1147 cstart2++;
1148 }
f846bd1a
MG		 1149 if (cstart1 < cend1)
1150 {
1151 ret = longer;
1152 goto done;
1153 }
1154 else if (cstart2 < cend2)
1155 {
1156 ret = shorter;
1157 goto done;
1158 }
1159 else
1160 {
1161 ret = equal;
1162 goto done;
1163 }
63181a97 1164
f846bd1a 1165 done:
63181a97 1166 scm_remember_upto_here_2 (s1, s2);
f846bd1a
MG		 1167 return ret;
1168}
1169
1170
1171SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
1172 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1173 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1174 "value otherwise.")
1175#define FUNC_NAME s_scm_string_eq
1176{
7614c983
LC		 1177 if (SCM_LIKELY (scm_is_string (s1) && scm_is_string (s2) &&
1178 scm_i_is_narrow_string (s1) == scm_i_is_narrow_string (s2)
0cc92ac4
LC		 1179 && SCM_UNBNDP (start1) && SCM_UNBNDP (end1)
1180 && SCM_UNBNDP (start2) && SCM_UNBNDP (end2)))
1181 {
1182 /* Fast path for this common case, which avoids the repeated calls to
1183 `scm_i_string_ref'. */
1184 size_t len1, len2;
1185
1186 len1 = scm_i_string_length (s1);
1187 len2 = scm_i_string_length (s2);
1188
06fc34c2
MW		 1189 if (len1 != len2)
1190 return SCM_BOOL_F;
1191 else
0cc92ac4
LC		 1192 {
1193 if (!scm_i_is_narrow_string (s1))
1194 len1 *= 4;
1195
1196 return scm_from_bool (memcmp (scm_i_string_data (s1),
1197 scm_i_string_data (s2),
1198 len1) == 0);
1199 }
1200 }
1201
f846bd1a
MG		 1202 return compare_strings (FUNC_NAME, 0,
1203 s1, s2, start1, end1, start2, end2,
1204 SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1205}
1206#undef FUNC_NAME
1207
1208
1209SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
1210 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1211 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1212 "value otherwise.")
1213#define FUNC_NAME s_scm_string_neq
1214{
f846bd1a
MG		 1215 return compare_strings (FUNC_NAME, 0,
1216 s1, s2, start1, end1, start2, end2,
1217 SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1218}
1219#undef FUNC_NAME
1220
1221
1222SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
1223 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1224 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1225 "true value otherwise.")
1226#define FUNC_NAME s_scm_string_lt
1227{
f846bd1a
MG		 1228 return compare_strings (FUNC_NAME, 0,
1229 s1, s2, start1, end1, start2, end2,
1230 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
63181a97
MV		 1231}
1232#undef FUNC_NAME
1233
1234
1235SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
1236 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1237 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1238 "true value otherwise.")
1239#define FUNC_NAME s_scm_string_gt
1240{
f846bd1a
MG		 1241 return compare_strings (FUNC_NAME, 0,
1242 s1, s2, start1, end1, start2, end2,
1243 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1244}
1245#undef FUNC_NAME
1246
1247
1248SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
1249 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1250 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1251 "value otherwise.")
1252#define FUNC_NAME s_scm_string_le
1253{
f846bd1a
MG		 1254 return compare_strings (FUNC_NAME, 0,
1255 s1, s2, start1, end1, start2, end2,
1256 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1257}
1258#undef FUNC_NAME
1259
1260
1261SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
1262 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1263 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1264 "otherwise.")
1265#define FUNC_NAME s_scm_string_ge
1266{
f846bd1a
MG		 1267 return compare_strings (FUNC_NAME, 0,
1268 s1, s2, start1, end1, start2, end2,
1269 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
63181a97
MV		 1270}
1271#undef FUNC_NAME
1272
1273
1274SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
1275 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1276 "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
1277 "value otherwise. The character comparison is done\n"
1278 "case-insensitively.")
1279#define FUNC_NAME s_scm_string_ci_eq
1280{
f846bd1a
MG		 1281 return compare_strings (FUNC_NAME, 1,
1282 s1, s2, start1, end1, start2, end2,
1283 SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1284}
1285#undef FUNC_NAME
1286
1287
1288SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
1289 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
f846bd1a
MG		 1290 "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
1291 "value otherwise. The character comparison is done\n"
1292 "case-insensitively.")
1293#define FUNC_NAME s_scm_string_ci_neq
1294{
1295 return compare_strings (FUNC_NAME, 1,
1296 s1, s2, start1, end1, start2, end2,
1297 SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1298}
1299#undef FUNC_NAME
1300
1301
1302SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
1303 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1304 "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
1305 "true value otherwise. The character comparison is done\n"
1306 "case-insensitively.")
1307#define FUNC_NAME s_scm_string_ci_lt
1308{
f846bd1a
MG		 1309 return compare_strings (FUNC_NAME, 1,
1310 s1, s2, start1, end1, start2, end2,
1311 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
63181a97
MV		 1312}
1313#undef FUNC_NAME
1314
1315
1316SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
1317 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1318 "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
1319 "true value otherwise. The character comparison is done\n"
1320 "case-insensitively.")
1321#define FUNC_NAME s_scm_string_ci_gt
1322{
f846bd1a
MG		 1323 return compare_strings (FUNC_NAME, 1,
1324 s1, s2, start1, end1, start2, end2,
1325 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
63181a97
MV		 1326}
1327#undef FUNC_NAME
1328
1329
1330SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
1331 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1332 "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
1333 "value otherwise. The character comparison is done\n"
1334 "case-insensitively.")
1335#define FUNC_NAME s_scm_string_ci_le
1336{
f846bd1a
MG		 1337 return compare_strings (FUNC_NAME, 1,
1338 s1, s2, start1, end1, start2, end2,
1339 SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
63181a97
MV		 1340}
1341#undef FUNC_NAME
1342
1343
1344SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
1345 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1346 "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
1347 "otherwise. The character comparison is done\n"
1348 "case-insensitively.")
1349#define FUNC_NAME s_scm_string_ci_ge
1350{
f846bd1a
MG		 1351 return compare_strings (FUNC_NAME, 1,
1352 s1, s2, start1, end1, start2, end2,
1353 SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
63181a97
MV		 1354}
1355#undef FUNC_NAME
1356
1357SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
1358 (SCM s, SCM bound, SCM start, SCM end),
b7e64f8b 1359 "Compute a hash value for @var{s}. the optional argument "
63181a97
MV		 1360 "@var{bound} is a non-negative exact "
1361 "integer specifying the range of the hash function. "
1362 "A positive value restricts the return value to the "
1363 "range [0,bound).")
1364#define FUNC_NAME s_scm_substring_hash
1365{
1366 if (SCM_UNBNDP (bound))
1367 bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM);
1368 if (SCM_UNBNDP (start))
1369 start = SCM_INUM0;
1370 return scm_hash (scm_substring_shared (s, start, end), bound);
1371}
1372#undef FUNC_NAME
1373
1374SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
1375 (SCM s, SCM bound, SCM start, SCM end),
b7e64f8b 1376 "Compute a hash value for @var{s}. the optional argument "
63181a97
MV		 1377 "@var{bound} is a non-negative exact "
1378 "integer specifying the range of the hash function. "
1379 "A positive value restricts the return value to the "
1380 "range [0,bound).")
1381#define FUNC_NAME s_scm_substring_hash_ci
1382{
1383 return scm_substring_hash (scm_substring_downcase (s, start, end),
1384 bound,
1385 SCM_UNDEFINED, SCM_UNDEFINED);
1386}
1387#undef FUNC_NAME
1388
1389SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
1390 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1391 "Return the length of the longest common prefix of the two\n"
1392 "strings.")
1393#define FUNC_NAME s_scm_string_prefix_length
1394{
63181a97
MV		 1395 size_t cstart1, cend1, cstart2, cend2;
1396 size_t len = 0;
1397
f846bd1a
MG		 1398 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1399 3, start1, cstart1,
1400 4, end1, cend1);
1401 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1402 5, start2, cstart2,
1403 6, end2, cend2);
1404
63181a97
MV		 1405 while (cstart1 < cend1 && cstart2 < cend2)
1406 {
f846bd1a
MG		 1407 if (scm_i_string_ref (s1, cstart1)
1408 != scm_i_string_ref (s2, cstart2))
3731fc67 1409 goto ret;
63181a97
MV		 1410 len++;
1411 cstart1++;
1412 cstart2++;
1413 }
3731fc67
MV		 1414
1415 ret:
1416 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1417 return scm_from_size_t (len);
1418}
1419#undef FUNC_NAME
1420
1421
1422SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
1423 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1424 "Return the length of the longest common prefix of the two\n"
1425 "strings, ignoring character case.")
1426#define FUNC_NAME s_scm_string_prefix_length_ci
1427{
63181a97
MV		 1428 size_t cstart1, cend1, cstart2, cend2;
1429 size_t len = 0;
1430
f846bd1a
MG		 1431 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1432 3, start1, cstart1,
1433 4, end1, cend1);
1434 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1435 5, start2, cstart2,
1436 6, end2, cend2);
63181a97
MV		 1437 while (cstart1 < cend1 && cstart2 < cend2)
1438 {
f846bd1a
MG		 1439 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
1440 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
3731fc67 1441 goto ret;
63181a97
MV		 1442 len++;
1443 cstart1++;
1444 cstart2++;
1445 }
3731fc67
MV		 1446
1447 ret:
1448 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1449 return scm_from_size_t (len);
1450}
1451#undef FUNC_NAME
1452
1453
1454SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
1455 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1456 "Return the length of the longest common suffix of the two\n"
1457 "strings.")
1458#define FUNC_NAME s_scm_string_suffix_length
1459{
63181a97
MV		 1460 size_t cstart1, cend1, cstart2, cend2;
1461 size_t len = 0;
1462
f846bd1a
MG		 1463 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1464 3, start1, cstart1,
1465 4, end1, cend1);
1466 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1467 5, start2, cstart2,
1468 6, end2, cend2);
63181a97
MV		 1469 while (cstart1 < cend1 && cstart2 < cend2)
1470 {
1471 cend1--;
1472 cend2--;
f846bd1a
MG		 1473 if (scm_i_string_ref (s1, cend1)
1474 != scm_i_string_ref (s2, cend2))
3731fc67 1475 goto ret;
63181a97
MV		 1476 len++;
1477 }
3731fc67
MV		 1478
1479 ret:
1480 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1481 return scm_from_size_t (len);
1482}
1483#undef FUNC_NAME
1484
1485
1486SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
1487 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1488 "Return the length of the longest common suffix of the two\n"
1489 "strings, ignoring character case.")
1490#define FUNC_NAME s_scm_string_suffix_length_ci
1491{
63181a97
MV		 1492 size_t cstart1, cend1, cstart2, cend2;
1493 size_t len = 0;
1494
f846bd1a
MG		 1495 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1496 3, start1, cstart1,
1497 4, end1, cend1);
1498 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1499 5, start2, cstart2,
1500 6, end2, cend2);
63181a97
MV		 1501 while (cstart1 < cend1 && cstart2 < cend2)
1502 {
1503 cend1--;
1504 cend2--;
f846bd1a
MG		 1505 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
1506 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
3731fc67 1507 goto ret;
63181a97
MV		 1508 len++;
1509 }
3731fc67
MV		 1510
1511 ret:
1512 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1513 return scm_from_size_t (len);
1514}
1515#undef FUNC_NAME
1516
1517
1518SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
1519 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1520 "Is @var{s1} a prefix of @var{s2}?")
1521#define FUNC_NAME s_scm_string_prefix_p
1522{
63181a97
MV		 1523 size_t cstart1, cend1, cstart2, cend2;
1524 size_t len = 0, len1;
1525
f846bd1a
MG		 1526 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1527 3, start1, cstart1,
1528 4, end1, cend1);
1529 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1530 5, start2, cstart2,
1531 6, end2, cend2);
63181a97
MV		 1532 len1 = cend1 - cstart1;
1533 while (cstart1 < cend1 && cstart2 < cend2)
1534 {
f846bd1a
MG		 1535 if (scm_i_string_ref (s1, cstart1)
1536 != scm_i_string_ref (s2, cstart2))
3731fc67 1537 goto ret;
63181a97
MV		 1538 len++;
1539 cstart1++;
1540 cstart2++;
1541 }
3731fc67
MV		 1542
1543 ret:
1544 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1545 return scm_from_bool (len == len1);
1546}
1547#undef FUNC_NAME
1548
1549
1550SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
1551 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1552 "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
1553#define FUNC_NAME s_scm_string_prefix_ci_p
1554{
63181a97
MV		 1555 size_t cstart1, cend1, cstart2, cend2;
1556 size_t len = 0, len1;
1557
f846bd1a
MG		 1558 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1559 3, start1, cstart1,
1560 4, end1, cend1);
1561 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1562 5, start2, cstart2,
1563 6, end2, cend2);
63181a97
MV		 1564 len1 = cend1 - cstart1;
1565 while (cstart1 < cend1 && cstart2 < cend2)
1566 {
f846bd1a
MG		 1567 scm_t_wchar a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
1568 scm_t_wchar b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
1569 if (a != b)
3731fc67 1570 goto ret;
63181a97
MV		 1571 len++;
1572 cstart1++;
1573 cstart2++;
1574 }
3731fc67
MV		 1575
1576 ret:
1577 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1578 return scm_from_bool (len == len1);
1579}
1580#undef FUNC_NAME
1581
1582
1583SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
1584 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1585 "Is @var{s1} a suffix of @var{s2}?")
1586#define FUNC_NAME s_scm_string_suffix_p
1587{
63181a97
MV		 1588 size_t cstart1, cend1, cstart2, cend2;
1589 size_t len = 0, len1;
1590
f846bd1a
MG		 1591 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1592 3, start1, cstart1,
1593 4, end1, cend1);
1594 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1595 5, start2, cstart2,
1596 6, end2, cend2);
63181a97
MV		 1597 len1 = cend1 - cstart1;
1598 while (cstart1 < cend1 && cstart2 < cend2)
1599 {
1600 cend1--;
1601 cend2--;
f846bd1a
MG		 1602 if (scm_i_string_ref (s1, cend1)
1603 != scm_i_string_ref (s2, cend2))
3731fc67 1604 goto ret;
63181a97
MV		 1605 len++;
1606 }
3731fc67
MV		 1607
1608 ret:
1609 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1610 return scm_from_bool (len == len1);
1611}
1612#undef FUNC_NAME
1613
1614
1615SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
1616 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1617 "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
1618#define FUNC_NAME s_scm_string_suffix_ci_p
1619{
63181a97
MV		 1620 size_t cstart1, cend1, cstart2, cend2;
1621 size_t len = 0, len1;
1622
f846bd1a
MG		 1623 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
1624 3, start1, cstart1,
1625 4, end1, cend1);
1626 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
1627 5, start2, cstart2,
1628 6, end2, cend2);
63181a97
MV		 1629 len1 = cend1 - cstart1;
1630 while (cstart1 < cend1 && cstart2 < cend2)
1631 {
1632 cend1--;
1633 cend2--;
f846bd1a
MG		 1634 if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
1635 != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
3731fc67 1636 goto ret;
63181a97
MV		 1637 len++;
1638 }
3731fc67
MV		 1639
1640 ret:
1641 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 1642 return scm_from_bool (len == len1);
1643}
1644#undef FUNC_NAME
1645
1646
1647SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
1648 (SCM s, SCM char_pred, SCM start, SCM end),
1649 "Search through the string @var{s} from left to right, returning\n"
ffb62a43 1650 "the index of the first occurrence of a character which\n"
63181a97
MV		 1651 "\n"
1652 "@itemize @bullet\n"
1653 "@item\n"
1654 "equals @var{char_pred}, if it is character,\n"
1655 "\n"
1656 "@item\n"
ffb62a43 1657 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
63181a97
MV		 1658 "\n"
1659 "@item\n"
1660 "is in the set @var{char_pred}, if it is a character set.\n"
bf7c2e96
LC		 1661 "@end itemize\n\n"
1662 "Return @code{#f} if no match is found.")
63181a97
MV		 1663#define FUNC_NAME s_scm_string_index
1664{
63181a97
MV		 1665 size_t cstart, cend;
1666
f846bd1a
MG		 1667 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1668 3, start, cstart,
1669 4, end, cend);
63181a97
MV		 1670 if (SCM_CHARP (char_pred))
1671 {
63181a97
MV		 1672 while (cstart < cend)
1673 {
f846bd1a 1674 if (scm_i_string_ref (s, cstart) == SCM_CHAR (char_pred))
3731fc67 1675 goto found;
63181a97
MV		 1676 cstart++;
1677 }
1678 }
1679 else if (SCM_CHARSETP (char_pred))
1680 {
1681 while (cstart < cend)
1682 {
f846bd1a 1683 if (REF_IN_CHARSET (s, cstart, char_pred))
3731fc67 1684 goto found;
63181a97
MV		 1685 cstart++;
1686 }
1687 }
1688 else
1689 {
6c9e8a53
AW		 1690 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1691 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1692
63181a97
MV		 1693 while (cstart < cend)
1694 {
1695 SCM res;
6c9e8a53 1696 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 1697 if (scm_is_true (res))
3731fc67 1698 goto found;
63181a97
MV		 1699 cstart++;
1700 }
1701 }
3731fc67
MV		 1702
1703 scm_remember_upto_here_1 (s);
63181a97 1704 return SCM_BOOL_F;
3731fc67
MV		 1705
1706 found:
1707 scm_remember_upto_here_1 (s);
1708 return scm_from_size_t (cstart);
63181a97
MV		 1709}
1710#undef FUNC_NAME
1711
1712SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
1713 (SCM s, SCM char_pred, SCM start, SCM end),
1714 "Search through the string @var{s} from right to left, returning\n"
ffb62a43 1715 "the index of the last occurrence of a character which\n"
63181a97
MV		 1716 "\n"
1717 "@itemize @bullet\n"
1718 "@item\n"
1719 "equals @var{char_pred}, if it is character,\n"
1720 "\n"
1721 "@item\n"
ffb62a43 1722 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
63181a97
MV		 1723 "\n"
1724 "@item\n"
1725 "is in the set if @var{char_pred} is a character set.\n"
bf7c2e96
LC		 1726 "@end itemize\n\n"
1727 "Return @code{#f} if no match is found.")
63181a97
MV		 1728#define FUNC_NAME s_scm_string_index_right
1729{
63181a97
MV		 1730 size_t cstart, cend;
1731
f846bd1a
MG		 1732 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1733 3, start, cstart,
1734 4, end, cend);
63181a97
MV		 1735 if (SCM_CHARP (char_pred))
1736 {
63181a97
MV		 1737 while (cstart < cend)
1738 {
1739 cend--;
f846bd1a 1740 if (scm_i_string_ref (s, cend) == SCM_CHAR (char_pred))
3731fc67 1741 goto found;
63181a97
MV		 1742 }
1743 }
1744 else if (SCM_CHARSETP (char_pred))
1745 {
1746 while (cstart < cend)
1747 {
1748 cend--;
f846bd1a 1749 if (REF_IN_CHARSET (s, cend, char_pred))
3731fc67 1750 goto found;
63181a97
MV		 1751 }
1752 }
1753 else
1754 {
6c9e8a53
AW		 1755 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1756 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1757
63181a97
MV		 1758 while (cstart < cend)
1759 {
1760 SCM res;
1761 cend--;
6c9e8a53 1762 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
63181a97 1763 if (scm_is_true (res))
3731fc67 1764 goto found;
63181a97
MV		 1765 }
1766 }
3731fc67
MV		 1767
1768 scm_remember_upto_here_1 (s);
63181a97 1769 return SCM_BOOL_F;
3731fc67
MV		 1770
1771 found:
1772 scm_remember_upto_here_1 (s);
1773 return scm_from_size_t (cend);
63181a97
MV		 1774}
1775#undef FUNC_NAME
1776
2562032b
MV		 1777SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
1778 (SCM s, SCM char_pred, SCM start, SCM end),
1779 "Search through the string @var{s} from right to left, returning\n"
ffb62a43 1780 "the index of the last occurrence of a character which\n"
2562032b
MV		 1781 "\n"
1782 "@itemize @bullet\n"
1783 "@item\n"
1784 "equals @var{char_pred}, if it is character,\n"
1785 "\n"
1786 "@item\n"
ffb62a43 1787 "satisfies the predicate @var{char_pred}, if it is a procedure,\n"
2562032b
MV		 1788 "\n"
1789 "@item\n"
1790 "is in the set if @var{char_pred} is a character set.\n"
bf7c2e96
LC		 1791 "@end itemize\n\n"
1792 "Return @code{#f} if no match is found.")
3731fc67 1793#define FUNC_NAME s_scm_string_rindex
63181a97 1794{
2562032b 1795 return scm_string_index_right (s, char_pred, start, end);
63181a97 1796}
3731fc67 1797#undef FUNC_NAME
63181a97
MV		 1798
1799SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
1800 (SCM s, SCM char_pred, SCM start, SCM end),
1801 "Search through the string @var{s} from left to right, returning\n"
ffb62a43 1802 "the index of the first occurrence of a character which\n"
63181a97
MV		 1803 "\n"
1804 "@itemize @bullet\n"
1805 "@item\n"
1806 "does not equal @var{char_pred}, if it is character,\n"
1807 "\n"
1808 "@item\n"
ffb62a43 1809 "does not satisfy the predicate @var{char_pred}, if it is a\n"
63181a97
MV		 1810 "procedure,\n"
1811 "\n"
1812 "@item\n"
1813 "is not in the set if @var{char_pred} is a character set.\n"
1814 "@end itemize")
1815#define FUNC_NAME s_scm_string_skip
1816{
63181a97
MV		 1817 size_t cstart, cend;
1818
f846bd1a
MG		 1819 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1820 3, start, cstart,
1821 4, end, cend);
63181a97
MV		 1822 if (SCM_CHARP (char_pred))
1823 {
63181a97
MV		 1824 while (cstart < cend)
1825 {
f846bd1a 1826 if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
3731fc67 1827 goto found;
63181a97
MV		 1828 cstart++;
1829 }
1830 }
1831 else if (SCM_CHARSETP (char_pred))
1832 {
1833 while (cstart < cend)
1834 {
f846bd1a 1835 if (!REF_IN_CHARSET (s, cstart, char_pred))
3731fc67 1836 goto found;
63181a97
MV		 1837 cstart++;
1838 }
1839 }
1840 else
1841 {
6c9e8a53
AW		 1842 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1843 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1844
63181a97
MV		 1845 while (cstart < cend)
1846 {
1847 SCM res;
6c9e8a53 1848 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97 1849 if (scm_is_false (res))
3731fc67 1850 goto found;
63181a97
MV		 1851 cstart++;
1852 }
1853 }
3731fc67
MV		 1854
1855 scm_remember_upto_here_1 (s);
63181a97 1856 return SCM_BOOL_F;
3731fc67
MV		 1857
1858 found:
1859 scm_remember_upto_here_1 (s);
1860 return scm_from_size_t (cstart);
63181a97
MV		 1861}
1862#undef FUNC_NAME
1863
1864
1865SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
1866 (SCM s, SCM char_pred, SCM start, SCM end),
1867 "Search through the string @var{s} from right to left, returning\n"
ffb62a43 1868 "the index of the last occurrence of a character which\n"
63181a97
MV		 1869 "\n"
1870 "@itemize @bullet\n"
1871 "@item\n"
1872 "does not equal @var{char_pred}, if it is character,\n"
1873 "\n"
1874 "@item\n"
1875 "does not satisfy the predicate @var{char_pred}, if it is a\n"
1876 "procedure,\n"
1877 "\n"
1878 "@item\n"
1879 "is not in the set if @var{char_pred} is a character set.\n"
1880 "@end itemize")
1881#define FUNC_NAME s_scm_string_skip_right
1882{
63181a97
MV		 1883 size_t cstart, cend;
1884
f846bd1a
MG		 1885 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1886 3, start, cstart,
1887 4, end, cend);
63181a97
MV		 1888 if (SCM_CHARP (char_pred))
1889 {
63181a97
MV		 1890 while (cstart < cend)
1891 {
1892 cend--;
f846bd1a 1893 if (scm_i_string_ref (s, cend) != SCM_CHAR (char_pred))
3731fc67 1894 goto found;
63181a97
MV		 1895 }
1896 }
1897 else if (SCM_CHARSETP (char_pred))
1898 {
1899 while (cstart < cend)
1900 {
1901 cend--;
f846bd1a 1902 if (!REF_IN_CHARSET (s, cend, char_pred))
3731fc67 1903 goto found;
63181a97
MV		 1904 }
1905 }
1906 else
1907 {
6c9e8a53
AW		 1908 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1909 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1910
63181a97
MV		 1911 while (cstart < cend)
1912 {
1913 SCM res;
1914 cend--;
6c9e8a53 1915 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
63181a97 1916 if (scm_is_false (res))
3731fc67 1917 goto found;
63181a97
MV		 1918 }
1919 }
3731fc67
MV		 1920
1921 scm_remember_upto_here_1 (s);
63181a97 1922 return SCM_BOOL_F;
3731fc67
MV		 1923
1924 found:
1925 scm_remember_upto_here_1 (s);
1926 return scm_from_size_t (cend);
1927
63181a97
MV		 1928}
1929#undef FUNC_NAME
1930
1931
1932SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
1933 (SCM s, SCM char_pred, SCM start, SCM end),
1934 "Return the count of the number of characters in the string\n"
1935 "@var{s} which\n"
1936 "\n"
1937 "@itemize @bullet\n"
1938 "@item\n"
1939 "equals @var{char_pred}, if it is character,\n"
1940 "\n"
1941 "@item\n"
ffb62a43 1942 "satisfies the predicate @var{char_pred}, if it is a procedure.\n"
63181a97
MV		 1943 "\n"
1944 "@item\n"
1945 "is in the set @var{char_pred}, if it is a character set.\n"
1946 "@end itemize")
1947#define FUNC_NAME s_scm_string_count
1948{
63181a97
MV		 1949 size_t cstart, cend;
1950 size_t count = 0;
1951
f846bd1a
MG		 1952 MY_VALIDATE_SUBSTRING_SPEC (1, s,
1953 3, start, cstart,
1954 4, end, cend);
63181a97
MV		 1955 if (SCM_CHARP (char_pred))
1956 {
63181a97
MV		 1957 while (cstart < cend)
1958 {
f846bd1a 1959 if (scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
63181a97
MV		 1960 count++;
1961 cstart++;
1962 }
1963 }
1964 else if (SCM_CHARSETP (char_pred))
1965 {
1966 while (cstart < cend)
1967 {
f846bd1a 1968 if (REF_IN_CHARSET (s, cstart, char_pred))
63181a97
MV		 1969 count++;
1970 cstart++;
1971 }
1972 }
1973 else
1974 {
6c9e8a53
AW		 1975 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
1976 char_pred, SCM_ARG2, FUNC_NAME);
3540b915 1977
63181a97
MV		 1978 while (cstart < cend)
1979 {
1980 SCM res;
6c9e8a53 1981 res = scm_call_1 (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 1982 if (scm_is_true (res))
1983 count++;
63181a97
MV		 1984 cstart++;
1985 }
1986 }
3731fc67
MV		 1987
1988 scm_remember_upto_here_1 (s);
63181a97
MV		 1989 return scm_from_size_t (count);
1990}
1991#undef FUNC_NAME
1992
1993
1994/* FIXME::martin: This should definitely get implemented more
1995 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
1996 implementation. */
1997SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
1998 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
1999 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2000 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2001 "The optional start/end indices restrict the operation to the\n"
2002 "indicated substrings.")
2003#define FUNC_NAME s_scm_string_contains
2004{
63181a97
MV		 2005 size_t cstart1, cend1, cstart2, cend2;
2006 size_t len2, i, j;
2007
f846bd1a
MG		 2008 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
2009 3, start1, cstart1,
2010 4, end1, cend1);
2011 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
2012 5, start2, cstart2,
2013 6, end2, cend2);
63181a97 2014 len2 = cend2 - cstart2;
4a310f1c
MV		 2015 if (cend1 - cstart1 >= len2)
2016 while (cstart1 <= cend1 - len2)
2017 {
2018 i = cstart1;
2019 j = cstart2;
f846bd1a
MG		 2020 while (i < cend1
2021 && j < cend2
2022 && (scm_i_string_ref (s1, i)
2023 == scm_i_string_ref (s2, j)))
4a310f1c
MV		 2024 {
2025 i++;
2026 j++;
2027 }
2028 if (j == cend2)
2029 {
2030 scm_remember_upto_here_2 (s1, s2);
2031 return scm_from_size_t (cstart1);
2032 }
2033 cstart1++;
2034 }
3731fc67
MV		 2035
2036 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 2037 return SCM_BOOL_F;
2038}
2039#undef FUNC_NAME
2040
2041
2042/* FIXME::martin: This should definitely get implemented more
2043 efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
2044 implementation. */
2045SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
2046 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2047 "Does string @var{s1} contain string @var{s2}? Return the index\n"
2048 "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
2049 "The optional start/end indices restrict the operation to the\n"
2050 "indicated substrings. Character comparison is done\n"
2051 "case-insensitively.")
2052#define FUNC_NAME s_scm_string_contains_ci
2053{
63181a97
MV		 2054 size_t cstart1, cend1, cstart2, cend2;
2055 size_t len2, i, j;
2056
f846bd1a
MG		 2057 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
2058 3, start1, cstart1,
2059 4, end1, cend1);
2060 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
2061 5, start2, cstart2,
2062 6, end2, cend2);
63181a97 2063 len2 = cend2 - cstart2;
4a310f1c
MV		 2064 if (cend1 - cstart1 >= len2)
2065 while (cstart1 <= cend1 - len2)
2066 {
2067 i = cstart1;
2068 j = cstart2;
f846bd1a
MG		 2069 while (i < cend1
2070 && j < cend2
2071 && (uc_tolower (uc_toupper (scm_i_string_ref (s1, i)))
2072 == uc_tolower (uc_toupper (scm_i_string_ref (s2, j)))))
4a310f1c
MV		 2073 {
2074 i++;
2075 j++;
2076 }
2077 if (j == cend2)
2078 {
2079 scm_remember_upto_here_2 (s1, s2);
2080 return scm_from_size_t (cstart1);
2081 }
2082 cstart1++;
2083 }
3731fc67
MV		 2084
2085 scm_remember_upto_here_2 (s1, s2);
63181a97
MV		 2086 return SCM_BOOL_F;
2087}
2088#undef FUNC_NAME
2089
2090
f846bd1a 2091/* Helper function for the string uppercase conversion functions. */
63181a97 2092static SCM
1a82a460 2093string_upcase_x (SCM v, size_t start, size_t end)
63181a97
MV		 2094{
2095 size_t k;
63181a97 2096
b2fb40a9
MW		 2097 if (start < end)
2098 {
2099 v = scm_i_string_start_writing (v);
2100 for (k = start; k < end; ++k)
2101 scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
2102 scm_i_string_stop_writing ();
2103 scm_remember_upto_here_1 (v);
2104 }
63181a97
MV		 2105
2106 return v;
2107}
2108
2109SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
2110 (SCM str, SCM start, SCM end),
2111 "Destructively upcase every character in @code{str}.\n"
2112 "\n"
2113 "@lisp\n"
2114 "(string-upcase! y)\n"
2115 "@result{} \"ARRDEFG\"\n"
2116 "y\n"
2117 "@result{} \"ARRDEFG\"\n"
2118 "@end lisp")
2119#define FUNC_NAME s_scm_substring_upcase_x
2120{
63181a97
MV		 2121 size_t cstart, cend;
2122
f846bd1a
MG		 2123 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2124 2, start, cstart,
2125 3, end, cend);
63181a97
MV		 2126 return string_upcase_x (str, cstart, cend);
2127}
2128#undef FUNC_NAME
2129
2130SCM
2131scm_string_upcase_x (SCM str)
2132{
2133 return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2134}
2135
2136SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
2137 (SCM str, SCM start, SCM end),
2138 "Upcase every character in @code{str}.")
2139#define FUNC_NAME s_scm_substring_upcase
2140{
63181a97
MV		 2141 size_t cstart, cend;
2142
f846bd1a
MG		 2143 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2144 2, start, cstart,
2145 3, end, cend);
63181a97
MV		 2146 return string_upcase_x (scm_string_copy (str), cstart, cend);
2147}
2148#undef FUNC_NAME
2149
2150SCM
2151scm_string_upcase (SCM str)
2152{
2153 return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2154}
2155
2156/* Helper function for the string lowercase conversion functions.
2157 * No argument checking is performed. */
2158static SCM
1a82a460 2159string_downcase_x (SCM v, size_t start, size_t end)
63181a97
MV		 2160{
2161 size_t k;
63181a97 2162
b2fb40a9
MW		 2163 if (start < end)
2164 {
2165 v = scm_i_string_start_writing (v);
2166 for (k = start; k < end; ++k)
2167 scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
2168 scm_i_string_stop_writing ();
2169 scm_remember_upto_here_1 (v);
2170 }
63181a97
MV		 2171
2172 return v;
2173}
2174
2175SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
2176 (SCM str, SCM start, SCM end),
2177 "Destructively downcase every character in @var{str}.\n"
2178 "\n"
2179 "@lisp\n"
2180 "y\n"
2181 "@result{} \"ARRDEFG\"\n"
2182 "(string-downcase! y)\n"
2183 "@result{} \"arrdefg\"\n"
2184 "y\n"
2185 "@result{} \"arrdefg\"\n"
2186 "@end lisp")
2187#define FUNC_NAME s_scm_substring_downcase_x
2188{
63181a97
MV		 2189 size_t cstart, cend;
2190
f846bd1a
MG		 2191 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2192 2, start, cstart,
2193 3, end, cend);
63181a97
MV		 2194 return string_downcase_x (str, cstart, cend);
2195}
2196#undef FUNC_NAME
2197
2198SCM
2199scm_string_downcase_x (SCM str)
2200{
2201 return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2202}
2203
2204SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
2205 (SCM str, SCM start, SCM end),
2206 "Downcase every character in @var{str}.")
2207#define FUNC_NAME s_scm_substring_downcase
2208{
63181a97
MV		 2209 size_t cstart, cend;
2210
f846bd1a
MG		 2211 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2212 2, start, cstart,
2213 3, end, cend);
63181a97
MV		 2214 return string_downcase_x (scm_string_copy (str), cstart, cend);
2215}
2216#undef FUNC_NAME
2217
2218SCM
2219scm_string_downcase (SCM str)
2220{
2221 return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
2222}
2223
2224/* Helper function for the string capitalization functions.
2225 * No argument checking is performed. */
2226static SCM
1a82a460 2227string_titlecase_x (SCM str, size_t start, size_t end)
63181a97 2228{
f846bd1a 2229 SCM ch;
63181a97
MV		 2230 size_t i;
2231 int in_word = 0;
2232
b2fb40a9 2233 if (start < end)
63181a97 2234 {
b2fb40a9
MW		 2235 str = scm_i_string_start_writing (str);
2236 for(i = start; i < end; i++)
2237 {
2238 ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
2239 if (scm_is_true (scm_char_alphabetic_p (ch)))
2240 {
2241 if (!in_word)
2242 {
2243 scm_i_string_set_x (str, i, uc_totitle (SCM_CHAR (ch)));
2244 in_word = 1;
2245 }
2246 else
2247 {
2248 scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
2249 }
2250 }
2251 else
2252 in_word = 0;
2253 }
2254 scm_i_string_stop_writing ();
2255 scm_remember_upto_here_1 (str);
63181a97 2256 }
63181a97
MV		 2257
2258 return str;
2259}
2260
2261
2262SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
2263 (SCM str, SCM start, SCM end),
2264 "Destructively titlecase every first character in a word in\n"
2265 "@var{str}.")
2266#define FUNC_NAME s_scm_string_titlecase_x
2267{
63181a97
MV		 2268 size_t cstart, cend;
2269
f846bd1a
MG		 2270 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2271 2, start, cstart,
2272 3, end, cend);
63181a97
MV		 2273 return string_titlecase_x (str, cstart, cend);
2274}
2275#undef FUNC_NAME
2276
2277
2278SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
2279 (SCM str, SCM start, SCM end),
2280 "Titlecase every first character in a word in @var{str}.")
2281#define FUNC_NAME s_scm_string_titlecase
2282{
63181a97
MV		 2283 size_t cstart, cend;
2284
f846bd1a
MG		 2285 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2286 2, start, cstart,
2287 3, end, cend);
63181a97
MV		 2288 return string_titlecase_x (scm_string_copy (str), cstart, cend);
2289}
2290#undef FUNC_NAME
2291
63181a97
MV		 2292SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
2293 (SCM str),
2294 "Upcase the first character of every word in @var{str}\n"
2295 "destructively and return @var{str}.\n"
2296 "\n"
2297 "@lisp\n"
2298 "y @result{} \"hello world\"\n"
2299 "(string-capitalize! y) @result{} \"Hello World\"\n"
2300 "y @result{} \"Hello World\"\n"
2301 "@end lisp")
2302#define FUNC_NAME s_scm_string_capitalize_x
2303{
2304 return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
2305}
2306#undef FUNC_NAME
2307
2308
2309SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
2310 (SCM str),
2311 "Return a freshly allocated string with the characters in\n"
2312 "@var{str}, where the first character of every word is\n"
2313 "capitalized.")
2314#define FUNC_NAME s_scm_string_capitalize
2315{
2316 return scm_string_capitalize_x (scm_string_copy (str));
2317}
2318#undef FUNC_NAME
2319
2320
2321/* Reverse the portion of @var{str} between str[cstart] (including)
2322 and str[cend] excluding. */
2323static void
f846bd1a 2324string_reverse_x (SCM str, size_t cstart, size_t cend)
63181a97 2325{
b2fb40a9 2326 if (cstart < cend)
63181a97 2327 {
b2fb40a9
MW		 2328 str = scm_i_string_start_writing (str);
2329 if (cend > 0)
2330 {
2331 SCM tmp;
2332
2333 cend--;
2334 while (cstart < cend)
2335 {
2336 tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
2337 scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
2338 scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
2339 cstart++;
2340 cend--;
2341 }
2342 }
2343 scm_i_string_stop_writing ();
63181a97
MV		 2344 }
2345}
2346
2347
2348SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
2349 (SCM str, SCM start, SCM end),
2350 "Reverse the string @var{str}. The optional arguments\n"
2351 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2352 "operate on.")
2353#define FUNC_NAME s_scm_string_reverse
2354{
63181a97
MV		 2355 size_t cstart, cend;
2356 SCM result;
2357
f846bd1a
MG		 2358 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2359 2, start, cstart,
2360 3, end, cend);
63181a97 2361 result = scm_string_copy (str);
f846bd1a 2362 string_reverse_x (result, cstart, cend);
3731fc67 2363 scm_remember_upto_here_1 (str);
63181a97
MV		 2364 return result;
2365}
2366#undef FUNC_NAME
2367
2368
2369SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
2370 (SCM str, SCM start, SCM end),
2371 "Reverse the string @var{str} in-place. The optional arguments\n"
2372 "@var{start} and @var{end} delimit the region of @var{str} to\n"
2373 "operate on. The return value is unspecified.")
2374#define FUNC_NAME s_scm_string_reverse_x
2375{
63181a97
MV		 2376 size_t cstart, cend;
2377
2378 MY_VALIDATE_SUBSTRING_SPEC (1, str,
2379 2, start, cstart,
2380 3, end, cend);
2381
f846bd1a 2382 string_reverse_x (str, cstart, cend);
63181a97
MV		 2383 scm_remember_upto_here_1 (str);
2384 return SCM_UNSPECIFIED;
2385}
2386#undef FUNC_NAME
2387
2388
2389SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
a003f3eb 2390 (SCM rest),
63181a97
MV		 2391 "Like @code{string-append}, but the result may share memory\n"
2392 "with the argument strings.")
2393#define FUNC_NAME s_scm_string_append_shared
2394{
a003f3eb
KR		 2395 /* If "rest" contains just one non-empty string, return that.
2396 If it's entirely empty strings, then return scm_nullstr.
2397 Otherwise use scm_string_concatenate. */
63181a97 2398
a003f3eb
KR		 2399 SCM ret = scm_nullstr;
2400 int seen_nonempty = 0;
2401 SCM l, s;
63181a97 2402
a003f3eb
KR		 2403 SCM_VALIDATE_REST_ARGUMENT (rest);
2404
2405 for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
2406 {
2407 s = SCM_CAR (l);
f846bd1a
MG		 2408 if (!scm_is_string (s))
2409 scm_wrong_type_arg (FUNC_NAME, 0, s);
2410 if (scm_i_string_length (s) != 0)
a003f3eb
KR		 2411 {
2412 if (seen_nonempty)
2413 /* two or more non-empty strings, need full concat */
2414 return scm_string_append (rest);
2415
2416 seen_nonempty = 1;
2417 ret = s;
2418 }
2419 }
2420 return ret;
63181a97
MV		 2421}
2422#undef FUNC_NAME
2423
2424
2425SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
2426 (SCM ls),
2427 "Append the elements of @var{ls} (which must be strings)\n"
2428 "together into a single string. Guaranteed to return a freshly\n"
2429 "allocated string.")
2430#define FUNC_NAME s_scm_string_concatenate
2431{
57d98034 2432 SCM_VALIDATE_LIST (SCM_ARG1, ls);
63181a97
MV		 2433 return scm_string_append (ls);
2434}
2435#undef FUNC_NAME
2436
2437
2438SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
2439 (SCM ls, SCM final_string, SCM end),
2440 "Without optional arguments, this procedure is equivalent to\n"
2441 "\n"
2442 "@smalllisp\n"
2443 "(string-concatenate (reverse ls))\n"
2444 "@end smalllisp\n"
2445 "\n"
2446 "If the optional argument @var{final_string} is specified, it is\n"
2447 "consed onto the beginning to @var{ls} before performing the\n"
2448 "list-reverse and string-concatenate operations. If @var{end}\n"
2449 "is given, only the characters of @var{final_string} up to index\n"
2450 "@var{end} are used.\n"
2451 "\n"
2452 "Guaranteed to return a freshly allocated string.")
2453#define FUNC_NAME s_scm_string_concatenate_reverse
2454{
3731fc67
MV		 2455 if (!SCM_UNBNDP (end))
2456 final_string = scm_substring (final_string, SCM_INUM0, end);
63181a97 2457
63181a97 2458 if (!SCM_UNBNDP (final_string))
3731fc67 2459 ls = scm_cons (final_string, ls);
63181a97 2460
3731fc67 2461 return scm_string_concatenate (scm_reverse (ls));
63181a97
MV		 2462}
2463#undef FUNC_NAME
2464
2465
2466SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
2467 (SCM ls),
2468 "Like @code{string-concatenate}, but the result may share memory\n"
2469 "with the strings in the list @var{ls}.")
2470#define FUNC_NAME s_scm_string_concatenate_shared
2471{
57d98034 2472 SCM_VALIDATE_LIST (SCM_ARG1, ls);
63181a97
MV		 2473 return scm_string_append_shared (ls);
2474}
2475#undef FUNC_NAME
2476
2477
2478SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
2479 (SCM ls, SCM final_string, SCM end),
2480 "Like @code{string-concatenate-reverse}, but the result may\n"
ffb62a43 2481 "share memory with the strings in the @var{ls} arguments.")
63181a97
MV		 2482#define FUNC_NAME s_scm_string_concatenate_reverse_shared
2483{
2484 /* Just call the non-sharing version. */
2485 return scm_string_concatenate_reverse (ls, final_string, end);
2486}
2487#undef FUNC_NAME
2488
2489
2490SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
2491 (SCM proc, SCM s, SCM start, SCM end),
2492 "@var{proc} is a char->char procedure, it is mapped over\n"
2493 "@var{s}. The order in which the procedure is applied to the\n"
2494 "string elements is not specified.")
2495#define FUNC_NAME s_scm_string_map
2496{
f846bd1a 2497 size_t p;
63181a97
MV		 2498 size_t cstart, cend;
2499 SCM result;
2500
6c9e8a53
AW		 2501 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2502 proc, SCM_ARG1, FUNC_NAME);
3731fc67
MV		 2503 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2504 3, start, cstart,
2505 4, end, cend);
190d4b0d 2506 result = scm_i_make_string (cend - cstart, NULL, 0);
f846bd1a 2507 p = 0;
63181a97
MV		 2508 while (cstart < cend)
2509 {
6c9e8a53 2510 SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
63181a97
MV		 2511 if (!SCM_CHARP (ch))
2512 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
63181a97 2513 cstart++;
f846bd1a
MG		 2514 result = scm_i_string_start_writing (result);
2515 scm_i_string_set_x (result, p, SCM_CHAR (ch));
2516 scm_i_string_stop_writing ();
2517 p++;
63181a97 2518 }
f846bd1a 2519
63181a97
MV		 2520 return result;
2521}
2522#undef FUNC_NAME
2523
2524
2525SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
2526 (SCM proc, SCM s, SCM start, SCM end),
2527 "@var{proc} is a char->char procedure, it is mapped over\n"
2528 "@var{s}. The order in which the procedure is applied to the\n"
2529 "string elements is not specified. The string @var{s} is\n"
2530 "modified in-place, the return value is not specified.")
2531#define FUNC_NAME s_scm_string_map_x
2532{
2533 size_t cstart, cend;
2534
6c9e8a53
AW		 2535 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2536 proc, SCM_ARG1, FUNC_NAME);
63181a97
MV		 2537 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2538 3, start, cstart,
2539 4, end, cend);
2540 while (cstart < cend)
2541 {
6c9e8a53 2542 SCM ch = scm_call_1 (proc, scm_c_string_ref (s, cstart));
63181a97
MV		 2543 if (!SCM_CHARP (ch))
2544 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
f846bd1a
MG		 2545 s = scm_i_string_start_writing (s);
2546 scm_i_string_set_x (s, cstart, SCM_CHAR (ch));
2547 scm_i_string_stop_writing ();
63181a97
MV		 2548 cstart++;
2549 }
2550 return SCM_UNSPECIFIED;
2551}
2552#undef FUNC_NAME
2553
2554
2555SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
2556 (SCM kons, SCM knil, SCM s, SCM start, SCM end),
2557 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2558 "as the terminating element, from left to right. @var{kons}\n"
2559 "must expect two arguments: The actual character and the last\n"
2560 "result of @var{kons}' application.")
2561#define FUNC_NAME s_scm_string_fold
2562{
63181a97
MV		 2563 size_t cstart, cend;
2564 SCM result;
2565
2566 SCM_VALIDATE_PROC (1, kons);
f846bd1a
MG		 2567 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2568 4, start, cstart,
2569 5, end, cend);
63181a97
MV		 2570 result = knil;
2571 while (cstart < cend)
2572 {
f846bd1a 2573 result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result);
63181a97
MV		 2574 cstart++;
2575 }
3731fc67
MV		 2576
2577 scm_remember_upto_here_1 (s);
63181a97
MV		 2578 return result;
2579}
2580#undef FUNC_NAME
2581
2582
2583SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
2584 (SCM kons, SCM knil, SCM s, SCM start, SCM end),
2585 "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
2586 "as the terminating element, from right to left. @var{kons}\n"
2587 "must expect two arguments: The actual character and the last\n"
2588 "result of @var{kons}' application.")
2589#define FUNC_NAME s_scm_string_fold_right
2590{
63181a97
MV		 2591 size_t cstart, cend;
2592 SCM result;
2593
2594 SCM_VALIDATE_PROC (1, kons);
f846bd1a
MG		 2595 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2596 4, start, cstart,
2597 5, end, cend);
63181a97
MV		 2598 result = knil;
2599 while (cstart < cend)
2600 {
f846bd1a 2601 result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result);
63181a97
MV		 2602 cend--;
2603 }
3731fc67
MV		 2604
2605 scm_remember_upto_here_1 (s);
63181a97
MV		 2606 return result;
2607}
2608#undef FUNC_NAME
2609
2610
2611SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
2612 (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2613 "@itemize @bullet\n"
2614 "@item @var{g} is used to generate a series of @emph{seed}\n"
2615 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2616 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2617 "@dots{}\n"
2618 "@item @var{p} tells us when to stop -- when it returns true\n"
2619 "when applied to one of these seed values.\n"
2620 "@item @var{f} maps each seed value to the corresponding\n"
2621 "character in the result string. These chars are assembled\n"
2622 "into the string in a left-to-right order.\n"
2623 "@item @var{base} is the optional initial/leftmost portion\n"
2624 "of the constructed string; it default to the empty\n"
2625 "string.\n"
2626 "@item @var{make_final} is applied to the terminal seed\n"
2627 "value (on which @var{p} returns true) to produce\n"
2628 "the final/rightmost portion of the constructed string.\n"
2629 "It defaults to @code{(lambda (x) "")}.\n"
2630 "@end itemize")
2631#define FUNC_NAME s_scm_string_unfold
2632{
2633 SCM res, ans;
2634
2635 SCM_VALIDATE_PROC (1, p);
2636 SCM_VALIDATE_PROC (2, f);
2637 SCM_VALIDATE_PROC (3, g);
2638 if (!SCM_UNBNDP (base))
2639 {
2640 SCM_VALIDATE_STRING (5, base);
2641 ans = base;
2642 }
2643 else
190d4b0d 2644 ans = scm_i_make_string (0, NULL, 0);
63181a97
MV		 2645 if (!SCM_UNBNDP (make_final))
2646 SCM_VALIDATE_PROC (6, make_final);
2647
2648 res = scm_call_1 (p, seed);
2649 while (scm_is_false (res))
2650 {
2651 SCM str;
f846bd1a 2652 size_t i = 0;
63181a97
MV		 2653 SCM ch = scm_call_1 (f, seed);
2654 if (!SCM_CHARP (ch))
2655 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
190d4b0d 2656 str = scm_i_make_string (1, NULL, 0);
f846bd1a
MG		 2657 str = scm_i_string_start_writing (str);
2658 scm_i_string_set_x (str, i, SCM_CHAR (ch));
2659 scm_i_string_stop_writing ();
2660 i++;
63181a97
MV		 2661
2662 ans = scm_string_append (scm_list_2 (ans, str));
2663 seed = scm_call_1 (g, seed);
2664 res = scm_call_1 (p, seed);
2665 }
2666 if (!SCM_UNBNDP (make_final))
2667 {
2668 res = scm_call_1 (make_final, seed);
2669 return scm_string_append (scm_list_2 (ans, res));
2670 }
2671 else
2672 return ans;
2673}
2674#undef FUNC_NAME
2675
2676
2677SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
2678 (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
2679 "@itemize @bullet\n"
2680 "@item @var{g} is used to generate a series of @emph{seed}\n"
2681 "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
2682 "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
2683 "@dots{}\n"
2684 "@item @var{p} tells us when to stop -- when it returns true\n"
2685 "when applied to one of these seed values.\n"
2686 "@item @var{f} maps each seed value to the corresponding\n"
2687 "character in the result string. These chars are assembled\n"
2688 "into the string in a right-to-left order.\n"
2689 "@item @var{base} is the optional initial/rightmost portion\n"
2690 "of the constructed string; it default to the empty\n"
2691 "string.\n"
2692 "@item @var{make_final} is applied to the terminal seed\n"
2693 "value (on which @var{p} returns true) to produce\n"
2694 "the final/leftmost portion of the constructed string.\n"
2695 "It defaults to @code{(lambda (x) "")}.\n"
2696 "@end itemize")
2697#define FUNC_NAME s_scm_string_unfold_right
2698{
2699 SCM res, ans;
2700
2701 SCM_VALIDATE_PROC (1, p);
2702 SCM_VALIDATE_PROC (2, f);
2703 SCM_VALIDATE_PROC (3, g);
2704 if (!SCM_UNBNDP (base))
2705 {
2706 SCM_VALIDATE_STRING (5, base);
2707 ans = base;
2708 }
2709 else
190d4b0d 2710 ans = scm_i_make_string (0, NULL, 0);
63181a97
MV		 2711 if (!SCM_UNBNDP (make_final))
2712 SCM_VALIDATE_PROC (6, make_final);
2713
2714 res = scm_call_1 (p, seed);
2715 while (scm_is_false (res))
2716 {
2717 SCM str;
f846bd1a 2718 size_t i = 0;
63181a97
MV		 2719 SCM ch = scm_call_1 (f, seed);
2720 if (!SCM_CHARP (ch))
2721 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
190d4b0d 2722 str = scm_i_make_string (1, NULL, 0);
f846bd1a
MG		 2723 str = scm_i_string_start_writing (str);
2724 scm_i_string_set_x (str, i, SCM_CHAR (ch));
2725 scm_i_string_stop_writing ();
2726 i++;
63181a97
MV		 2727
2728 ans = scm_string_append (scm_list_2 (str, ans));
2729 seed = scm_call_1 (g, seed);
2730 res = scm_call_1 (p, seed);
2731 }
2732 if (!SCM_UNBNDP (make_final))
2733 {
2734 res = scm_call_1 (make_final, seed);
2735 return scm_string_append (scm_list_2 (res, ans));
2736 }
2737 else
2738 return ans;
2739}
2740#undef FUNC_NAME
2741
2742
2743SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
2744 (SCM proc, SCM s, SCM start, SCM end),
2745 "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
2746 "return value is not specified.")
2747#define FUNC_NAME s_scm_string_for_each
2748{
63181a97
MV		 2749 size_t cstart, cend;
2750
6c9e8a53
AW		 2751 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2752 proc, SCM_ARG1, FUNC_NAME);
9c44cd45
MG		 2753 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2754 3, start, cstart,
2755 4, end, cend);
63181a97
MV		 2756 while (cstart < cend)
2757 {
6c9e8a53 2758 scm_call_1 (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
63181a97
MV		 2759 cstart++;
2760 }
3731fc67
MV		 2761
2762 scm_remember_upto_here_1 (s);
63181a97
MV		 2763 return SCM_UNSPECIFIED;
2764}
2765#undef FUNC_NAME
2766
2767SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
2768 (SCM proc, SCM s, SCM start, SCM end),
1729055b
KR		 2769 "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
2770 "left to right.\n"
2771 "\n"
2772 "For example, to change characters to alternately upper and\n"
2773 "lower case,\n"
2774 "\n"
2775 "@example\n"
2776 "(define str (string-copy \"studly\"))\n"
2777 "(string-for-each-index\n"
2778 " (lambda (i)\n"
2779 " (string-set! str i\n"
2780 " ((if (even? i) char-upcase char-downcase)\n"
2781 " (string-ref str i))))\n"
2782 " str)\n"
2783 "str @result{} \"StUdLy\"\n"
2784 "@end example")
63181a97
MV		 2785#define FUNC_NAME s_scm_string_for_each_index
2786{
63181a97
MV		 2787 size_t cstart, cend;
2788
6c9e8a53
AW		 2789 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
2790 proc, SCM_ARG1, FUNC_NAME);
3731fc67
MV		 2791 MY_VALIDATE_SUBSTRING_SPEC (2, s,
2792 3, start, cstart,
2793 4, end, cend);
2794
63181a97
MV		 2795 while (cstart < cend)
2796 {
6c9e8a53 2797 scm_call_1 (proc, scm_from_size_t (cstart));
63181a97
MV		 2798 cstart++;
2799 }
3731fc67
MV		 2800
2801 scm_remember_upto_here_1 (s);
63181a97
MV		 2802 return SCM_UNSPECIFIED;
2803}
2804#undef FUNC_NAME
2805
2806SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
2807 (SCM s, SCM from, SCM to, SCM start, SCM end),
2808 "This is the @emph{extended substring} procedure that implements\n"
2809 "replicated copying of a substring of some string.\n"
2810 "\n"
2811 "@var{s} is a string, @var{start} and @var{end} are optional\n"
2812 "arguments that demarcate a substring of @var{s}, defaulting to\n"
2813 "0 and the length of @var{s}. Replicate this substring up and\n"
2814 "down index space, in both the positive and negative directions.\n"
2815 "@code{xsubstring} returns the substring of this string\n"
2816 "beginning at index @var{from}, and ending at @var{to}, which\n"
2817 "defaults to @var{from} + (@var{end} - @var{start}).")
2818#define FUNC_NAME s_scm_xsubstring
2819{
f846bd1a 2820 size_t p;
1a82a460
MV		 2821 size_t cstart, cend;
2822 int cfrom, cto;
63181a97
MV		 2823 SCM result;
2824
3731fc67
MV		 2825 MY_VALIDATE_SUBSTRING_SPEC (1, s,
2826 4, start, cstart,
2827 5, end, cend);
2828
1a82a460 2829 cfrom = scm_to_int (from);
63181a97
MV		 2830 if (SCM_UNBNDP (to))
2831 cto = cfrom + (cend - cstart);
2832 else
1a82a460 2833 cto = scm_to_int (to);
63181a97
MV		 2834 if (cstart == cend && cfrom != cto)
2835 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
2836
190d4b0d 2837 result = scm_i_make_string (cto - cfrom, NULL, 0);
f846bd1a 2838 result = scm_i_string_start_writing (result);
63181a97 2839
f846bd1a 2840 p = 0;
63181a97
MV		 2841 while (cfrom < cto)
2842 {
1a82a460 2843 size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
63181a97 2844 if (cfrom < 0)
f846bd1a
MG		 2845 scm_i_string_set_x (result, p,
2846 scm_i_string_ref (s, (cend - cstart) - t));
63181a97 2847 else
f846bd1a 2848 scm_i_string_set_x (result, p, scm_i_string_ref (s, t));
63181a97
MV		 2849 cfrom++;
2850 p++;
2851 }
f846bd1a 2852 scm_i_string_stop_writing ();
3731fc67 2853
63181a97
MV		 2854 scm_remember_upto_here_1 (s);
2855 return result;
2856}
2857#undef FUNC_NAME
2858
2859
2860SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
2861 (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
2862 "Exactly the same as @code{xsubstring}, but the extracted text\n"
2863 "is written into the string @var{target} starting at index\n"
2864 "@var{tstart}. The operation is not defined if @code{(eq?\n"
2865 "@var{target} @var{s})} or these arguments share storage -- you\n"
2866 "cannot copy a string on top of itself.")
2867#define FUNC_NAME s_scm_string_xcopy_x
2868{
f846bd1a 2869 size_t p;
1a82a460
MV		 2870 size_t ctstart, cstart, cend;
2871 int csfrom, csto;
63181a97 2872 SCM dummy = SCM_UNDEFINED;
616775ed 2873 size_t cdummy;
63181a97
MV		 2874
2875 MY_VALIDATE_SUBSTRING_SPEC (1, target,
2876 2, tstart, ctstart,
2877 2, dummy, cdummy);
3731fc67
MV		 2878 MY_VALIDATE_SUBSTRING_SPEC (3, s,
2879 6, start, cstart,
2880 7, end, cend);
1a82a460 2881 csfrom = scm_to_int (sfrom);
63181a97
MV		 2882 if (SCM_UNBNDP (sto))
2883 csto = csfrom + (cend - cstart);
2884 else
1a82a460 2885 csto = scm_to_int (sto);
b2fb40a9 2886 if (csfrom < csto)
63181a97 2887 {
b2fb40a9
MW		 2888 if (cstart == cend)
2889 SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
2890 SCM_ASSERT_RANGE (1, tstart,
2891 ctstart + (csto - csfrom) <= scm_i_string_length (target));
63181a97 2892
b2fb40a9
MW		 2893 p = 0;
2894 target = scm_i_string_start_writing (target);
2895 while (csfrom < csto)
2896 {
2897 size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
2898 if (csfrom < 0)
2899 scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
2900 else
2901 scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
2902 csfrom++;
2903 p++;
2904 }
2905 scm_i_string_stop_writing ();
2906
2907 scm_remember_upto_here_2 (target, s);
2908 }
63181a97
MV		 2909 return SCM_UNSPECIFIED;
2910}
2911#undef FUNC_NAME
2912
2913
2914SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
2915 (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
2916 "Return the string @var{s1}, but with the characters\n"
2917 "@var{start1} @dots{} @var{end1} replaced by the characters\n"
2918 "@var{start2} @dots{} @var{end2} from @var{s2}.")
2919#define FUNC_NAME s_scm_string_replace
2920{
63181a97
MV		 2921 size_t cstart1, cend1, cstart2, cend2;
2922 SCM result;
2923
3731fc67
MV		 2924 MY_VALIDATE_SUBSTRING_SPEC (1, s1,
2925 3, start1, cstart1,
2926 4, end1, cend1);
2927 MY_VALIDATE_SUBSTRING_SPEC (2, s2,
2928 5, start2, cstart2,
2929 6, end2, cend2);
f846bd1a
MG		 2930 return (scm_string_append
2931 (scm_list_3 (scm_i_substring (s1, 0, cstart1),
2932 scm_i_substring (s2, cstart2, cend2),
2933 scm_i_substring (s1, cend1, scm_i_string_length (s1)))));
63181a97
MV		 2934 return result;
2935}
2936#undef FUNC_NAME
2937
2938
2939SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
2940 (SCM s, SCM token_set, SCM start, SCM end),
2941 "Split the string @var{s} into a list of substrings, where each\n"
2942 "substring is a maximal non-empty contiguous sequence of\n"
2943 "characters from the character set @var{token_set}, which\n"
2944 "defaults to @code{char-set:graphic}.\n"
2945 "If @var{start} or @var{end} indices are provided, they restrict\n"
2946 "@code{string-tokenize} to operating on the indicated substring\n"
2947 "of @var{s}.")
2948#define FUNC_NAME s_scm_string_tokenize
2949{
63181a97
MV		 2950 size_t cstart, cend;
2951 SCM result = SCM_EOL;
2952
f846bd1a
MG		 2953 MY_VALIDATE_SUBSTRING_SPEC (1, s,
2954 3, start, cstart,
2955 4, end, cend);
63181a97
MV		 2956
2957 if (SCM_UNBNDP (token_set))
2958 token_set = scm_char_set_graphic;
2959
2960 if (SCM_CHARSETP (token_set))
2961 {
1a82a460 2962 size_t idx;
63181a97
MV		 2963
2964 while (cstart < cend)
2965 {
2966 while (cstart < cend)
2967 {
f846bd1a 2968 if (REF_IN_CHARSET (s, cend-1, token_set))
63181a97
MV		 2969 break;
2970 cend--;
2971 }
2972 if (cstart >= cend)
2973 break;
2974 idx = cend;
2975 while (cstart < cend)
2976 {
f846bd1a 2977 if (!REF_IN_CHARSET (s, cend-1, token_set))
63181a97
MV		 2978 break;
2979 cend--;
2980 }
f846bd1a 2981 result = scm_cons (scm_i_substring (s, cend, idx), result);
63181a97
MV		 2982 }
2983 }
3731fc67
MV		 2984 else
2985 SCM_WRONG_TYPE_ARG (2, token_set);
2986
63181a97
MV		 2987 scm_remember_upto_here_1 (s);
2988 return result;
2989}
2990#undef FUNC_NAME
2991
2992SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
2993 (SCM str, SCM chr),
ffb62a43 2994 "Split the string @var{str} into a list of the substrings delimited\n"
63181a97
MV		 2995 "by appearances of the character @var{chr}. Note that an empty substring\n"
2996 "between separator characters will result in an empty string in the\n"
2997 "result list.\n"
2998 "\n"
2999 "@lisp\n"
3000 "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
3001 "@result{}\n"
3002 "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
3003 "\n"
3004 "(string-split \"::\" #\\:)\n"
3005 "@result{}\n"
3006 "(\"\" \"\" \"\")\n"
3007 "\n"
3008 "(string-split \"\" #\\:)\n"
3009 "@result{}\n"
3010 "(\"\")\n"
3011 "@end lisp")
3012#define FUNC_NAME s_scm_string_split
3013{
3014 long idx, last_idx;
f846bd1a 3015 int narrow;
63181a97
MV		 3016 SCM res = SCM_EOL;
3017
3018 SCM_VALIDATE_STRING (1, str);
3019 SCM_VALIDATE_CHAR (2, chr);
f846bd1a
MG		 3020
3021 /* This is explicit wide/narrow logic (instead of using
3022 scm_i_string_ref) is a speed optimization. */
63181a97 3023 idx = scm_i_string_length (str);
f846bd1a
MG		 3024 narrow = scm_i_is_narrow_string (str);
3025 if (narrow)
3026 {
3027 const char *buf = scm_i_string_chars (str);
3028 while (idx >= 0)
3029 {
3030 last_idx = idx;
3031 while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
3032 idx--;
3033 if (idx >= 0)
3034 {
3035 res = scm_cons (scm_i_substring (str, idx, last_idx), res);
3036 idx--;
3037 }
3038 }
3039 }
3040 else
3041 {
3042 const scm_t_wchar *buf = scm_i_string_wide_chars (str);
3043 while (idx >= 0)
3044 {
3045 last_idx = idx;
3046 while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
3047 idx--;
3048 if (idx >= 0)
3049 {
3050 res = scm_cons (scm_i_substring (str, idx, last_idx), res);
3051 idx--;
3052 }
3053 }
63181a97
MV		 3054 }
3055 scm_remember_upto_here_1 (str);
3056 return res;
3057}
3058#undef FUNC_NAME
3059
3060
3061SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
9fe717e2 3062 (SCM char_pred, SCM s, SCM start, SCM end),
8753a993 3063 "Filter the string @var{s}, retaining only those characters\n"
85912343 3064 "which satisfy @var{char_pred}.\n"
8753a993
KR		 3065 "\n"
3066 "If @var{char_pred} is a procedure, it is applied to each\n"
3067 "character as a predicate, if it is a character, it is tested\n"
3068 "for equality and if it is a character set, it is tested for\n"
3069 "membership.")
63181a97
MV		 3070#define FUNC_NAME s_scm_string_filter
3071{
63181a97
MV		 3072 size_t cstart, cend;
3073 SCM result;
3074 size_t idx;
3075
215e0312 3076#if SCM_ENABLE_DEPRECATED == 1
9fe717e2
AW		 3077 if (scm_is_string (char_pred))
3078 {
3079 SCM tmp;
215e0312 3080
9fe717e2
AW		 3081 scm_c_issue_deprecation_warning
3082 ("Guile used to use the wrong argument order for string-filter.\n"
3083 "This call to string-filter had the arguments in the wrong order.\n"
3084 "See SRFI-13 for more details. At some point we will remove this hack.");
3085
3086 tmp = char_pred;
3087 char_pred = s;
3088 s = tmp;
3089 }
215e0312 3090#endif
9fe717e2
AW		 3091
3092 MY_VALIDATE_SUBSTRING_SPEC (2, s,
f846bd1a
MG		 3093 3, start, cstart,
3094 4, end, cend);
85912343
KR		 3095
3096 /* The explicit loops below stripping leading and trailing non-matches
3097 mean we can return a substring if those are the only deletions, making
3098 string-filter as efficient as string-trim-both in that case. */
3099
63181a97
MV		 3100 if (SCM_CHARP (char_pred))
3101 {
8753a993 3102 size_t count;
85912343
KR		 3103
3104 /* strip leading non-matches by incrementing cstart */
f846bd1a 3105 while (cstart < cend && scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
85912343
KR		 3106 cstart++;
3107
3108 /* strip trailing non-matches by decrementing cend */
f846bd1a 3109 while (cend > cstart && scm_i_string_ref (s, cend-1) != SCM_CHAR (char_pred))
85912343
KR		 3110 cend--;
3111
3112 /* count chars to keep */
8753a993
KR		 3113 count = 0;
3114 for (idx = cstart; idx < cend; idx++)
f846bd1a 3115 if (scm_i_string_ref (s, idx) == SCM_CHAR (char_pred))
8753a993
KR		 3116 count++;
3117
8753a993 3118 if (count == cend - cstart)
8230ee41 3119 {
85912343
KR		 3120 /* whole of cstart to cend is to be kept, return a copy-on-write
3121 substring */
8230ee41
KR		 3122 result_substring:
3123 result = scm_i_substring (s, cstart, cend);
3124 }
8753a993
KR		 3125 else
3126 result = scm_c_make_string (count, char_pred);
63181a97
MV		 3127 }
3128 else if (SCM_CHARSETP (char_pred))
3129 {
8753a993 3130 size_t count;
63181a97 3131
85912343 3132 /* strip leading non-matches by incrementing cstart */
f846bd1a 3133 while (cstart < cend && ! REF_IN_CHARSET (s, cstart, char_pred))
85912343
KR		 3134 cstart++;
3135
3136 /* strip trailing non-matches by decrementing cend */
f846bd1a 3137 while (cend > cstart && ! REF_IN_CHARSET (s, cend-1, char_pred))
85912343
KR		 3138 cend--;
3139
8753a993
KR		 3140 /* count chars to be kept */
3141 count = 0;
3142 for (idx = cstart; idx < cend; idx++)
f846bd1a 3143 if (REF_IN_CHARSET (s, idx, char_pred))
8753a993
KR		 3144 count++;
3145
8230ee41 3146 /* if whole of start to end kept then return substring */
8753a993 3147 if (count == cend - cstart)
8230ee41 3148 goto result_substring;
8753a993
KR		 3149 else
3150 {
f846bd1a 3151 size_t dst = 0;
190d4b0d 3152 result = scm_i_make_string (count, NULL, 0);
f846bd1a 3153 result = scm_i_string_start_writing (result);
8753a993
KR		 3154
3155 /* decrement "count" in this loop as well as using idx, so that if
3156 another thread is simultaneously changing "s" there's no chance
3157 it'll make us copy more than count characters */
3158 for (idx = cstart; idx < cend && count != 0; idx++)
3159 {
f846bd1a 3160 if (REF_IN_CHARSET (s, idx, char_pred))
8753a993 3161 {
f846bd1a
MG		 3162 scm_i_string_set_x (result, dst, scm_i_string_ref (s, idx));
3163 dst ++;
8753a993
KR		 3164 count--;
3165 }
3166 }
f846bd1a 3167 scm_i_string_stop_writing ();
8753a993 3168 }
63181a97
MV		 3169 }
3170 else
3171 {
3172 SCM ls = SCM_EOL;
3173
6c9e8a53 3174 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
9fe717e2 3175 char_pred, SCM_ARG1, FUNC_NAME);
63181a97
MV		 3176 idx = cstart;
3177 while (idx < cend)
3178 {
3731fc67 3179 SCM res, ch;
f846bd1a 3180 ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
6c9e8a53 3181 res = scm_call_1 (char_pred, ch);
63181a97 3182 if (scm_is_true (res))
3731fc67 3183 ls = scm_cons (ch, ls);
63181a97
MV		 3184 idx++;
3185 }
3186 result = scm_reverse_list_to_string (ls);
3187 }
3731fc67 3188
63181a97
MV		 3189 scm_remember_upto_here_1 (s);
3190 return result;
3191}
3192#undef FUNC_NAME
3193
3194
3195SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
9fe717e2 3196 (SCM char_pred, SCM s, SCM start, SCM end),
85912343 3197 "Delete characters satisfying @var{char_pred} from @var{s}.\n"
8753a993
KR		 3198 "\n"
3199 "If @var{char_pred} is a procedure, it is applied to each\n"
3200 "character as a predicate, if it is a character, it is tested\n"
3201 "for equality and if it is a character set, it is tested for\n"
3202 "membership.")
63181a97
MV		 3203#define FUNC_NAME s_scm_string_delete
3204{
63181a97
MV		 3205 size_t cstart, cend;
3206 SCM result;
3207 size_t idx;
3208
215e0312 3209#if SCM_ENABLE_DEPRECATED == 1
9fe717e2
AW		 3210 if (scm_is_string (char_pred))
3211 {
3212 SCM tmp;
215e0312 3213
9fe717e2
AW		 3214 scm_c_issue_deprecation_warning
3215 ("Guile used to use the wrong argument order for string-delete.\n"
3216 "This call to string-filter had the arguments in the wrong order.\n"
3217 "See SRFI-13 for more details. At some point we will remove this hack.");
3218
3219 tmp = char_pred;
3220 char_pred = s;
3221 s = tmp;
3222 }
215e0312 3223#endif
9fe717e2
AW		 3224
3225 MY_VALIDATE_SUBSTRING_SPEC (2, s,
f846bd1a
MG		 3226 3, start, cstart,
3227 4, end, cend);
85912343
KR		 3228
3229 /* The explicit loops below stripping leading and trailing matches mean we
3230 can return a substring if those are the only deletions, making
3231 string-delete as efficient as string-trim-both in that case. */
3232
63181a97
MV		 3233 if (SCM_CHARP (char_pred))
3234 {
8753a993 3235 size_t count;
8753a993 3236
85912343 3237 /* strip leading matches by incrementing cstart */
f846bd1a 3238 while (cstart < cend && scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
85912343
KR		 3239 cstart++;
3240
3241 /* strip trailing matches by decrementing cend */
f846bd1a 3242 while (cend > cstart && scm_i_string_ref (s, cend-1) == SCM_CHAR (char_pred))
85912343
KR		 3243 cend--;
3244
8753a993
KR		 3245 /* count chars to be kept */
3246 count = 0;
3247 for (idx = cstart; idx < cend; idx++)
f846bd1a 3248 if (scm_i_string_ref (s, idx) != SCM_CHAR (char_pred))
8753a993
KR		 3249 count++;
3250
8753a993
KR		 3251 if (count == cend - cstart)
3252 {
85912343
KR		 3253 /* whole of cstart to cend is to be kept, return a copy-on-write
3254 substring */
8753a993 3255 result_substring:
8230ee41 3256 result = scm_i_substring (s, cstart, cend);
8753a993
KR		 3257 }
3258 else
3259 {
f846bd1a 3260 int i = 0;
8753a993 3261 /* new string for retained portion */
190d4b0d 3262 result = scm_i_make_string (count, NULL, 0);
f846bd1a 3263 result = scm_i_string_start_writing (result);
8753a993
KR		 3264 /* decrement "count" in this loop as well as using idx, so that if
3265 another thread is simultaneously changing "s" there's no chance
3266 it'll make us copy more than count characters */
3267 for (idx = cstart; idx < cend && count != 0; idx++)
3268 {
f846bd1a
MG		 3269 scm_t_wchar c = scm_i_string_ref (s, idx);
3270 if (c != SCM_CHAR (char_pred))
8753a993 3271 {
f846bd1a
MG		 3272 scm_i_string_set_x (result, i, c);
3273 i++;
8753a993
KR		 3274 count--;
3275 }
3276 }
f846bd1a 3277 scm_i_string_stop_writing ();
8753a993 3278 }
63181a97
MV		 3279 }
3280 else if (SCM_CHARSETP (char_pred))
3281 {
8753a993 3282 size_t count;
63181a97 3283
85912343 3284 /* strip leading matches by incrementing cstart */
f846bd1a 3285 while (cstart < cend && REF_IN_CHARSET (s, cstart, char_pred))
85912343
KR		 3286 cstart++;
3287
3288 /* strip trailing matches by decrementing cend */
f846bd1a 3289 while (cend > cstart && REF_IN_CHARSET (s, cend-1, char_pred))
85912343
KR		 3290 cend--;
3291
8753a993
KR		 3292 /* count chars to be kept */
3293 count = 0;
3294 for (idx = cstart; idx < cend; idx++)
f846bd1a 3295 if (!REF_IN_CHARSET (s, idx, char_pred))
8753a993
KR		 3296 count++;
3297
8753a993
KR		 3298 if (count == cend - cstart)
3299 goto result_substring;
3300 else
3301 {
f846bd1a 3302 size_t i = 0;
8753a993 3303 /* new string for retained portion */
190d4b0d 3304 result = scm_i_make_string (count, NULL, 0);
f846bd1a 3305 result = scm_i_string_start_writing (result);
8753a993
KR		 3306
3307 /* decrement "count" in this loop as well as using idx, so that if
3308 another thread is simultaneously changing "s" there's no chance
3309 it'll make us copy more than count characters */
3310 for (idx = cstart; idx < cend && count != 0; idx++)
3311 {
f846bd1a 3312 if (!REF_IN_CHARSET (s, idx, char_pred))
8753a993 3313 {
f846bd1a
MG		 3314 scm_i_string_set_x (result, i, scm_i_string_ref (s, idx));
3315 i++;
8753a993
KR		 3316 count--;
3317 }
3318 }
f846bd1a 3319 scm_i_string_stop_writing ();
8753a993 3320 }
63181a97
MV		 3321 }
3322 else
3323 {
3324 SCM ls = SCM_EOL;
6c9e8a53 3325 SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
9fe717e2 3326 char_pred, SCM_ARG1, FUNC_NAME);
63181a97 3327
63181a97
MV		 3328 idx = cstart;
3329 while (idx < cend)
3330 {
f846bd1a 3331 SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
6c9e8a53 3332 res = scm_call_1 (char_pred, ch);
63181a97 3333 if (scm_is_false (res))
3731fc67 3334 ls = scm_cons (ch, ls);
63181a97
MV		 3335 idx++;
3336 }
3337 result = scm_reverse_list_to_string (ls);
3338 }
3731fc67
MV		 3339
3340 scm_remember_upto_here_1 (s);
63181a97
MV		 3341 return result;
3342}
3343#undef FUNC_NAME
3344
63181a97
MV		 3345void
3346scm_init_srfi_13 (void)
3347{
3348#include "libguile/srfi-13.x"
3349}
3350
3351/* End of srfi-13.c. */
Unnamed repository; edit this file 'description' to name the repository.