Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp

[bpt/guile.git] / libguile / srfi-13.c

/* srfi-13.c --- SRFI-13 procedures for Guile
 *
 * Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */


#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <string.h>
#include <ctype.h>

#include "libguile.h"

#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"

/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
   messing with the internal representation of strings.  We define our
   own version since we use it so much and are messing with Guile
   internals anyway.
*/

#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str,        \
                                        pos_start, start, c_start,  \
                                        pos_end, end, c_end)        \
  do {                                                              \
    SCM_VALIDATE_STRING (pos_str, str);                             \
    c_str = scm_i_string_chars (str);                               \
    scm_i_get_substring_spec (scm_i_string_length (str),            \
                              start, &c_start, end, &c_end);        \
  } while (0)

/* Expecting "unsigned char *c_str" */
#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str,           \
                                         pos_start, start, c_start,     \
                                         pos_end, end, c_end)           \
  do {                                                                  \
    const char *signed_c_str;                                           \
    MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str,         \
                                    pos_start, start, c_start,          \
                                    pos_end, end, c_end);               \
    c_str = (unsigned char *) signed_c_str;                             \
  } while (0)

#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str,              \
                                   pos_start, start, c_start, \
                                   pos_end, end, c_end)       \
  do {                                                        \
    SCM_VALIDATE_STRING (pos_str, str);                       \
    scm_i_get_substring_spec (scm_i_string_length (str),      \
                              start, &c_start, end, &c_end);  \
  } while (0)

SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
           (SCM str),
            "Return @code{#t} if @var{str}'s length is zero, and\n"
            "@code{#f} otherwise.\n"
            "@lisp\n"
            "(string-null? \"\")  @result{} #t\n"
            "y                    @result{} \"foo\"\n"
            "(string-null? y)     @result{} #f\n"
            "@end lisp")
#define FUNC_NAME s_scm_string_null_p
{
  SCM_VALIDATE_STRING (1, str);
  return scm_from_bool (scm_i_string_length (str) == 0);
}
#undef FUNC_NAME

#if 0
static void
race_error ()
{
  scm_misc_error (NULL, "race condition detected", SCM_EOL);
}
#endif

SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
            (SCM char_pred, SCM s, SCM start, SCM end),
"Check if @var{char_pred} is true for any character in string @var{s}.\n"
"\n"
"@var{char_pred} can be a character to check for any equal to that, or\n"
"a character set (@pxref{Character Sets}) to check for any in that set,\n"
"or a predicate procedure to call.\n"
"\n"
"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
"successively on the characters from @var{start} to @var{end}.  If\n"
"@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
"stops and that return value is the return from @code{string-any}.  The\n"
"call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
"point is reached, is a tail call.\n"
"\n"
"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
"@var{end}) then the return is @code{#f}.\n")
#define FUNC_NAME s_scm_string_any
{
  const char *cstr;
  size_t cstart, cend;
  SCM res = SCM_BOOL_F;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);

  if (SCM_CHARP (char_pred))
    {
      res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
                     cend-cstart) == NULL
             ? SCM_BOOL_F : SCM_BOOL_T);
    }
  else if (SCM_CHARSETP (char_pred))
    {
      size_t i;
      for (i = cstart; i < cend; i++)
        if (SCM_CHARSET_GET (char_pred, cstr[i]))
          {
            res = SCM_BOOL_T;
            break;
          }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);

      while (cstart < cend)
        {
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_true (res))
            break;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }

  scm_remember_upto_here_1 (s);
  return res;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
            (SCM char_pred, SCM s, SCM start, SCM end),
"Check if @var{char_pred} is true for every character in string\n"
"@var{s}.\n"
"\n"
"@var{char_pred} can be a character to check for every character equal\n"
"to that, or a character set (@pxref{Character Sets}) to check for\n"
"every character being in that set, or a predicate procedure to call.\n"
"\n"
"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
"successively on the characters from @var{start} to @var{end}.  If\n"
"@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
"returns @code{#f}.  The call on the last character (ie.@: at\n"
"@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
"return from that call is the return from @code{string-every}.\n"
"\n"
"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
"@var{end}) then the return is @code{#t}.\n")
#define FUNC_NAME s_scm_string_every
{
  const char *cstr;
  size_t cstart, cend;
  SCM res = SCM_BOOL_T;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      size_t i;
      for (i = cstart; i < cend; i++)
        if (cstr[i] != cchr)
          {
            res = SCM_BOOL_F;
            break;
          }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      size_t i;
      for (i = cstart; i < cend; i++)
        if (!SCM_CHARSET_GET (char_pred, cstr[i]))
          {
            res = SCM_BOOL_F;
            break;
          }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);

      while (cstart < cend)
        {
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_false (res))
            break;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }

  scm_remember_upto_here_1 (s);
  return res;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
            (SCM proc, SCM len),
            "@var{proc} is an integer->char procedure.  Construct a string\n"
            "of size @var{len} by applying @var{proc} to each index to\n"
            "produce the corresponding string element.  The order in which\n"
            "@var{proc} is applied to the indices is not specified.")
#define FUNC_NAME s_scm_string_tabulate
{
  size_t clen, i;
  SCM res;
  SCM ch;
  char *p;
  scm_t_trampoline_1 proc_tramp;

  proc_tramp = scm_trampoline_1 (proc);
  SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);

  clen = scm_to_size_t (len);
  SCM_ASSERT_RANGE (2, len, clen >= 0);

  res = scm_i_make_string (clen, &p);
  i = 0;
  while (i < clen)
    {
      /* The RES string remains untouched since nobody knows about it
         yet. No need to refetch P.
      */
      ch = proc_tramp (proc, scm_from_size_t (i));
      if (!SCM_CHARP (ch))
        SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
      *p++ = SCM_CHAR (ch);
      i++;
    }
  return res;
}
#undef FUNC_NAME


SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Convert the string @var{str} into a list of characters.")
#define FUNC_NAME s_scm_substring_to_list
{
  const char *cstr;
  size_t cstart, cend;
  SCM result = SCM_EOL;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  while (cstart < cend)
    {
      cend--;
      result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
      cstr = scm_i_string_chars (str);
    }
  scm_remember_upto_here_1 (str);
  return result;
}
#undef FUNC_NAME

/* We export scm_substring_to_list as "string->list" since it is
   compatible and more general.  This function remains for the benefit
   of C code that used it.
*/

SCM
scm_string_to_list (SCM str)
{
  return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED);
}

SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
            (SCM chrs),
            "An efficient implementation of @code{(compose string->list\n"
            "reverse)}:\n"
            "\n"
            "@smalllisp\n"
            "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
            "@end smalllisp")
#define FUNC_NAME s_scm_reverse_list_to_string
{
  SCM result;
  long i = scm_ilength (chrs);
  char *data;

  if (i < 0)
    SCM_WRONG_TYPE_ARG (1, chrs);
  result = scm_i_make_string (i, &data);

  {
    
    data += i;
    while (i > 0 && scm_is_pair (chrs))
      {
        SCM elt = SCM_CAR (chrs);

        SCM_VALIDATE_CHAR (SCM_ARGn, elt);
        data--;
        *data = SCM_CHAR (elt);
        chrs = SCM_CDR (chrs);
        i--;
      }
  }

  return result;
}
#undef FUNC_NAME


SCM_SYMBOL (scm_sym_infix, "infix");
SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
SCM_SYMBOL (scm_sym_suffix, "suffix");
SCM_SYMBOL (scm_sym_prefix, "prefix");

static void
append_string (char **sp, size_t *lp, SCM str)
{
  size_t len;
  len = scm_c_string_length (str);
  if (len > *lp)
    len = *lp;
  memcpy (*sp, scm_i_string_chars (str), len);
  *lp -= len;
  *sp += len;
}

SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
            (SCM ls, SCM delimiter, SCM grammar),
            "Append the string in the string list @var{ls}, using the string\n"
            "@var{delim} as a delimiter between the elements of @var{ls}.\n"
            "@var{grammar} is a symbol which specifies how the delimiter is\n"
            "placed between the strings, and defaults to the symbol\n"
            "@code{infix}.\n"
            "\n"
            "@table @code\n"
            "@item infix\n"
            "Insert the separator between list elements.  An empty string\n"
            "will produce an empty list.\n"
            "@item string-infix\n"
            "Like @code{infix}, but will raise an error if given the empty\n"
            "list.\n"
            "@item suffix\n"
            "Insert the separator after every list element.\n"
            "@item prefix\n"
            "Insert the separator before each list element.\n"
            "@end table")
#define FUNC_NAME s_scm_string_join
{
#define GRAM_INFIX        0
#define GRAM_STRICT_INFIX 1
#define GRAM_SUFFIX       2
#define GRAM_PREFIX       3
  SCM tmp;
  SCM result;
  int gram = GRAM_INFIX;
  size_t del_len = 0;
  size_t len = 0;
  char *p;
  long strings = scm_ilength (ls);

  /* Validate the string list.  */
  if (strings < 0)
    SCM_WRONG_TYPE_ARG (1, ls);

  /* Validate the delimiter and record its length.  */
  if (SCM_UNBNDP (delimiter))
    {
      delimiter = scm_from_locale_string (" ");
      del_len = 1;
    }
  else
    del_len = scm_c_string_length (delimiter);

  /* Validate the grammar symbol and remember the grammar.  */
  if (SCM_UNBNDP (grammar))
    gram = GRAM_INFIX;
  else if (scm_is_eq (grammar, scm_sym_infix))
    gram = GRAM_INFIX;
  else if (scm_is_eq (grammar, scm_sym_strict_infix))
    gram = GRAM_STRICT_INFIX;
  else if (scm_is_eq (grammar, scm_sym_suffix))
    gram = GRAM_SUFFIX;
  else if (scm_is_eq (grammar, scm_sym_prefix))
    gram = GRAM_PREFIX;
  else
    SCM_WRONG_TYPE_ARG (3, grammar);

  /* Check grammar constraints and calculate the space required for
     the delimiter(s).  */
  switch (gram)
    {
    case GRAM_INFIX:
      if (!scm_is_null (ls))
        len = (strings > 0) ? ((strings - 1) * del_len) : 0;
      break;
    case GRAM_STRICT_INFIX:
      if (strings == 0)
        SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
                        SCM_EOL);
      len = (strings - 1) * del_len;
      break;
    default:
      len = strings * del_len;
      break;
    }

  tmp = ls;
  while (scm_is_pair (tmp))
    {
      len += scm_c_string_length (SCM_CAR (tmp));
      tmp = SCM_CDR (tmp);
    }

  result = scm_i_make_string (len, &p);

  tmp = ls;
  switch (gram)
    {
    case GRAM_INFIX:
    case GRAM_STRICT_INFIX:
      while (scm_is_pair (tmp))
        {
          append_string (&p, &len, SCM_CAR (tmp));
          if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
            append_string (&p, &len, delimiter);
          tmp = SCM_CDR (tmp);
        }
      break;
    case GRAM_SUFFIX:
      while (scm_is_pair (tmp))
        {
          append_string (&p, &len, SCM_CAR (tmp));
          if (del_len > 0)
            append_string (&p, &len, delimiter);
          tmp = SCM_CDR (tmp);
        }
      break;
    case GRAM_PREFIX:
      while (scm_is_pair (tmp))
        {
          if (del_len > 0)
            append_string (&p, &len, delimiter);
          append_string (&p, &len, SCM_CAR (tmp));
          tmp = SCM_CDR (tmp);
        }
      break;
    }

  return result;
#undef GRAM_INFIX
#undef GRAM_STRICT_INFIX
#undef GRAM_SUFFIX
#undef GRAM_PREFIX
}
#undef FUNC_NAME


/* There are a number of functions to consider here for Scheme and C:

   string-copy STR [start [end]]    ;; SRFI-13 variant of R5RS string-copy
   substring/copy STR start [end]   ;; Guile variant of R5RS substring

   scm_string_copy (str)            ;; Old function from Guile
   scm_substring_copy (str, [start, [end]])
                                    ;; C version of SRFI-13 string-copy
                                    ;; and C version of substring/copy

   The C function underlying string-copy is not exported to C
   programs.  scm_substring_copy is defined in strings.c as the
   underlying function of substring/copy and allows an optional START
   argument.
*/

SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end);

SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Return a freshly allocated copy of the string @var{str}.  If\n"
            "given, @var{start} and @var{end} delimit the portion of\n"
            "@var{str} which is copied.")
#define FUNC_NAME s_scm_srfi13_substring_copy
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return scm_c_substring_copy (str, cstart, cend);
}
#undef FUNC_NAME

SCM 
scm_string_copy (SCM str)
{
  return scm_c_substring (str, 0, scm_c_string_length (str));
}

SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
            (SCM target, SCM tstart, SCM s, SCM start, SCM end),
            "Copy the sequence of characters from index range [@var{start},\n"
            "@var{end}) in string @var{s} to string @var{target}, beginning\n"
            "at index @var{tstart}.  The characters are copied left-to-right\n"
            "or right-to-left as needed -- the copy is guaranteed to work,\n"
            "even if @var{target} and @var{s} are the same string.  It is an\n"
            "error if the copy operation runs off the end of the target\n"
            "string.")
#define FUNC_NAME s_scm_string_copy_x
{
  const char *cstr;
  char *ctarget;
  size_t cstart, cend, ctstart, dummy, len;
  SCM sdummy = SCM_UNDEFINED;

  MY_VALIDATE_SUBSTRING_SPEC (1, target,
                              2, tstart, ctstart,
                              2, sdummy, dummy);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
                                   4, start, cstart,
                                   5, end, cend);
  len = cend - cstart;
  SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);

  ctarget = scm_i_string_writable_chars (target);
  memmove (ctarget + ctstart, cstr + cstart, len);
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (target);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
            (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
            "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
            "into @var{str2} beginning at position @var{start2}.\n"
            "@var{str1} and @var{str2} can be the same string.")
#define FUNC_NAME s_scm_substring_move_x
{
  return scm_string_copy_x (str2, start2, str1, start1, end1);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
            (SCM s, SCM n),
            "Return the @var{n} first characters of @var{s}.")
#define FUNC_NAME s_scm_string_take
{
  return scm_substring (s, SCM_INUM0, n);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
            (SCM s, SCM n),
            "Return all but the first @var{n} characters of @var{s}.")
#define FUNC_NAME s_scm_string_drop
{
  return scm_substring (s, n, SCM_UNDEFINED);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
            (SCM s, SCM n),
            "Return the @var{n} last characters of @var{s}.")
#define FUNC_NAME s_scm_string_take_right
{
  return scm_substring (s,
                        scm_difference (scm_string_length (s), n),
                        SCM_UNDEFINED);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
            (SCM s, SCM n),
            "Return all but the last @var{n} characters of @var{s}.")
#define FUNC_NAME s_scm_string_drop_right
{
  return scm_substring (s,
                        SCM_INUM0,
                        scm_difference (scm_string_length (s), n));
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
            (SCM s, SCM len, SCM chr, SCM start, SCM end),
            "Take that characters from @var{start} to @var{end} from the\n"
            "string @var{s} and return a new string, right-padded by the\n"
            "character @var{chr} to length @var{len}.  If the resulting\n"
            "string is longer than @var{len}, it is truncated on the right.")
#define FUNC_NAME s_scm_string_pad
{
  char cchr;
  size_t cstart, cend, clen;

  MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              4, start, cstart,
                              5, end, cend);
  clen = scm_to_size_t (len);

  if (SCM_UNBNDP (chr))
    cchr = ' ';
  else
    {
      SCM_VALIDATE_CHAR (3, chr);
      cchr = SCM_CHAR (chr);
    }
  if (clen < (cend - cstart))
    return scm_c_substring (s, cend - clen, cend);
  else
    {
      SCM result;
      char *dst;

      result = scm_i_make_string (clen, &dst);
      memset (dst, cchr, (clen - (cend - cstart)));
      memmove (dst + clen - (cend - cstart),
               scm_i_string_chars (s) + cstart, cend - cstart);
      return result;
    }
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
            (SCM s, SCM len, SCM chr, SCM start, SCM end),
            "Take that characters from @var{start} to @var{end} from the\n"
            "string @var{s} and return a new string, left-padded by the\n"
            "character @var{chr} to length @var{len}.  If the resulting\n"
            "string is longer than @var{len}, it is truncated on the left.")
#define FUNC_NAME s_scm_string_pad_right
{
  char cchr;
  size_t cstart, cend, clen;

  MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              4, start, cstart,
                              5, end, cend);
  clen = scm_to_size_t (len);

  if (SCM_UNBNDP (chr))
    cchr = ' ';
  else
    {
      SCM_VALIDATE_CHAR (3, chr);
      cchr = SCM_CHAR (chr);
    }
  if (clen < (cend - cstart))
    return scm_c_substring (s, cstart, cstart + clen);
  else
    {
      SCM result;
      char *dst;

      result = scm_i_make_string (clen, &dst);
      memset (dst + (cend - cstart), cchr, clen - (cend - cstart));
      memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart);
      return result;
    }
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Trim @var{s} by skipping over all characters on the left\n"
            "that satisfy the parameter @var{char_pred}:\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "if it is the character @var{ch}, characters equal to\n"
            "@var{ch} are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a procedure @var{pred} characters that\n"
            "satisfy @var{pred} are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a character set, characters in that set are trimmed.\n"
            "@end itemize\n"
            "\n"
            "If called without a @var{char_pred} argument, all whitespace is\n"
            "trimmed.")
#define FUNC_NAME s_scm_string_trim
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_UNBNDP (char_pred))
    {
      while (cstart < cend)
        {
          if (!isspace((int) (unsigned char) cstr[cstart]))
            break;
          cstart++;
        }
    }
  else if (SCM_CHARP (char_pred))
    {
      char chr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (chr != cstr[cstart])
            break;
          cstart++;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
            break;
          cstart++;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;

          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_false (res))
            break;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }
  return scm_c_substring (s, cstart, cend);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Trim @var{s} by skipping over all characters on the rightt\n"
            "that satisfy the parameter @var{char_pred}:\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "if it is the character @var{ch}, characters equal to @var{ch}\n"
            "are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a procedure @var{pred} characters that satisfy\n"
            "@var{pred} are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a character sets, all characters in that set are\n"
            "trimmed.\n"
            "@end itemize\n"
            "\n"
            "If called without a @var{char_pred} argument, all whitespace is\n"
            "trimmed.")
#define FUNC_NAME s_scm_string_trim_right
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_UNBNDP (char_pred))
    {
      while (cstart < cend)
        {
          if (!isspace((int) (unsigned char) cstr[cend - 1]))
            break;
          cend--;
        }
    }
  else if (SCM_CHARP (char_pred))
    {
      char chr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (chr != cstr[cend - 1])
            break;
          cend--;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
            break;
          cend--;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;

          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
          if (scm_is_false (res))
            break;
          cstr = scm_i_string_chars (s);
          cend--;
        }
    }
  return scm_c_substring (s, cstart, cend);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Trim @var{s} by skipping over all characters on both sides of\n"
            "the string that satisfy the parameter @var{char_pred}:\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "if it is the character @var{ch}, characters equal to @var{ch}\n"
            "are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a procedure @var{pred} characters that satisfy\n"
            "@var{pred} are trimmed,\n"
            "\n"
            "@item\n"
            "if it is a character set, the characters in the set are\n"
            "trimmed.\n"
            "@end itemize\n"
            "\n"
            "If called without a @var{char_pred} argument, all whitespace is\n"
            "trimmed.")
#define FUNC_NAME s_scm_string_trim_both
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_UNBNDP (char_pred))
    {
      while (cstart < cend)
        {
          if (!isspace((int) (unsigned char) cstr[cstart]))
            break;
          cstart++;
        }
      while (cstart < cend)
        {
          if (!isspace((int) (unsigned char) cstr[cend - 1]))
            break;
          cend--;
        }
    }
  else if (SCM_CHARP (char_pred))
    {
      char chr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (chr != cstr[cstart])
            break;
          cstart++;
        }
      while (cstart < cend)
        {
          if (chr != cstr[cend - 1])
            break;
          cend--;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
            break;
          cstart++;
        }
      while (cstart < cend)
        {
          if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
            break;
          cend--;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;

          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_false (res))
            break;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
      while (cstart < cend)
        {
          SCM res;

          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
          if (scm_is_false (res))
            break;
          cstr = scm_i_string_chars (s);
          cend--;
        }
    }
  return scm_c_substring (s, cstart, cend);
}
#undef FUNC_NAME


SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
            (SCM str, SCM chr, SCM start, SCM end),
            "Stores @var{chr} in every element of the given @var{str} and\n"
            "returns an unspecified value.")
#define FUNC_NAME s_scm_substring_fill_x
{
  char *cstr;
  size_t cstart, cend;
  int c;
  size_t k;

  /* Older versions of Guile provided the function
     scm_substring_fill_x with the following order of arguments:

         str, start, end, chr

     We accomodate this here by detecting such a usage and reordering
     the arguments.
  */
  if (SCM_CHARP (end))
    {
      SCM tmp = end;
      end = start;
      start = chr;
      chr = tmp;
    }

  MY_VALIDATE_SUBSTRING_SPEC (1, str,
                              3, start, cstart,
                              4, end, cend);
  SCM_VALIDATE_CHAR_COPY (2, chr, c);

  cstr = scm_i_string_writable_chars (str);
  for (k = cstart; k < cend; k++)
    cstr[k] = c;
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (str);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_string_fill_x (SCM str, SCM chr)
{
  return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED);
}

SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
            (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
            "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
            "mismatch index, depending upon whether @var{s1} is less than,\n"
            "equal to, or greater than @var{s2}.  The mismatch index is the\n"
            "largest index @var{i} such that for every 0 <= @var{j} <\n"
            "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
            "@var{i} is the first position that does not match.")
#define FUNC_NAME s_scm_string_compare
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  SCM proc;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    6, start1, cstart1,
                                    7, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    8, start2, cstart2,
                                    9, end2, cend2);
  SCM_VALIDATE_PROC (3, proc_lt);
  SCM_VALIDATE_PROC (4, proc_eq);
  SCM_VALIDATE_PROC (5, proc_gt);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        {
          proc = proc_lt;
          goto ret;
        }
      else if (cstr1[cstart1] > cstr2[cstart2])
        {
          proc = proc_gt;
          goto ret;
        }
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    proc = proc_gt;
  else if (cstart2 < cend2)
    proc = proc_lt;
  else
    proc = proc_eq;

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_call_1 (proc, scm_from_size_t (cstart1));
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
            (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
            "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
            "mismatch index, depending upon whether @var{s1} is less than,\n"
            "equal to, or greater than @var{s2}.  The mismatch index is the\n"
            "largest index @var{i} such that for every 0 <= @var{j} <\n"
            "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
            "@var{i} is the first position that does not match.  The\n"
            "character comparison is done case-insensitively.")
#define FUNC_NAME s_scm_string_compare_ci
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  SCM proc;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    6, start1, cstart1,
                                    7, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    8, start2, cstart2,
                                    9, end2, cend2);
  SCM_VALIDATE_PROC (3, proc_lt);
  SCM_VALIDATE_PROC (4, proc_eq);
  SCM_VALIDATE_PROC (5, proc_gt);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        {
          proc = proc_lt;
          goto ret;
        }
      else if (scm_c_downcase (cstr1[cstart1]) 
               > scm_c_downcase (cstr2[cstart2]))
        {
          proc = proc_gt;
          goto ret;
        }
      cstart1++;
      cstart2++;
    }

  if (cstart1 < cend1)
    proc = proc_gt;
  else if (cstart2 < cend2)
    proc = proc_lt;
  else
    proc = proc_eq;

 ret:
  scm_remember_upto_here (s1, s2);
  return scm_call_1 (proc, scm_from_size_t (cstart1));
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
            "value otherwise.")
#define FUNC_NAME s_scm_string_eq
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);

  if ((cend1 - cstart1) != (cend2 - cstart2))
    goto false;

  while (cstart1 < cend1)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto false;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto false;
      cstart1++;
      cstart2++;
    }
  
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
            "value otherwise.")
#define FUNC_NAME s_scm_string_neq
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto true;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto true;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
            "true value otherwise.")
#define FUNC_NAME s_scm_string_lt
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto true;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto false;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto false;
  else if (cstart2 < cend2)
    goto true;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
            "true value otherwise.")
#define FUNC_NAME s_scm_string_gt
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto false;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto false;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
            "value otherwise.")
#define FUNC_NAME s_scm_string_le
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto true;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto false;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto false;
  else if (cstart2 < cend2)
    goto true;
  else
    goto true;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
            "otherwise.")
#define FUNC_NAME s_scm_string_ge
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] < cstr2[cstart2])
        goto false;
      else if (cstr1[cstart1] > cstr2[cstart2])
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto false;
  else
    goto true;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
            "value otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_eq
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto false;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto false;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto false;
  else if (cstart2 < cend2)
    goto false;
  else
    goto true;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
            "value otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_neq
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto true;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto true;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
            "true value otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_lt
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto true;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto false;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto false;
  else if (cstart2 < cend2)
    goto true;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
            "true value otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_gt
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto false;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto false;
  else
    goto false;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
            "value otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_le
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto true;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto false;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto false;
  else if (cstart2 < cend2)
    goto true;
  else
    goto true;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
            "otherwise.  The character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_ci_ge
{
  const unsigned char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
                                    3, start1, cstart1,
                                    4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
                                    5, start2, cstart2,
                                    6, end2, cend2);

  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
        goto false;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
        goto true;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    goto true;
  else if (cstart2 < cend2)
    goto false;
  else
    goto true;

 true:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (cstart1);

 false:
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
            (SCM s, SCM bound, SCM start, SCM end),
            "Compute a hash value for @var{S}.  the optional argument "
            "@var{bound} is a non-negative exact "
            "integer specifying the range of the hash function. "
            "A positive value restricts the return value to the "
            "range [0,bound).")
#define FUNC_NAME s_scm_substring_hash
{
  if (SCM_UNBNDP (bound))
    bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM);
  if (SCM_UNBNDP (start))
    start = SCM_INUM0;
  return scm_hash (scm_substring_shared (s, start, end), bound);
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
            (SCM s, SCM bound, SCM start, SCM end),
            "Compute a hash value for @var{S}.  the optional argument "
            "@var{bound} is a non-negative exact "
            "integer specifying the range of the hash function. "
            "A positive value restricts the return value to the "
            "range [0,bound).")
#define FUNC_NAME s_scm_substring_hash_ci
{
  return scm_substring_hash (scm_substring_downcase (s, start, end),
                             bound,
                             SCM_UNDEFINED, SCM_UNDEFINED);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return the length of the longest common prefix of the two\n"
            "strings.")
#define FUNC_NAME s_scm_string_prefix_length
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] != cstr2[cstart2])
        goto ret;
      len++;
      cstart1++;
      cstart2++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (len);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return the length of the longest common prefix of the two\n"
            "strings, ignoring character case.")
#define FUNC_NAME s_scm_string_prefix_length_ci
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
        goto ret;
      len++;
      cstart1++;
      cstart2++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (len);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return the length of the longest common suffix of the two\n"
            "strings.")
#define FUNC_NAME s_scm_string_suffix_length
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      cend1--;
      cend2--;
      if (cstr1[cend1] != cstr2[cend2])
        goto ret;
      len++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (len);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return the length of the longest common suffix of the two\n"
            "strings, ignoring character case.")
#define FUNC_NAME s_scm_string_suffix_length_ci
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      cend1--;
      cend2--;
      if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
        goto ret;
      len++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_size_t (len);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Is @var{s1} a prefix of @var{s2}?")
#define FUNC_NAME s_scm_string_prefix_p
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0, len1;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len1 = cend1 - cstart1;
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (cstr1[cstart1] != cstr2[cstart2])
        goto ret;
      len++;
      cstart1++;
      cstart2++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_bool (len == len1);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_prefix_ci_p
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0, len1;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len1 = cend1 - cstart1;
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
        goto ret;
      len++;
      cstart1++;
      cstart2++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_bool (len == len1);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Is @var{s1} a suffix of @var{s2}?")
#define FUNC_NAME s_scm_string_suffix_p
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0, len1;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len1 = cend1 - cstart1;
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      cend1--;
      cend2--;
      if (cstr1[cend1] != cstr2[cend2])
        goto ret;
      len++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_bool (len == len1);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_suffix_ci_p
{
  const char *cstr1, *cstr2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len = 0, len1;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len1 = cend1 - cstart1;
  while (cstart1 < cend1 && cstart2 < cend2)
    {
      cend1--;
      cend2--;
      if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
        goto ret;
      len++;
    }

 ret:
  scm_remember_upto_here_2 (s1, s2);
  return scm_from_bool (len == len1);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Search through the string @var{s} from left to right, returning\n"
            "the index of the first occurence of a character which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "equals @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
            "\n"
            "@item\n"
            "is in the set @var{char_pred}, if it is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_index
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (cchr == cstr[cstart])
            goto found;
          cstart++;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
            goto found;
          cstart++;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_true (res))
            goto found;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }
  
  scm_remember_upto_here_1 (s);
  return SCM_BOOL_F;
  
 found:
  scm_remember_upto_here_1 (s);
  return scm_from_size_t (cstart);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Search through the string @var{s} from right to left, returning\n"
            "the index of the last occurence of a character which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "equals @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
            "\n"
            "@item\n"
            "is in the set if @var{char_pred} is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_index_right
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          cend--;
          if (cchr == cstr[cend])
            goto found;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          cend--;
          if (SCM_CHARSET_GET (char_pred, cstr[cend]))
            goto found;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;
          cend--;
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
          if (scm_is_true (res))
            goto found;
          cstr = scm_i_string_chars (s);
        }
    }

  scm_remember_upto_here_1 (s);
  return SCM_BOOL_F;

 found:
  scm_remember_upto_here_1 (s);
  return scm_from_size_t (cend);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Search through the string @var{s} from right to left, returning\n"
            "the index of the last occurence of a character which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "equals @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
            "\n"
            "@item\n"
            "is in the set if @var{char_pred} is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_rindex
{
  return scm_string_index_right (s, char_pred, start, end);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Search through the string @var{s} from left to right, returning\n"
            "the index of the first occurence of a character which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "does not equal @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "does not satisify the predicate @var{char_pred}, if it is a\n"
            "procedure,\n"
            "\n"
            "@item\n"
            "is not in the set if @var{char_pred} is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_skip
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (cchr != cstr[cstart])
            goto found;
          cstart++;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
            goto found;
          cstart++;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_false (res))
            goto found;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }

  scm_remember_upto_here_1 (s);
  return SCM_BOOL_F;

 found:
  scm_remember_upto_here_1 (s);
  return scm_from_size_t (cstart);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Search through the string @var{s} from right to left, returning\n"
            "the index of the last occurence of a character which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "does not equal @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "does not satisfy the predicate @var{char_pred}, if it is a\n"
            "procedure,\n"
            "\n"
            "@item\n"
            "is not in the set if @var{char_pred} is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_skip_right
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          cend--;
          if (cchr != cstr[cend])
            goto found;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          cend--;
          if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
            goto found;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;
          cend--;
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
          if (scm_is_false (res))
            goto found;
          cstr = scm_i_string_chars (s);
        }
    }

  scm_remember_upto_here_1 (s);
  return SCM_BOOL_F;

 found:
  scm_remember_upto_here_1 (s);
  return scm_from_size_t (cend);

}
#undef FUNC_NAME


SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Return the count of the number of characters in the string\n"
            "@var{s} which\n"
            "\n"
            "@itemize @bullet\n"
            "@item\n"
            "equals @var{char_pred}, if it is character,\n"
            "\n"
            "@item\n"
            "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
            "\n"
            "@item\n"
            "is in the set @var{char_pred}, if it is a character set.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_count
{
  const char *cstr;
  size_t cstart, cend;
  size_t count = 0;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      char cchr = SCM_CHAR (char_pred);
      while (cstart < cend)
        {
          if (cchr == cstr[cstart])
            count++;
          cstart++;
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
        {
          if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
            count++;
          cstart++;
        }
    }
  else
    {
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      while (cstart < cend)
        {
          SCM res;
          res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
          if (scm_is_true (res))
            count++;
          cstr = scm_i_string_chars (s);
          cstart++;
        }
    }

  scm_remember_upto_here_1 (s);
  return scm_from_size_t (count);
}
#undef FUNC_NAME


/* FIXME::martin: This should definitely get implemented more
   efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
   implementation.  */
SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Does string @var{s1} contain string @var{s2}?  Return the index\n"
            "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
            "The optional start/end indices restrict the operation to the\n"
            "indicated substrings.")
#define FUNC_NAME s_scm_string_contains
{
  const char *cs1, * cs2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len2, i, j;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len2 = cend2 - cstart2;
  if (cend1 - cstart1 >= len2)
    while (cstart1 <= cend1 - len2)
      {
        i = cstart1;
        j = cstart2;
        while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
          {
            i++;
            j++;
          }
        if (j == cend2)
          {
            scm_remember_upto_here_2 (s1, s2);
            return scm_from_size_t (cstart1);
          }
        cstart1++;
      }

  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


/* FIXME::martin: This should definitely get implemented more
   efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
   implementation.  */
SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Does string @var{s1} contain string @var{s2}?  Return the index\n"
            "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
            "The optional start/end indices restrict the operation to the\n"
            "indicated substrings.  Character comparison is done\n"
            "case-insensitively.")
#define FUNC_NAME s_scm_string_contains_ci
{
  const char *cs1, * cs2;
  size_t cstart1, cend1, cstart2, cend2;
  size_t len2, i, j;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
                                   3, start1, cstart1,
                                   4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
                                   5, start2, cstart2,
                                   6, end2, cend2);
  len2 = cend2 - cstart2;
  if (cend1 - cstart1 >= len2)
    while (cstart1 <= cend1 - len2)
      {
        i = cstart1;
        j = cstart2;
        while (i < cend1 && j < cend2 &&
               scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
          {
            i++;
            j++;
          }
        if (j == cend2)
          {
            scm_remember_upto_here_2 (s1, s2);
            return scm_from_size_t (cstart1);
          }
        cstart1++;
      }
  
  scm_remember_upto_here_2 (s1, s2);
  return SCM_BOOL_F;
}
#undef FUNC_NAME


/* Helper function for the string uppercase conversion functions.
 * No argument checking is performed.  */
static SCM
string_upcase_x (SCM v, size_t start, size_t end)
{
  size_t k;
  char *dst;

  dst = scm_i_string_writable_chars (v);
  for (k = start; k < end; ++k)
    dst[k] = scm_c_upcase (dst[k]);
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (v);

  return v;
}

SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Destructively upcase every character in @code{str}.\n"
            "\n"
            "@lisp\n"
            "(string-upcase! y)\n"
            "@result{} \"ARRDEFG\"\n"
            "y\n"
            "@result{} \"ARRDEFG\"\n"
            "@end lisp")
#define FUNC_NAME s_scm_substring_upcase_x
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_upcase_x (str, cstart, cend);
}
#undef FUNC_NAME

SCM
scm_string_upcase_x (SCM str)
{
  return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
}

SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Upcase every character in @code{str}.")
#define FUNC_NAME s_scm_substring_upcase
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_upcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME

SCM
scm_string_upcase (SCM str)
{
  return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
}

/* Helper function for the string lowercase conversion functions.
 * No argument checking is performed.  */
static SCM
string_downcase_x (SCM v, size_t start, size_t end)
{
  size_t k;
  char *dst;

  dst = scm_i_string_writable_chars (v);
  for (k = start; k < end; ++k)
    dst[k] = scm_c_downcase (dst[k]);
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (v);

  return v;
}

SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Destructively downcase every character in @var{str}.\n"
            "\n"
            "@lisp\n"
            "y\n"
            "@result{} \"ARRDEFG\"\n"
            "(string-downcase! y)\n"
            "@result{} \"arrdefg\"\n"
            "y\n"
            "@result{} \"arrdefg\"\n"
            "@end lisp")
#define FUNC_NAME s_scm_substring_downcase_x
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_downcase_x (str, cstart, cend);
}
#undef FUNC_NAME

SCM
scm_string_downcase_x (SCM str)
{
  return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
}

SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Downcase every character in @var{str}.")
#define FUNC_NAME s_scm_substring_downcase
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_downcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME

SCM
scm_string_downcase (SCM str)
{
  return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
}

/* Helper function for the string capitalization functions.
 * No argument checking is performed.  */
static SCM
string_titlecase_x (SCM str, size_t start, size_t end)
{
  unsigned char *sz;
  size_t i;
  int in_word = 0;

  sz = (unsigned char *) scm_i_string_writable_chars (str);
  for(i = start; i < end;  i++)
    {
      if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
        {
          if (!in_word)
            {
              sz[i] = scm_c_upcase(sz[i]);
              in_word = 1;
            }
          else
            {
              sz[i] = scm_c_downcase(sz[i]);
            }
        }
      else
        in_word = 0;
    }
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (str);

  return str;
}


SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Destructively titlecase every first character in a word in\n"
            "@var{str}.")
#define FUNC_NAME s_scm_string_titlecase_x
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_titlecase_x (str, cstart, cend);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Titlecase every first character in a word in @var{str}.")
#define FUNC_NAME s_scm_string_titlecase
{
  const char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  return string_titlecase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
            (SCM str),
            "Upcase the first character of every word in @var{str}\n"
            "destructively and return @var{str}.\n"
            "\n"
            "@lisp\n"
            "y                      @result{} \"hello world\"\n"
            "(string-capitalize! y) @result{} \"Hello World\"\n"
            "y                      @result{} \"Hello World\"\n"
            "@end lisp")
#define FUNC_NAME s_scm_string_capitalize_x
{
  return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
            (SCM str),
            "Return a freshly allocated string with the characters in\n"
            "@var{str}, where the first character of every word is\n"
            "capitalized.")
#define FUNC_NAME s_scm_string_capitalize
{
  return scm_string_capitalize_x (scm_string_copy (str));
}
#undef FUNC_NAME


/* Reverse the portion of @var{str} between str[cstart] (including)
   and str[cend] excluding.  */
static void
string_reverse_x (char * str, size_t cstart, size_t cend)
{
  char tmp;

  if (cend > 0)
    {
      cend--;
      while (cstart < cend)
        {
          tmp = str[cstart];
          str[cstart] = str[cend];
          str[cend] = tmp;
          cstart++;
          cend--;
        }
    }
}


SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Reverse the string @var{str}.  The optional arguments\n"
            "@var{start} and @var{end} delimit the region of @var{str} to\n"
            "operate on.")
#define FUNC_NAME s_scm_string_reverse
{
  const char *cstr;
  char *ctarget;
  size_t cstart, cend;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
                                   2, start, cstart,
                                   3, end, cend);
  result = scm_string_copy (str);
  ctarget = scm_i_string_writable_chars (result);
  string_reverse_x (ctarget, cstart, cend);
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (str);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
            (SCM str, SCM start, SCM end),
            "Reverse the string @var{str} in-place.  The optional arguments\n"
            "@var{start} and @var{end} delimit the region of @var{str} to\n"
            "operate on.  The return value is unspecified.")
#define FUNC_NAME s_scm_string_reverse_x
{
  char *cstr;
  size_t cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC (1, str,
                              2, start, cstart,
                              3, end, cend);

  cstr = scm_i_string_writable_chars (str);
  string_reverse_x (cstr, cstart, cend);
  scm_i_string_stop_writing ();
  scm_remember_upto_here_1 (str);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
            (SCM rest),
            "Like @code{string-append}, but the result may share memory\n"
            "with the argument strings.")
#define FUNC_NAME s_scm_string_append_shared
{
  /* If "rest" contains just one non-empty string, return that.
     If it's entirely empty strings, then return scm_nullstr.
     Otherwise use scm_string_concatenate.  */

  SCM ret = scm_nullstr;
  int seen_nonempty = 0;
  SCM l, s;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
    {
      s = SCM_CAR (l);
      if (scm_c_string_length (s) != 0)
        {
          if (seen_nonempty)
            /* two or more non-empty strings, need full concat */
            return scm_string_append (rest);

          seen_nonempty = 1;
          ret = s;
        }
    }
  return ret;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
            (SCM ls),
            "Append the elements of @var{ls} (which must be strings)\n"
            "together into a single string.  Guaranteed to return a freshly\n"
            "allocated string.")
#define FUNC_NAME s_scm_string_concatenate
{
  SCM_VALIDATE_LIST (SCM_ARG1, ls);
  return scm_string_append (ls);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
            (SCM ls, SCM final_string, SCM end),
            "Without optional arguments, this procedure is equivalent to\n"
            "\n"
            "@smalllisp\n"
            "(string-concatenate (reverse ls))\n"
            "@end smalllisp\n"
            "\n"
            "If the optional argument @var{final_string} is specified, it is\n"
            "consed onto the beginning to @var{ls} before performing the\n"
            "list-reverse and string-concatenate operations.  If @var{end}\n"
            "is given, only the characters of @var{final_string} up to index\n"
            "@var{end} are used.\n"
            "\n"
            "Guaranteed to return a freshly allocated string.")
#define FUNC_NAME s_scm_string_concatenate_reverse
{
  if (!SCM_UNBNDP (end))
    final_string = scm_substring (final_string, SCM_INUM0, end);

  if (!SCM_UNBNDP (final_string))
    ls = scm_cons (final_string, ls);

  return scm_string_concatenate (scm_reverse (ls));
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
            (SCM ls),
            "Like @code{string-concatenate}, but the result may share memory\n"
            "with the strings in the list @var{ls}.")
#define FUNC_NAME s_scm_string_concatenate_shared
{
  SCM_VALIDATE_LIST (SCM_ARG1, ls);
  return scm_string_append_shared (ls);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
            (SCM ls, SCM final_string, SCM end),
            "Like @code{string-concatenate-reverse}, but the result may\n"
            "share memory with the the strings in the @var{ls} arguments.")
#define FUNC_NAME s_scm_string_concatenate_reverse_shared
{
  /* Just call the non-sharing version.  */
  return scm_string_concatenate_reverse (ls, final_string, end);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
            (SCM proc, SCM s, SCM start, SCM end),
            "@var{proc} is a char->char procedure, it is mapped over\n"
            "@var{s}.  The order in which the procedure is applied to the\n"
            "string elements is not specified.")
#define FUNC_NAME s_scm_string_map
{
  char *p;
  size_t cstart, cend;
  SCM result;
  scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);

  SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
  MY_VALIDATE_SUBSTRING_SPEC (2, s,
                              3, start, cstart,
                              4, end, cend);
  result = scm_i_make_string (cend - cstart, &p);
  while (cstart < cend)
    {
      SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
      if (!SCM_CHARP (ch))
        SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
      cstart++;
      *p++ = SCM_CHAR (ch);
    }
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
            (SCM proc, SCM s, SCM start, SCM end),
            "@var{proc} is a char->char procedure, it is mapped over\n"
            "@var{s}.  The order in which the procedure is applied to the\n"
            "string elements is not specified.  The string @var{s} is\n"
            "modified in-place, the return value is not specified.")
#define FUNC_NAME s_scm_string_map_x
{
  size_t cstart, cend;
  scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);

  SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
  MY_VALIDATE_SUBSTRING_SPEC (2, s,
                              3, start, cstart,
                              4, end, cend);
  while (cstart < cend)
    {
      SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
      if (!SCM_CHARP (ch))
        SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
      scm_c_string_set_x (s, cstart, ch);
      cstart++;
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
            (SCM kons, SCM knil, SCM s, SCM start, SCM end),
            "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
            "as the terminating element, from left to right.  @var{kons}\n"
            "must expect two arguments: The actual character and the last\n"
            "result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold
{
  const char *cstr;
  size_t cstart, cend;
  SCM result;

  SCM_VALIDATE_PROC (1, kons);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
                                   4, start, cstart,
                                   5, end, cend);
  result = knil;
  while (cstart < cend)
    {
      unsigned int c = (unsigned char) cstr[cstart];
      result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
      cstr = scm_i_string_chars (s);
      cstart++;
    }

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
            (SCM kons, SCM knil, SCM s, SCM start, SCM end),
            "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
            "as the terminating element, from right to left.  @var{kons}\n"
            "must expect two arguments: The actual character and the last\n"
            "result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold_right
{
  const char *cstr;
  size_t cstart, cend;
  SCM result;

  SCM_VALIDATE_PROC (1, kons);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
                                   4, start, cstart,
                                   5, end, cend);
  result = knil;
  while (cstart < cend)
    {
      unsigned int c  = (unsigned char) cstr[cend - 1];
      result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
      cstr = scm_i_string_chars (s);
      cend--;
    }

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
            (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
            "@itemize @bullet\n"
            "@item @var{g} is used to generate a series of @emph{seed}\n"
            "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
            "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
            "@dots{}\n"
            "@item @var{p} tells us when to stop -- when it returns true\n"
            "when applied to one of these seed values.\n"
            "@item @var{f} maps each seed value to the corresponding\n"
            "character in the result string.  These chars are assembled\n"
            "into the string in a left-to-right order.\n"
            "@item @var{base} is the optional initial/leftmost portion\n"
            "of the constructed string; it default to the empty\n"
            "string.\n"
            "@item @var{make_final} is applied to the terminal seed\n"
            "value (on which @var{p} returns true) to produce\n"
            "the final/rightmost portion of the constructed string.\n"
            "It defaults to @code{(lambda (x) "")}.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_unfold
{
  SCM res, ans;

  SCM_VALIDATE_PROC (1, p);
  SCM_VALIDATE_PROC (2, f);
  SCM_VALIDATE_PROC (3, g);
  if (!SCM_UNBNDP (base))
    {
      SCM_VALIDATE_STRING (5, base);
      ans = base;
    }
  else
    ans = scm_i_make_string (0, NULL);
  if (!SCM_UNBNDP (make_final))
    SCM_VALIDATE_PROC (6, make_final);

  res = scm_call_1 (p, seed);
  while (scm_is_false (res))
    {
      SCM str;
      char *ptr;
      SCM ch = scm_call_1 (f, seed);
      if (!SCM_CHARP (ch))
        SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
      str = scm_i_make_string (1, &ptr);
      *ptr = SCM_CHAR (ch);

      ans = scm_string_append (scm_list_2 (ans, str));
      seed = scm_call_1 (g, seed);
      res = scm_call_1 (p, seed);
    }
  if (!SCM_UNBNDP (make_final))
    {
      res = scm_call_1 (make_final, seed);
      return scm_string_append (scm_list_2 (ans, res));
    }
  else
    return ans;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
            (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
            "@itemize @bullet\n"
            "@item @var{g} is used to generate a series of @emph{seed}\n"
            "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
            "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
            "@dots{}\n"
            "@item @var{p} tells us when to stop -- when it returns true\n"
            "when applied to one of these seed values.\n"
            "@item @var{f} maps each seed value to the corresponding\n"
            "character in the result string.  These chars are assembled\n"
            "into the string in a right-to-left order.\n"
            "@item @var{base} is the optional initial/rightmost portion\n"
            "of the constructed string; it default to the empty\n"
            "string.\n"
            "@item @var{make_final} is applied to the terminal seed\n"
            "value (on which @var{p} returns true) to produce\n"
            "the final/leftmost portion of the constructed string.\n"
            "It defaults to @code{(lambda (x) "")}.\n"
            "@end itemize")
#define FUNC_NAME s_scm_string_unfold_right
{
  SCM res, ans;

  SCM_VALIDATE_PROC (1, p);
  SCM_VALIDATE_PROC (2, f);
  SCM_VALIDATE_PROC (3, g);
  if (!SCM_UNBNDP (base))
    {
      SCM_VALIDATE_STRING (5, base);
      ans = base;
    }
  else
    ans = scm_i_make_string (0, NULL);
  if (!SCM_UNBNDP (make_final))
    SCM_VALIDATE_PROC (6, make_final);

  res = scm_call_1 (p, seed);
  while (scm_is_false (res))
    {
      SCM str;
      char *ptr;
      SCM ch = scm_call_1 (f, seed);
      if (!SCM_CHARP (ch))
        SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
      str = scm_i_make_string (1, &ptr);
      *ptr = SCM_CHAR (ch);

      ans = scm_string_append (scm_list_2 (str, ans));
      seed = scm_call_1 (g, seed);
      res = scm_call_1 (p, seed);
    }
  if (!SCM_UNBNDP (make_final))
    {
      res = scm_call_1 (make_final, seed);
      return scm_string_append (scm_list_2 (res, ans));
    }
  else
    return ans;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
            (SCM proc, SCM s, SCM start, SCM end),
            "@var{proc} is mapped over @var{s} in left-to-right order.  The\n"
            "return value is not specified.")
#define FUNC_NAME s_scm_string_for_each
{
  const char *cstr;
  size_t cstart, cend;
  scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);

  SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);
  while (cstart < cend)
    {
      unsigned int c = (unsigned char) cstr[cstart];
      proc_tramp (proc, SCM_MAKE_CHAR (c));
      cstr = scm_i_string_chars (s);
      cstart++;
    }

  scm_remember_upto_here_1 (s);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
            (SCM proc, SCM s, SCM start, SCM end),
            "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
            "left to right.\n"
            "\n"
            "For example, to change characters to alternately upper and\n"
            "lower case,\n"
            "\n"
            "@example\n"
            "(define str (string-copy \"studly\"))\n"
            "(string-for-each-index\n"
            "    (lambda (i)\n"
            "      (string-set! str i\n"
            "        ((if (even? i) char-upcase char-downcase)\n"
            "         (string-ref str i))))\n"
            "    str)\n"
            "str @result{} \"StUdLy\"\n"
            "@end example")
#define FUNC_NAME s_scm_string_for_each_index
{
  size_t cstart, cend;
  scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);

  SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
  MY_VALIDATE_SUBSTRING_SPEC (2, s,
                              3, start, cstart,
                              4, end, cend);

  while (cstart < cend)
    {
      proc_tramp (proc, scm_from_size_t (cstart));
      cstart++;
    }

  scm_remember_upto_here_1 (s);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
            (SCM s, SCM from, SCM to, SCM start, SCM end),
            "This is the @emph{extended substring} procedure that implements\n"
            "replicated copying of a substring of some string.\n"
            "\n"
            "@var{s} is a string, @var{start} and @var{end} are optional\n"
            "arguments that demarcate a substring of @var{s}, defaulting to\n"
            "0 and the length of @var{s}.  Replicate this substring up and\n"
            "down index space, in both the positive and negative directions.\n"
            "@code{xsubstring} returns the substring of this string\n"
            "beginning at index @var{from}, and ending at @var{to}, which\n"
            "defaults to @var{from} + (@var{end} - @var{start}).")
#define FUNC_NAME s_scm_xsubstring
{
  const char *cs;
  char *p;
  size_t cstart, cend;
  int cfrom, cto;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC (1, s,
                              4, start, cstart,
                              5, end, cend);

  cfrom = scm_to_int (from);
  if (SCM_UNBNDP (to))
    cto = cfrom + (cend - cstart);
  else
    cto = scm_to_int (to);
  if (cstart == cend && cfrom != cto)
    SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);

  result = scm_i_make_string (cto - cfrom, &p);

  cs = scm_i_string_chars (s);
  while (cfrom < cto)
    {
      size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
      if (cfrom < 0)
        *p = cs[(cend - cstart) - t];
      else
        *p = cs[t];
      cfrom++;
      p++;
    }

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
            (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
            "Exactly the same as @code{xsubstring}, but the extracted text\n"
            "is written into the string @var{target} starting at index\n"
            "@var{tstart}.  The operation is not defined if @code{(eq?\n"
            "@var{target} @var{s})} or these arguments share storage -- you\n"
            "cannot copy a string on top of itself.")
#define FUNC_NAME s_scm_string_xcopy_x
{
  char *p;
  const char *cs;
  size_t ctstart, cstart, cend;
  int csfrom, csto;
  SCM dummy = SCM_UNDEFINED;
  size_t cdummy;

  MY_VALIDATE_SUBSTRING_SPEC (1, target,
                              2, tstart, ctstart,
                              2, dummy, cdummy);
  MY_VALIDATE_SUBSTRING_SPEC (3, s,
                              6, start, cstart,
                              7, end, cend);
  csfrom = scm_to_int (sfrom);
  if (SCM_UNBNDP (sto))
    csto = csfrom + (cend - cstart);
  else
    csto = scm_to_int (sto); 
  if (cstart == cend && csfrom != csto)
    SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
  SCM_ASSERT_RANGE (1, tstart,
                    ctstart + (csto - csfrom) <= scm_i_string_length (target));

  p = scm_i_string_writable_chars (target) + ctstart;
  cs = scm_i_string_chars (s);
  while (csfrom < csto)
    {
      size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
      if (csfrom < 0)
        *p = cs[(cend - cstart) - t];
      else
        *p = cs[t];
      csfrom++;
      p++;
    }
  scm_i_string_stop_writing ();

  scm_remember_upto_here_2 (target, s);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
            (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
            "Return the string @var{s1}, but with the characters\n"
            "@var{start1} @dots{} @var{end1} replaced by the characters\n"
            "@var{start2} @dots{} @var{end2} from @var{s2}.")
#define FUNC_NAME s_scm_string_replace
{
  const char *cstr1, *cstr2;
  char *p;
  size_t cstart1, cend1, cstart2, cend2;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC (1, s1,
                              3, start1, cstart1,
                              4, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC (2, s2,
                              5, start2, cstart2,
                              6, end2, cend2);
  result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
                              scm_i_string_length (s1) - cend1, &p);
  cstr1 = scm_i_string_chars (s1);
  cstr2 = scm_i_string_chars (s2);
  memmove (p, cstr1, cstart1 * sizeof (char));
  memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
  memmove (p + cstart1 + (cend2 - cstart2),
           cstr1 + cend1,
           (scm_i_string_length (s1) - cend1) * sizeof (char));
  scm_remember_upto_here_2 (s1, s2);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
            (SCM s, SCM token_set, SCM start, SCM end),
            "Split the string @var{s} into a list of substrings, where each\n"
            "substring is a maximal non-empty contiguous sequence of\n"
            "characters from the character set @var{token_set}, which\n"
            "defaults to @code{char-set:graphic}.\n"
            "If @var{start} or @var{end} indices are provided, they restrict\n"
            "@code{string-tokenize} to operating on the indicated substring\n"
            "of @var{s}.")
#define FUNC_NAME s_scm_string_tokenize
{
  const char *cstr;
  size_t cstart, cend;
  SCM result = SCM_EOL;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);

  if (SCM_UNBNDP (token_set))
    token_set = scm_char_set_graphic;

  if (SCM_CHARSETP (token_set))
    {
      size_t idx;

      while (cstart < cend)
        {
          while (cstart < cend)
            {
              if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
                break;
              cend--;
            }
          if (cstart >= cend)
            break;
          idx = cend;
          while (cstart < cend)
            {
              if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
                break;
              cend--;
            }
          result = scm_cons (scm_c_substring (s, cend, idx), result);
          cstr = scm_i_string_chars (s);
        }
    }
  else
    SCM_WRONG_TYPE_ARG (2, token_set);

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
            (SCM str, SCM chr),
            "Split the string @var{str} into the a list of the substrings delimited\n"
            "by appearances of the character @var{chr}.  Note that an empty substring\n"
            "between separator characters will result in an empty string in the\n"
            "result list.\n"
            "\n"
            "@lisp\n"
            "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
            "@result{}\n"
            "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
            "\n"
            "(string-split \"::\" #\\:)\n"
            "@result{}\n"
            "(\"\" \"\" \"\")\n"
            "\n"
            "(string-split \"\" #\\:)\n"
            "@result{}\n"
            "(\"\")\n"
            "@end lisp")
#define FUNC_NAME s_scm_string_split
{
  long idx, last_idx;
  const char * p;
  char ch;
  SCM res = SCM_EOL;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_CHAR (2, chr);

  idx = scm_i_string_length (str);
  p = scm_i_string_chars (str);
  ch = SCM_CHAR (chr);
  while (idx >= 0)
    {
      last_idx = idx;
      while (idx > 0 && p[idx - 1] != ch)
        idx--;
      if (idx >= 0)
        {
          res = scm_cons (scm_c_substring (str, idx, last_idx), res);
          p = scm_i_string_chars (str);
          idx--;
        }
    }
  scm_remember_upto_here_1 (str);
  return res;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Filter the string @var{s}, retaining only those characters\n"
            "which satisfy @var{char_pred}.\n"
            "\n"
            "If @var{char_pred} is a procedure, it is applied to each\n"
            "character as a predicate, if it is a character, it is tested\n"
            "for equality and if it is a character set, it is tested for\n"
            "membership.")
#define FUNC_NAME s_scm_string_filter
{
  const char *cstr;
  size_t cstart, cend;
  SCM result;
  size_t idx;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);

  /* The explicit loops below stripping leading and trailing non-matches
     mean we can return a substring if those are the only deletions, making
     string-filter as efficient as string-trim-both in that case.  */

  if (SCM_CHARP (char_pred))
    {
      size_t count;
      char chr;

      chr = SCM_CHAR (char_pred);

      /* strip leading non-matches by incrementing cstart */
      while (cstart < cend && cstr[cstart] != chr)
        cstart++;

      /* strip trailing non-matches by decrementing cend */
      while (cend > cstart && cstr[cend-1] != chr)
        cend--;

      /* count chars to keep */
      count = 0;
      for (idx = cstart; idx < cend; idx++)
        if (cstr[idx] == chr)
          count++;

      if (count == cend - cstart)
        {
          /* whole of cstart to cend is to be kept, return a copy-on-write
             substring */
        result_substring:
          result = scm_i_substring (s, cstart, cend);
        }
      else
        result = scm_c_make_string (count, char_pred);
    }
  else if (SCM_CHARSETP (char_pred))
    {
      size_t count;

      /* strip leading non-matches by incrementing cstart */
      while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart]))
        cstart++;

      /* strip trailing non-matches by decrementing cend */
      while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1]))
        cend--;

      /* count chars to be kept */
      count = 0;
      for (idx = cstart; idx < cend; idx++)
        if (SCM_CHARSET_GET (char_pred, cstr[idx]))
          count++;

      /* if whole of start to end kept then return substring */
      if (count == cend - cstart)
        goto result_substring;
      else
        {
          char *dst;
          result = scm_i_make_string (count, &dst);
          cstr = scm_i_string_chars (s);

          /* decrement "count" in this loop as well as using idx, so that if
             another thread is simultaneously changing "s" there's no chance
             it'll make us copy more than count characters */
          for (idx = cstart; idx < cend && count != 0; idx++)
            {
              if (SCM_CHARSET_GET (char_pred, cstr[idx]))
                {
                  *dst++ = cstr[idx];
                  count--;
                }
            }
        }
    }
  else
    {
      SCM ls = SCM_EOL;
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);

      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
      idx = cstart;
      while (idx < cend)
        {
          SCM res, ch;
          ch = SCM_MAKE_CHAR (cstr[idx]);
          res = pred_tramp (char_pred, ch);
          if (scm_is_true (res))
            ls = scm_cons (ch, ls);
          cstr = scm_i_string_chars (s);
          idx++;
        }
      result = scm_reverse_list_to_string (ls);
    }

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
            (SCM s, SCM char_pred, SCM start, SCM end),
            "Delete characters satisfying @var{char_pred} from @var{s}.\n"
            "\n"
            "If @var{char_pred} is a procedure, it is applied to each\n"
            "character as a predicate, if it is a character, it is tested\n"
            "for equality and if it is a character set, it is tested for\n"
            "membership.")
#define FUNC_NAME s_scm_string_delete
{
  const char *cstr;
  size_t cstart, cend;
  SCM result;
  size_t idx;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
                                   3, start, cstart,
                                   4, end, cend);

  /* The explicit loops below stripping leading and trailing matches mean we
     can return a substring if those are the only deletions, making
     string-delete as efficient as string-trim-both in that case.  */

  if (SCM_CHARP (char_pred))
    {
      size_t count;
      char chr;

      chr = SCM_CHAR (char_pred);

      /* strip leading matches by incrementing cstart */
      while (cstart < cend && cstr[cstart] == chr)
        cstart++;

      /* strip trailing matches by decrementing cend */
      while (cend > cstart && cstr[cend-1] == chr)
        cend--;

      /* count chars to be kept */
      count = 0;
      for (idx = cstart; idx < cend; idx++)
        if (cstr[idx] != chr)
          count++;

      if (count == cend - cstart)
        {
          /* whole of cstart to cend is to be kept, return a copy-on-write
             substring */
        result_substring:
          result = scm_i_substring (s, cstart, cend);
        }
      else
        {
          /* new string for retained portion */
          char *dst;
          result = scm_i_make_string (count, &dst);
          cstr = scm_i_string_chars (s);

          /* decrement "count" in this loop as well as using idx, so that if
             another thread is simultaneously changing "s" there's no chance
             it'll make us copy more than count characters */
          for (idx = cstart; idx < cend && count != 0; idx++)
            {
              if (cstr[idx] != chr)
                {
                  *dst++ = cstr[idx];
                  count--;
                }
            }
        }
    }
  else if (SCM_CHARSETP (char_pred))
    {
      size_t count;

      /* strip leading matches by incrementing cstart */
      while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart]))
        cstart++;

      /* strip trailing matches by decrementing cend */
      while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1]))
        cend--;

      /* count chars to be kept */
      count = 0;
      for (idx = cstart; idx < cend; idx++)
        if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
          count++;

      if (count == cend - cstart)
        goto result_substring;
      else
        {
          /* new string for retained portion */
          char *dst;
          result = scm_i_make_string (count, &dst);
          cstr = scm_i_string_chars (s);

          /* decrement "count" in this loop as well as using idx, so that if
             another thread is simultaneously changing "s" there's no chance
             it'll make us copy more than count characters */
          for (idx = cstart; idx < cend && count != 0; idx++)
            {
              if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
                {
                  *dst++ = cstr[idx];
                  count--;
                }
            }
        }
    }
  else
    {
      SCM ls = SCM_EOL;
      scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
      SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);

      idx = cstart;
      while (idx < cend)
        {
          SCM res, ch = SCM_MAKE_CHAR (cstr[idx]);
          res = pred_tramp (char_pred, ch);
          if (scm_is_false (res))
            ls = scm_cons (ch, ls);
          cstr = scm_i_string_chars (s);
          idx++;
        }
      result = scm_reverse_list_to_string (ls);
    }

  scm_remember_upto_here_1 (s);
  return result;
}
#undef FUNC_NAME

void
scm_init_srfi_13 (void)
{
#include "libguile/srfi-13.x"
}

/* End of srfi-13.c.  */