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