guile18/libguile/srfi-13.c

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