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