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

/* srfi-13.c --- SRFI-13 procedures for Guile
 *
 * Copyright (C) 2001, 2004 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */


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

#include <libguile.h>

#include "srfi-13.h"
#include "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)


/* Likewise for SCM_VALIDATE_STRING_COPY. */

#define MY_VALIDATE_STRING_COPY(pos, str, cvar)  \
  do {                                           \
    SCM_VALIDATE_STRING (pos, str);              \
    cvar = SCM_I_STRING_CHARS(str);              \
  } while (0)


SCM_DEFINE (scm_string_any, "string-any", 2, 2, 0,
            (SCM char_pred, SCM s, SCM start, SCM end),
	    "Check if the predicate @var{pred} is true for any character in\n"
	    "the string @var{s}.\n"
	    "\n"
	    "Calls to @var{pred} are made from left to right across @var{s}.\n"
	    "When it returns true (ie.@: non-@code{#f}), that return value\n"
	    "is the return from @code{string-any}.\n"
	    "\n"
	    "The SRFI-13 specification requires that the call to @var{pred}\n"
	    "on the last character of @var{s} (assuming that point is\n"
	    "reached) be a tail call, but currently in Guile this is not the\n"
	    "case.")
#define FUNC_NAME s_scm_string_any
{
  char * cstr;
  int cstart, cend;
  SCM res;

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

  if (SCM_CHARP (char_pred))
    {
      return (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
                      cend-cstart) == NULL
              ? SCM_BOOL_F : SCM_BOOL_T);
    }
  else if (SCM_CHARSETP (char_pred))
    {
      int i;
      for (i = cstart; i < cend; i++)
        if (SCM_CHARSET_GET (char_pred, cstr[i]))
          return SCM_BOOL_T;
    }
  else
    {
      SCM_VALIDATE_PROC (1, char_pred);

      cstr += cstart;
      while (cstart < cend)
        {
          res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr));
          if (scm_is_true (res))
            return res;
          cstr++;
          cstart++;
        }
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_every, "string-every", 2, 2, 0,
            (SCM char_pred, SCM s, SCM start, SCM end),
	    "Check if the predicate @var{pred} is true for every character\n"
	    "in the string @var{s}.\n"
	    "\n"
	    "Calls to @var{pred} are made from left to right across @var{s}.\n"
	    "If the predicate is true for every character then the return\n"
	    "value from the last @var{pred} call is the return from\n"
	    "@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"
	    "\n"
	    "The SRFI-13 specification requires that the call to @var{pred}\n"
	    "on the last character of @var{s} (assuming that point is\n"
	    "reached) be a tail call, but currently in Guile this is not the\n"
	    "case.")
#define FUNC_NAME s_scm_string_every
{
  char * cstr;
  int cstart, cend;
  SCM res;

  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);
      int i;
      for (i = cstart; i < cend; i++)
        if (cstr[i] != cchr)
          return SCM_BOOL_F;
      return SCM_BOOL_T;
    }
  else if (SCM_CHARSETP (char_pred))
    {
      int i;
      for (i = cstart; i < cend; i++)
        if (! SCM_CHARSET_GET (char_pred, cstr[i]))
          return SCM_BOOL_F;
      return SCM_BOOL_T;
    }
  else
    {
      SCM_VALIDATE_PROC (1, char_pred);

      res = SCM_BOOL_T;
      cstr += cstart;
      while (cstart < cend)
        {
          res = scm_call_1 (char_pred, SCM_MAKE_CHAR (*cstr));
          if (scm_is_false (res))
            return res;
          cstr++;
          cstart++;
        }
      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_VALIDATE_PROC (1, proc);
  clen = scm_to_size_t (len);
  SCM_ASSERT_RANGE (2, len, clen >= 0);

  res = scm_allocate_string (clen);
  p = SCM_STRING_CHARS (res);
  i = 0;
  while (i < clen)
    {
      ch = scm_call_1 (proc, scm_from_int (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_string_to_listS, "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_string_to_listS
{
  char * cstr;
  int 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);
    }
  return result;
}
#undef FUNC_NAME

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);

  if (i < 0)
    SCM_WRONG_TYPE_ARG (1, chrs);
  result = scm_allocate_string (i);

  {
    unsigned char *data = SCM_STRING_UCHARS (result) + i;

    while (!SCM_NULLP (chrs))
      {
	SCM elt = SCM_CAR (chrs);

	SCM_VALIDATE_CHAR (SCM_ARGn, elt);
	data--;
	*data = SCM_CHAR (elt);
	chrs = SCM_CDR (chrs);
      }
  }
  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");

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;
  int del_len = 0, extra_len = 0;
  int 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_makfrom0str (" ");
      del_len = 1;
    }
  else
    {
      SCM_VALIDATE_STRING (2, delimiter);
      del_len = SCM_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_NULLP (ls))
	extra_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);
      extra_len = (strings - 1) * del_len;
      break;
    default:
      extra_len = strings * del_len;
      break;
    }

  tmp = ls;
  while (SCM_CONSP (tmp))
    {
      SCM elt = SCM_CAR (tmp);
      SCM_VALIDATE_STRING (1, elt);
      len += SCM_STRING_LENGTH (elt);
      tmp = SCM_CDR (tmp);
    }

  result = scm_allocate_string (len + extra_len);
  p = SCM_STRING_CHARS (result);

  tmp = ls;
  switch (gram)
    {
    case GRAM_INFIX:
    case GRAM_STRICT_INFIX:
      while (!SCM_NULLP (tmp))
	{
	  SCM elt = SCM_CAR (tmp);
	  memmove (p, SCM_STRING_CHARS (elt),
		   SCM_STRING_LENGTH (elt) * sizeof (char));
	  p += SCM_STRING_LENGTH (elt);
	  if (!SCM_NULLP (SCM_CDR (tmp)) && del_len > 0)
	    {
	      memmove (p, SCM_STRING_CHARS (delimiter),
		       SCM_STRING_LENGTH (delimiter) * sizeof (char));
	      p += del_len;
	    }
	  tmp = SCM_CDR (tmp);
	}
      break;
    case GRAM_SUFFIX:
      while (!SCM_NULLP (tmp))
	{
	  SCM elt = SCM_CAR (tmp);
	  memmove (p, SCM_STRING_CHARS (elt),
		   SCM_STRING_LENGTH (elt) * sizeof (char));
	  p += SCM_STRING_LENGTH (elt);
	  if (del_len > 0)
	    {
	      memmove (p, SCM_STRING_CHARS (delimiter),
		       SCM_STRING_LENGTH (delimiter) * sizeof (char));
	      p += del_len;
	    }
	  tmp = SCM_CDR (tmp);
	}
      break;
    case GRAM_PREFIX:
      while (!SCM_NULLP (tmp))
	{
	  SCM elt = SCM_CAR (tmp);
	  if (del_len > 0)
	    {
	      memmove (p, SCM_STRING_CHARS (delimiter),
		       SCM_STRING_LENGTH (delimiter) * sizeof (char));
	      p += del_len;
	    }
	  memmove (p, SCM_STRING_CHARS (elt),
		   SCM_STRING_LENGTH (elt) * sizeof (char));
	  p += SCM_STRING_LENGTH (elt);
	  tmp = SCM_CDR (tmp);
	}
      break;
    }
  return result;
#undef GRAM_INFIX
#undef GRAM_STRICT_INFIX
#undef GRAM_SUFFIX
#undef GRAM_PREFIX
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_copyS, "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_string_copyS
{
  char * cstr;
  int cstart, cend;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
				   2, start, cstart,
				   3, end, cend);
  return scm_mem2string (cstr + cstart, cend - cstart);

}
#undef FUNC_NAME


SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
            (SCM str, SCM start, SCM end),
	    "Like @code{substring}, but the result may share memory with the\n"
	    "argument @var{str}.")
#define FUNC_NAME s_scm_substring_shared
{
  size_t s, e;
  SCM_VALIDATE_STRING (1, str);
  s = scm_to_size_t (start);
  if (SCM_UNBNDP (end))
    e = SCM_STRING_LENGTH (str);
  else
    e = scm_to_size_t (end);
  if (s == 0 && e == SCM_STRING_LENGTH (str))
    return str;
  else
    return scm_substring (str, start, end);
}
#undef FUNC_NAME


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
{
  char * cstr, * ctarget;
  int cstart, cend, ctstart, dummy;
  int len;
  SCM sdummy = SCM_UNDEFINED;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget,
				   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_STRING_LENGTH (target) - ctstart);

  memmove (SCM_STRING_CHARS (target) + ctstart,
	   SCM_STRING_CHARS (s) + cstart,
	   len * sizeof (char));
  return SCM_UNSPECIFIED;
}
#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
{
  char * cstr;
  size_t cn;

  MY_VALIDATE_STRING_COPY (1, s, cstr);
  cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s));

  return scm_mem2string (cstr, cn);
}
#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
{
  char * cstr;
  size_t cn;

  MY_VALIDATE_STRING_COPY (1, s, cstr);
  cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s));

  return scm_mem2string (cstr + cn, SCM_STRING_LENGTH (s) - cn);
}
#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
{
  char * cstr;
  size_t cn;

  MY_VALIDATE_STRING_COPY (1, s, cstr);
  cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s));

  return scm_mem2string (cstr + SCM_STRING_LENGTH (s) - cn, cn);
}
#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
{
  char * cstr;
  size_t cn;

  MY_VALIDATE_STRING_COPY (1, s, cstr);
  cn = scm_to_unsigned_integer (n, 0, SCM_STRING_LENGTH (s));

  return scm_mem2string (cstr, SCM_STRING_LENGTH (s) - cn);
}
#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;
  char * cstr;
  size_t cstart, cend, clen;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
				   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);
    }
  result = scm_allocate_string (clen);
  if (clen < (cend - cstart))
    memmove (SCM_STRING_CHARS (result),
	     cstr + cend - clen,
	     clen * sizeof (char));
  else
    {
      memset (SCM_STRING_CHARS (result), cchr,
	      (clen - (cend - cstart)) * sizeof (char));
      memmove (SCM_STRING_CHARS (result) + (clen - (cend - cstart)),
	       cstr + cstart,
	       (cend - cstart) * sizeof (char));
    }
  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;
  char * cstr;
  size_t cstart, cend, clen;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
				   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);
    }
  result = scm_allocate_string (clen);
  if (clen < (cend - cstart))
    memmove (SCM_STRING_CHARS (result), cstr + cstart, clen * sizeof (char));
  else
    {
      memset (SCM_STRING_CHARS (result) + (cend - cstart),
	      cchr, (clen - (cend - cstart)) * sizeof (char));
      memmove (SCM_STRING_CHARS (result), cstr + cstart,
	       (cend - cstart) * sizeof (char));
    }
  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
{
  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_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;

	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
	  if (scm_is_false (res))
	    break;
	  cstart++;
	}
    }
  return scm_mem2string (cstr + cstart, cend - cstart);
}
#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
{
  char * cstr;
  int 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_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;

	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
	  if (scm_is_false (res))
	    break;
	  cend--;
	}
    }
  return scm_mem2string (cstr + cstart, cend - cstart);
}
#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
{
  char * cstr;
  int 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_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;

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

	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
	  if (scm_is_false (res))
	    break;
	  cend--;
	}
    }
  return scm_mem2string (cstr + cstart, cend - cstart);
}
#undef FUNC_NAME


SCM_DEFINE (scm_string_fill_xS, "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_string_fill_xS
{
  char * cstr;
  int cstart, cend;
  int c;
  long k;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
				   3, start, cstart,
				   4, end, cend);
  SCM_VALIDATE_CHAR_COPY (2, chr, c);
  for (k = cstart; k < cend; k++)
    cstr[k] = c;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
				   6, start1, cstart1,
				   7, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (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])
	return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1));
      else if (cstr1[cstart1] > cstr2[cstart2])
	return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1));
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1));
  else if (cstart2 < cend2)
    return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1));
  else
    return scm_call_1 (proc_eq, SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
				   6, start1, cstart1,
				   7, end1, cend1);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (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]))
	return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1));
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1));
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return scm_call_1 (proc_gt, SCM_I_MAKINUM (cstart1));
  else if (cstart2 < cend2)
    return scm_call_1 (proc_lt, SCM_I_MAKINUM (cstart1));
  else
    return scm_call_1 (proc_eq, SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_BOOL_F;
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_I_MAKINUM (cstart1);
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_I_MAKINUM (cstart1);
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_BOOL_F;
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_I_MAKINUM (cstart1);
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int 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])
	return SCM_BOOL_F;
      else if (cstr1[cstart1] > cstr2[cstart2])
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_BOOL_F;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_I_MAKINUM (cstart1);
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_I_MAKINUM (cstart1);
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_BOOL_F;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_I_MAKINUM (cstart1);
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_BOOL_F;
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_BOOL_F;
  else if (cstart2 < cend2)
    return SCM_I_MAKINUM (cstart1);
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int 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]))
	return SCM_BOOL_F;
      else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
      cstart2++;
    }
  if (cstart1 < cend1)
    return SCM_I_MAKINUM (cstart1);
  else if (cstart2 < cend2)
    return SCM_BOOL_F;
  else
    return SCM_I_MAKINUM (cstart1);
}
#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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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])
	return SCM_I_MAKINUM (len);
      len++;
      cstart1++;
      cstart2++;
    }
  return SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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]))
	return SCM_I_MAKINUM (len);
      len++;
      cstart1++;
      cstart2++;
    }
  return SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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])
	return SCM_I_MAKINUM (len);
      len++;
    }
  return SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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]))
	return SCM_I_MAKINUM (len);
      len++;
    }
  return SCM_I_MAKINUM (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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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])
	return scm_from_bool (len == len1);
      len++;
      cstart1++;
      cstart2++;
    }
  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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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]))
	return scm_from_bool (len == len1);
      len++;
      cstart1++;
      cstart2++;
    }
  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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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])
	return scm_from_bool (len == len1);
      len++;
    }
  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
{
  char * cstr1, * cstr2;
  int cstart1, cend1, cstart2, cend2;
  int 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]))
	return scm_from_bool (len == len1);
      len++;
    }
  return scm_from_bool (len == len1);
}
#undef FUNC_NAME


/* FIXME::martin: The `S' is to avoid a name clash with the procedure
   in the core, which does not accept a predicate. */
SCM_DEFINE (scm_string_indexS, "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_indexS
{
  char * cstr;
  int 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])
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
	{
	  if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  else
    {
      SCM_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
	  if (scm_is_true (res))
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  return SCM_BOOL_F;
}
#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
{
  char * cstr;
  int 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])
	    return SCM_I_MAKINUM (cend);
	}
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
	{
	  cend--;
	  if (SCM_CHARSET_GET (char_pred, cstr[cend]))
	    return SCM_I_MAKINUM (cend);
	}
    }
  else
    {
      SCM_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;
	  cend--;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
	  if (scm_is_true (res))
	    return SCM_I_MAKINUM (cend);
	}
    }
  return SCM_BOOL_F;
}
#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
{
  char * cstr;
  int 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])
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
	{
	  if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  else
    {
      SCM_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
	  if (scm_is_false (res))
	    return SCM_I_MAKINUM (cstart);
	  cstart++;
	}
    }
  return SCM_BOOL_F;
}
#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 satisifie 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
{
  char * cstr;
  int 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])
	    return SCM_I_MAKINUM (cend);
	}
    }
  else if (SCM_CHARSETP (char_pred))
    {
      while (cstart < cend)
	{
	  cend--;
	  if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
	    return SCM_I_MAKINUM (cend);
	}
    }
  else
    {
      SCM_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;
	  cend--;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cend]));
	  if (scm_is_false (res))
	    return SCM_I_MAKINUM (cend);
	}
    }
  return SCM_BOOL_F;
}
#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
{
  char * cstr;
  int cstart, cend;
  int 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_VALIDATE_PROC (2, char_pred);
      while (cstart < cend)
	{
	  SCM res;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
	  if (scm_is_true (res))
	    count++;
	  cstart++;
	}
    }
  return SCM_I_MAKINUM (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
{
  char * cs1, * cs2;
  int cstart1, cend1, cstart2, cend2;
  int 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;
  while (cstart1 <= cend1 - len2)
    {
      i = cstart1;
      j = cstart2;
      while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
	{
	  i++;
	  j++;
	}
      if (j == cend2)
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
    }
  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
{
  char * cs1, * cs2;
  int cstart1, cend1, cstart2, cend2;
  int 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;
  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)
	return SCM_I_MAKINUM (cstart1);
      cstart1++;
    }
  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, int start, int end)
{
  unsigned long k;

  for (k = start; k < end; ++k)
    SCM_STRING_UCHARS (v) [k] = scm_c_upcase (SCM_STRING_UCHARS (v) [k]);

  return v;
}


/* FIXME::martin: The `S' is to avoid a name clash with the procedure
   in the core, which does not accept start/end indices */
SCM_DEFINE (scm_string_upcase_xS, "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_string_upcase_xS
{
  char * cstr;
  int 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


/* FIXME::martin: The `S' is to avoid a name clash with the procedure
   in the core, which does not accept start/end indices */
SCM_DEFINE (scm_string_upcaseS, "string-upcase", 1, 2, 0,
	    (SCM str, SCM start, SCM end),
	    "Upcase every character in @code{str}.")
#define FUNC_NAME s_scm_string_upcaseS
{
  char * cstr;
  int 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


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

  for (k = start; k < end; ++k)
    SCM_STRING_UCHARS (v) [k] = scm_c_downcase (SCM_STRING_UCHARS (v) [k]);

  return v;
}


/* FIXME::martin: The `S' is to avoid a name clash with the procedure
   in the core, which does not accept start/end indices */
SCM_DEFINE (scm_string_downcase_xS, "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_string_downcase_xS
{
  char * cstr;
  int 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


/* FIXME::martin: The `S' is to avoid a name clash with the procedure
   in the core, which does not accept start/end indices */
SCM_DEFINE (scm_string_downcaseS, "string-downcase", 1, 2, 0,
	    (SCM str, SCM start, SCM end),
	    "Downcase every character in @var{str}.")
#define FUNC_NAME s_scm_string_downcaseS
{
  char * cstr;
  int 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


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

  sz = SCM_STRING_UCHARS (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;
    }
  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
{
  char * cstr;
  int 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
{
  char * cstr;
  int 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


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

  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
{
  char * cstr;
  int cstart;
  int cend;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
				   2, start, cstart,
				   3, end, cend);
  result = scm_string_copy (str);
  string_reverse_x (SCM_STRING_CHARS (result), cstart, cend);
  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;
  int cstart;
  int cend;

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


SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
            (SCM ls),
	    "Like @code{string-append}, but the result may share memory\n"
	    "with the argument strings.")
#define FUNC_NAME s_scm_string_append_shared
{
  long i;

  SCM_VALIDATE_REST_ARGUMENT (ls);

  /* Optimize the one-argument case.  */
  i = scm_ilength (ls);
  if (i == 1)
    return SCM_CAR (ls);
  else
    return scm_string_append (ls);
}
#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
{
  long strings = scm_ilength (ls);
  SCM tmp, result;
  int len = 0;
  char * p;

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

  /* Calculate the size of the result string.  */
  tmp = ls;
  while (!SCM_NULLP (tmp))
    {
      SCM elt = SCM_CAR (tmp);
      SCM_VALIDATE_STRING (1, elt);
      len += SCM_STRING_LENGTH (elt);
      tmp = SCM_CDR (tmp);
    }
  result = scm_allocate_string (len);

  /* Copy the list elements into the result.  */
  p = SCM_STRING_CHARS (result);
  tmp = ls;
  while (!SCM_NULLP (tmp))
    {
      SCM elt = SCM_CAR (tmp);
      memmove (p, SCM_STRING_CHARS (elt),
	       SCM_STRING_LENGTH (elt) * sizeof (char));
      p += SCM_STRING_LENGTH (elt);
      tmp = SCM_CDR (tmp);
    }
  return result;
}
#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
{
  long strings;
  SCM tmp, result;
  size_t len = 0;
  char * p;
  size_t cend = 0;

  /* Check the optional arguments and calculate the additional length
     of the result string.  */
  if (!SCM_UNBNDP (final_string))
    {
      SCM_VALIDATE_STRING (2, final_string);
      if (!SCM_UNBNDP (end))
	{
	  cend = scm_to_unsigned_integer (end,
					  0, SCM_STRING_LENGTH (final_string));
	}
      else
	{
	  cend = SCM_STRING_LENGTH (final_string);
	}
      len += cend;
    }
  strings = scm_ilength (ls);
  /* Validate the string list.  */
  if (strings < 0)
    SCM_WRONG_TYPE_ARG (1, ls);

  /* Calculate the length of the result string.  */
  tmp = ls;
  while (!SCM_NULLP (tmp))
    {
      SCM elt = SCM_CAR (tmp);
      SCM_VALIDATE_STRING (1, elt);
      len += SCM_STRING_LENGTH (elt);
      tmp = SCM_CDR (tmp);
    }

  result = scm_allocate_string (len);

  p = SCM_STRING_CHARS (result) + len;

  /* Construct the result string, possibly by using the optional final
     string.  */
  if (!SCM_UNBNDP (final_string))
    {
      p -= cend;
      memmove (p, SCM_STRING_CHARS (final_string), cend * sizeof (char));
    }
  tmp = ls;
  while (!SCM_NULLP (tmp))
    {
      SCM elt = SCM_CAR (tmp);
      p -= SCM_STRING_LENGTH (elt);
      memmove (p, SCM_STRING_CHARS (elt),
	       SCM_STRING_LENGTH (elt) * sizeof (char));
      tmp = SCM_CDR (tmp);
    }
  return result;
}
#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
{
  /* Optimize the one-string case.  */
  long i = scm_ilength (ls);
  if (i == 1)
    {
      SCM_VALIDATE_STRING (1, SCM_CAR (ls));
      return SCM_CAR (ls);
    }
  return scm_string_concatenate (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 * cstr, *p;
  int cstart, cend;
  SCM result;

  SCM_VALIDATE_PROC (1, proc);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  result = scm_allocate_string (cend - cstart);
  p = SCM_STRING_CHARS (result);
  while (cstart < cend)
    {
      unsigned int c =  (unsigned char) cstr[cstart];
      SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c));
      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
{
  char * cstr, *p;
  int cstart, cend;

  SCM_VALIDATE_PROC (1, proc);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  p = SCM_STRING_CHARS (s) + cstart;
  while (cstart < cend)
    {
      unsigned int c =  (unsigned char) cstr[cstart];
      SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (c));
      if (!SCM_CHARP (ch))
	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
      cstart++;
      *p++ = SCM_CHAR (ch);
    }
  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
{
  char * cstr;
  int 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);
      cstart++;
    }
  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
{
  char * cstr;
  int 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);
      cend--;
    }
  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_allocate_string (0);
  if (!SCM_UNBNDP (make_final))
    SCM_VALIDATE_PROC (6, make_final);

  res = scm_call_1 (p, seed);
  while (scm_is_false (res))
    {
      SCM str;
      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_allocate_string (1);
      *SCM_STRING_CHARS (str) = 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_allocate_string (0);
  if (!SCM_UNBNDP (make_final))
    SCM_VALIDATE_PROC (6, make_final);

  res = scm_call_1 (p, seed);
  while (scm_is_false (res))
    {
      SCM str;
      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_allocate_string (1);
      *SCM_STRING_CHARS (str) = 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
{
  char * cstr;
  int cstart, cend;

  SCM_VALIDATE_PROC (1, proc);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  while (cstart < cend)
    {
      unsigned int c = (unsigned char) cstr[cstart];
      scm_call_1 (proc, SCM_MAKE_CHAR (c));
      cstart++;
    }
  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),
	    "@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
{
  char * cstr;
  int cstart, cend;

  SCM_VALIDATE_PROC (1, proc);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  while (cstart < cend)
    {
      scm_call_1 (proc, SCM_I_MAKINUM (cstart));
      cstart++;
    }
  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
{
  char * cs, * p;
  size_t cstart, cend, cfrom, cto;
  SCM result;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cs,
				   4, start, cstart,
				   5, end, cend);
  cfrom = scm_to_size_t (from);
  if (SCM_UNBNDP (to))
    cto = cfrom + (cend - cstart);
  else
    cto = scm_to_size_t (to);
  if (cstart == cend && cfrom != cto)
    SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);

  result = scm_allocate_string (cto - cfrom);

  p = SCM_STRING_CHARS (result);
  while (cfrom < cto)
    {
      int t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
      if (cfrom < 0)
	*p = cs[(cend - cstart) - t];
      else
	*p = cs[t];
      cfrom++;
      p++;
    }
  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 * ctarget, * cs, * p;
  size_t ctstart, csfrom, csto, cstart, cend;
  SCM dummy = SCM_UNDEFINED;
  int cdummy;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, target, ctarget,
				   2, tstart, ctstart,
				   2, dummy, cdummy);
  MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cs,
				   6, start, cstart,
				   7, end, cend);
  csfrom = scm_to_size_t (sfrom);
  if (SCM_UNBNDP (sto))
    csto = csfrom + (cend - cstart);
  else
    csto = scm_to_size_t (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_STRING_LENGTH (target));

  p = ctarget + ctstart;
  while (csfrom < csto)
    {
      int t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
      if (csfrom < 0)
	*p = cs[(cend - cstart) - t];
      else
	*p = cs[t];
      csfrom++;
      p++;
    }
  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
{
  char * cstr1, * cstr2, * p;
  size_t cstart1, cend1, cstart2, cend2;
  SCM result;

  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);
  result = scm_allocate_string (cstart1 + (cend2 - cstart2) +
				SCM_STRING_LENGTH (s1) - cend1);
  p = SCM_STRING_CHARS (result);
  memmove (p, cstr1, cstart1 * sizeof (char));
  memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
  memmove (p + cstart1 + (cend2 - cstart2),
	   cstr1 + cend1,
	   (SCM_STRING_LENGTH (s1) - cend1) * sizeof (char));
  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} from module (srfi srfi-14).\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
{
  char * cstr;
  size_t cstart, cend;
  SCM result = SCM_EOL;

  static SCM charset_graphic = SCM_BOOL_F;

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

  if (SCM_UNBNDP (token_set))
    {
      if (charset_graphic == SCM_BOOL_F)
	{
	  SCM srfi_14_module = scm_c_resolve_module ("srfi srfi-14");
	  SCM charset_graphic_var = scm_c_module_lookup (srfi_14_module,
							 "char-set:graphic");
	  charset_graphic =
	    scm_permanent_object (SCM_VARIABLE_REF (charset_graphic_var));
	}
      token_set = charset_graphic;
    }

  if (SCM_CHARSETP (token_set))
    {
      int 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_mem2string (cstr + cend, idx - cend), result);
	}
    }
  else SCM_WRONG_TYPE_ARG (2, token_set);
  return result;
}
#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 that\n"
	    "satisfy the @var{char_pred} argument.  If the argument is a\n"
	    "procedure, it is applied to each character as a predicate, if\n"
	    "it is a character, it is tested for equality and if it is a\n"
	    "character set, it is tested for membership.")
#define FUNC_NAME s_scm_string_filter
{
  char * cstr;
  size_t cstart, cend;
  SCM result;
  int idx;

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      SCM ls = SCM_EOL;
      char chr;

      chr = SCM_CHAR (char_pred);
      idx = cstart;
      while (idx < cend)
	{
	  if (cstr[idx] == chr)
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  else if (SCM_CHARSETP (char_pred))
    {
      SCM ls = SCM_EOL;

      idx = cstart;
      while (idx < cend)
	{
	  if (SCM_CHARSET_GET (char_pred, cstr[idx]))
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  else
    {
      SCM ls = SCM_EOL;

      SCM_VALIDATE_PROC (2, char_pred);
      idx = cstart;
      while (idx < cend)
	{
	  SCM res;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
	  if (scm_is_true (res))
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  return result;
}
#undef FUNC_NAME


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

  MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
				   3, start, cstart,
				   4, end, cend);
  if (SCM_CHARP (char_pred))
    {
      SCM ls = SCM_EOL;
      char chr;

      chr = SCM_CHAR (char_pred);
      idx = cstart;
      while (idx < cend)
	{
	  if (cstr[idx] != chr)
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  else if (SCM_CHARSETP (char_pred))
    {
      SCM ls = SCM_EOL;

      idx = cstart;
      while (idx < cend)
	{
	  if (!SCM_CHARSET_GET (char_pred, cstr[idx]))
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  else
    {
      SCM ls = SCM_EOL;

      SCM_VALIDATE_PROC (2, char_pred);
      idx = cstart;
      while (idx < cend)
	{
	  SCM res;
	  res = scm_call_1 (char_pred, SCM_MAKE_CHAR (cstr[idx]));
	  if (scm_is_false (res))
	    ls = scm_cons (SCM_MAKE_CHAR (cstr[idx]), ls);
	  idx++;
	}
      result = scm_reverse_list_to_string (ls);
    }
  return result;
}
#undef FUNC_NAME


/* Initialize the SRFI-13 module.  This function will be called by the
   loading Scheme module.  */
void
scm_init_srfi_13 (void)
{
  /* We initialize the SRFI-14 module here, because the string
     primitives need the charset smob type created by that module.  */
  scm_c_init_srfi_14 ();

  /* Install the string primitives.  */
#include "srfi/srfi-13.x"
}

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