/* libsizzle/srfi-13.c - string operations from SRFI-13
 
  Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2, or (at your option)
  any later version.
  
  This software 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 General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this package; see the file COPYING.  If not, write to the
  Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  MA 02111-1307, USA.  */

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

#ifndef __USE_BSD
# define __USE_BSD
#endif
#include <string.h>
#include <ctype.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "node.h"
#include "validate.h"
#include "capi.h"
#include "stringfun.h"
#include "list.h"

/* On initialization, the symbol `infix', `strict-infix', `suffix' and
   `prefix' are created for use with `string-join'.  For faster
   operation, they are created on startup and then taken from these
   variables.  */
static zzz_scm_t infix_sym;
static zzz_scm_t strict_infix_sym;
static zzz_scm_t suffix_sym;
static zzz_scm_t prefix_sym;

/*:doc
  string-null?
  (string-null? str) => boolean
  Return @code{#t} if @var{obj} is a the empty string @code{""},
  @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string-null?"
static result_t
string_null_p_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  if (string_len (str) == 0)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#define FUNC_NAME "string-upcase!"
/*:doc
  string-upcase!
  (string-upcase! s [start end]) => string
  Convert all characters in @var{s} to upper case, modifying @var{s} in-place.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
static result_t
string_upcase_x (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
		 zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * p, *endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  if (ro_string_p (string))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("read-only string passed to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if ((err = zzz_parse_string_indices
       (s_func_name, 2, string, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (string) + cstart;
  endp = string_val (string) + cend;
  while (p < endp)
    {
      *p = toupper (*p);
      p++;
    }
  *result = string;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-upcase
  (string-upcase s [start end]) => string
  Convert all characters in @var{s} to upper case, returning a newly allocated
  string.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-upcase"
static result_t
string_upcase (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
	       zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t str;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  str = zzz_make_string (string_val (string), string_len (string));
  string_upcase_x (env, str, start, end, result);
  *result = str;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-downcase!
  (string-downcase! s [start end]) => string
  Convert all characters in @var{s} to lower case, modifying @var{s} in-place.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-downcase!"
static result_t
string_downcase_x (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
		   zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * p, *endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  if (ro_string_p (string))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("read-only string passed to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if ((err = zzz_parse_string_indices
       (s_func_name, 2, string, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (string) + cstart;
  endp = string_val (string) + cend;
  while (p < endp)
    {
      *p = tolower (*p);
      p++;
    }
  *result = string;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-downcase
  (string-downcase s [start end]) => string
  Convert all characters in @var{s} to lower case, returning a newly allocated
  string.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-downcase"
static result_t
string_downcase (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
		 zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t str;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  str = zzz_make_string (string_val (string), string_len (string));
  string_downcase_x (env, str, start, end, result);
  *result = str;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-titlecase!
  (string-titlecase! s [start end]) => string
  Upper-case all characters in @var{s} which are starting words, modifying
  S in-place.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-titlecase!"
static result_t
string_titlecase_x (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
		     zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * p, *endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  if (ro_string_p (string))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("read-only string passed to `"), -1),
	  zzz_make_string (s_func_name, -1), 
	  zzz_make_string ("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if ((err = zzz_parse_string_indices
       (s_func_name, 2, string, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (string) + cstart;
  endp = string_val (string) + cend;
  while (p < endp)
    {
      while (p < endp && !isalpha (*p))
	p++;
      if (p < endp)
	{
	  *p = toupper (*p);
	  p++;
	  while (p < endp && isalpha (*p))
	    {
	      *p = tolower (*p);
	      p++;
	    }
	}
    }
  *result = string;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-titlecase
  (string-titlecase s [start end]) => string
  Upper-case all characters in @var{s} which are starting words, returning 
  a newly allocated string.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-titlecase"
static result_t
string_titlecase (zzz_scm_t env, zzz_scm_t string, zzz_scm_t start,
		   zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t str;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  str = zzz_make_string (string_val (string), string_len (string));
  string_titlecase_x (env, str, start, end, result);
  *result = str;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-trim
  (string-trim s [char/pred start end]) => string
  Skip all characters matching @var{char} or passing application of
  @var{pred} at the left of the string.  @var{start} and @var{end} are
  optional parameters to restrict operation to the characters between
  these indices.
  doc:*/
#define FUNC_NAME "string-trim"
static result_t
string_trim (zzz_scm_t env, zzz_scm_t str, zzz_scm_t char_pred,
	     zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * startp, * endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 3, str,
				   start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  startp = string_val (str) + cstart;
  endp = string_val (str) + cend;
  if (char_pred == zzz_undefined)
    {
      while (startp < endp && isspace (*startp))
	startp++;
    }
  else if (char_p (char_pred))
    {
      int ch = char_val (char_pred);
      while (startp < endp && *startp == ch)
	startp++;
    }
  else
    {
      CHECK_TYPE (2, procedure_p (char_pred), _("character or predicate"));
      while (startp < endp)
	{
	  if ((err = zzz_apply (env, char_pred,
				zzz_cons (zzz_make_char (*startp), NULL),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (*result == zzz_false_value)
	    break;
	  startp++;
	}
    }
  *result = zzz_make_string (startp, endp - startp);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-trim-right
  (string-trim-right s [char/pred start end]) => string
  Skip all characters matching @var{char} or passing application of
  @var{pred} at the right of the string.  @var{start} and @var{end}
  are optional parameters to restrict operation to the characters
  between these indices.
  doc:*/
#define FUNC_NAME "string-trim-right"
static result_t
string_trim_right (zzz_scm_t env, zzz_scm_t str, zzz_scm_t char_pred,
		   zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * startp, * endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 3, str,
				   start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  startp = string_val (str) + cstart;
  endp = string_val (str) + cend;
  if (char_pred == zzz_undefined)
    {
      while (startp < endp && isspace (endp[-1]))
	endp--;
    }
  else if (char_p (char_pred))
    {
      int ch = char_val (char_pred);
      while (startp < endp && endp[-1] == ch)
	endp--;
    }
  else
    {
      CHECK_TYPE (2, procedure_p (char_pred), _("character or predicate"));
      while (startp < endp)
	{
	  if ((err = zzz_apply (env, char_pred,
				zzz_cons (zzz_make_char (endp[-1]), NULL),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (*result == zzz_false_value)
	    break;
	  endp--;
	}
    }
  *result = zzz_make_string (startp, endp - startp);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-trim-both
  (string-trim-both s [char/pred start end]) => string
  Skip all characters matching @var{char} or passing application of
  @var{pred} at both ends of the string.  @var{start} and @var{end}
  are optional parameters to restrict operation to the characters
  between these indices.
  doc:*/
#define FUNC_NAME "string-trim-both"
static result_t
string_trim_both (zzz_scm_t env, zzz_scm_t str, zzz_scm_t char_pred,
	     zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * startp, * endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 3, str,
				   start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  startp = string_val (str) + cstart;
  endp = string_val (str) + cend;
  if (char_pred == zzz_undefined)
    {
      while (startp < endp && isspace (*startp))
	startp++;
      while (startp < endp && isspace (endp[-1]))
	endp--;
    }
  else if (char_p (char_pred))
    {
      int ch = char_val (char_pred);
      while (startp < endp && *startp == ch)
	startp++;
      while (startp < endp && endp[-1] == ch)
	endp--;
    }
  else
    {
      CHECK_TYPE (2, procedure_p (char_pred), _("character or predicate"));
      while (startp < endp)
	{
	  if ((err = zzz_apply (env, char_pred,
				zzz_cons (zzz_make_char (*startp), NULL),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (*result == zzz_false_value)
	    break;
	  startp++;
	}
      while (startp < endp)
	{
	  if ((err = zzz_apply (env, char_pred,
				zzz_cons (zzz_make_char (endp[-1]), NULL),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (*result == zzz_false_value)
	    break;
	  endp--;
	}
    }
  *result = zzz_make_string (startp, endp - startp);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-every
  (string-every pred s [start end]) => value
  Returns a true value, if the applications of @var{pred} to all of
  the characters of @var{s} yield true values.  @var{start} and @var{end}
  may be given to restrict operation to the characters of @var{s} between
  these indices.
  doc:*/
#define FUNC_NAME "string-every"
static result_t
string_every (zzz_scm_t env, zzz_scm_t pred, zzz_scm_t string,
	      zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * startp, * endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, procedure_p (pred), zzz_procedure_type_name);
  CHECK_TYPE (2, string_p (string), zzz_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 3, string,
				   start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  startp = string_val (string) + cstart;
  endp = string_val (string) + cend;
  *result = zzz_true_value;
  while (startp < endp)
    {
      if ((err = zzz_apply (env, pred,
			    zzz_cons (zzz_make_char (*startp), NULL),
			    result)) != RESULT_SUCCESS)
	return err;
      if (*result == zzz_false_value)
	return RESULT_SUCCESS;
      startp++;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-any
  (string-any pred s [start end]) => value
  Returns a true value, if the application of @var{pred} to any of the
  characters of @var{s} yields a true value.  @var{start} and @var{end} may
  be given to restrict operation to the characters of @var{s} between these
  indices.
  doc:*/
#define FUNC_NAME "string-any"
static result_t
string_any (zzz_scm_t env, zzz_scm_t pred, zzz_scm_t string,
	    zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * startp, * endp;
  int cstart, cend;
  result_t err;

  CHECK_TYPE (1, procedure_p (pred), zzz_procedure_type_name);
  CHECK_TYPE (2, string_p (string), zzz_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 3, string,
				   start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  startp = string_val (string) + cstart;
  endp = string_val (string) + cend;
  *result = zzz_false_value;
  while (startp < endp)
    {
      if ((err = zzz_apply (env, pred,
			    zzz_cons (zzz_make_char (*startp), NULL),
			    result)) != RESULT_SUCCESS)
	return err;
      if (*result != zzz_false_value)
	return RESULT_SUCCESS;
      startp++;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-tabulate
  (string-tabulate proc len) => string
  Create a string o length @var{len}, where each character is initialized from
  the value returned by applying @var{proc} to the character index.
  doc:*/
#define FUNC_NAME "string-tabulate"
static result_t
string_tabulate (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t len,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;
  int l;
  result_t err;

  CHECK_TYPE (1, procedure_p (proc), zzz_procedure_type_name);
  CHECK_TYPE (2, integer_p (len), zzz_integer_type_name);
  l = integer_val (len);
  res = zzz_make_nstring (l);
  while (l-- > 0)
    {
      if ((err = zzz_apply (env, proc, zzz_cons (zzz_make_integer (l), NULL),
			    result)) != RESULT_SUCCESS)
	return err;
      if (!char_p (*result))
	{
	  *result = zzz_make_error
	    (zzz_make_list
	     (zzz_make_string
	      (_("procedure did not return character in call to "), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL),
	     NULL);
	  return RESULT_SUCCESS;
	}
      string_val (res)[l] = char_val (*result);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-join
  (string-join string-list [delimiter grammar]) => string
  @var{string-list} must be a list of strings, @var{delimiter} must be
  a string and @var{grammar} must be any of the symbols infix, strict-infix,
  prefix or suffix.  The strings from @var{string-list} are joined
  with @var{delimiter} inbetween according to @var{grammar}.
  doc:*/
#define FUNC_NAME "string-join"
static result_t
string_join (zzz_scm_t env, zzz_scm_t string_list, zzz_scm_t delimiter,
	     zzz_scm_t grammar, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;		/* For traversing string-list. */
  zzz_scm_t res;		/* Result string.  */
  int res_len = 0;		/* Length of result string.  */
  int str_count = 0;		/* Count of elements in string-list */
  char * delim = "";		/* Delimiter string.  */
  int delim_len = 0;		/* Length of the above.  */
  int extra_len = 0;		/* Length of all delimiters together.  */
  char * p;			/* Running pointer into result string. */

  /* Check structure of the string-list argument and compute the total
     length of all the strings.  */
  CHECK_TYPE (1, zzz_list_length (string_list) >= 0, _("list of strings"));
  tmp = string_list;
  while (cons_p (tmp))
    {
      CHECK_TYPE (1, string_p (car (tmp)), _("list of strings"));
      res_len += string_len (car (tmp));
      str_count++;
      tmp = cdr (tmp);
    }

  /* If specified, check delimiter and get the value.  */
  if (delimiter != zzz_undefined)
    {
      CHECK_TYPE (2, string_p (delimiter), zzz_string_type_name);
      delim = string_val (delimiter);
      delim_len = string_len (delimiter);
    }

  /* Validate the grammar parameter.  */
  if (grammar != zzz_undefined)
    {
      CHECK_TYPE
	(3,
	 grammar == infix_sym ||
	 grammar == strict_infix_sym ||
	 grammar == prefix_sym ||
	 grammar == suffix_sym,
	 _("any of the symbols infix, strixt_infix, prefix or suffix"));
    }
  else
    grammar = infix_sym;

  /* Calculate the length all delimiters will need in the result
     string.  This also verifies that a non-empty list is given if the
     grammar is `string-infix'.  */
  if (grammar == infix_sym)
    extra_len = str_count > 0 ? ((str_count - 1) * delim_len) : 0;
  else if (grammar == strict_infix_sym)
    {
      if (str_count == 0)
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string
	      (_("`strict-infix' requires non-empty string list in `"), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      extra_len = (str_count - 1) * delim_len;
    }
  else
    extra_len = str_count * delim_len;

  /* Create the result string with the necessary length and copy all
     the strings from the string list together with the delimiter into
     the result.  */
  res = zzz_make_nstring (res_len + extra_len);
  p = string_val (res);
  if (grammar == prefix_sym)
    {
      memmove (p, delim, delim_len);
      p += delim_len;
    }
  tmp = string_list;
  while (cons_p (tmp))
    {
      memmove (p, string_val (car (tmp)), string_len (car (tmp)));
      p += string_len (car (tmp));
      tmp = cdr (tmp);
      if (cons_p (tmp))
	{
	  memmove (p, delim, delim_len);
	  p += delim_len;
	}
    }
  if (grammar == suffix_sym)
    {
      memmove (p, delim, delim_len);
      p += delim_len;
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-prefix-length
  (string-prefix-length s1 s2 [start1 end1 start2 end2]) => integer
  Return the length of the longest common prefix of the two strings.
  doc:*/
#define FUNC_NAME "string-prefix-length"
static result_t
string_prefix_length (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		      zzz_scm_t start1, zzz_scm_t end1,
		      zzz_scm_t start2, zzz_scm_t end2,
		      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2, len;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  len = 0;
  while (p1 < pend1 && p2 < pend2 && *p1 == *p2)
    {
      len++;
      p1++;
      p2++;
    }
  *result = zzz_make_integer (len);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-prefix-length-ci
  (string-prefix-length-ci s1 s2 [start1 end1 start2 end2]) => integer
  Return the length of the longest common prefix of the two strings.
  When comparing characters, case is ignored.
  doc:*/
#define FUNC_NAME "string-prefix-length-ci"
static result_t
string_prefix_length_ci (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
			 zzz_scm_t start1, zzz_scm_t end1,
			 zzz_scm_t start2, zzz_scm_t end2,
			 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2, len;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  len = 0;
  while (p1 < pend1 && p2 < pend2 && toupper (*p1) == toupper (*p2))
    {
      len++;
      p1++;
      p2++;
    }
  *result = zzz_make_integer (len);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-suffix-length
  (string-suffix-length s1 s2 [start1 end1 start2 end2]) => integer
  Return the length of the longest common suffix of the two strings.
  doc:*/
#define FUNC_NAME "string-suffix-length"
static result_t
string_suffix_length (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		      zzz_scm_t start1, zzz_scm_t end1,
		      zzz_scm_t start2, zzz_scm_t end2,
		      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2, len;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  len = 0;
  while (p1 < pend1 && p2 < pend2 && pend1[-1] == pend2[-1])
    {
      len++;
      pend1--;
      pend2--;
    }
  *result = zzz_make_integer (len);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-suffix-length-ci
  (string-suffix-length-ci s1 s2 [start1 end1 start2 end2]) => integer
  Return the length of the longest common suffix of the two strings.
  Case is ignored when comparing characters.
  doc:*/
#define FUNC_NAME "string-suffix-length-ci"
static result_t
string_suffix_length_ci (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
			 zzz_scm_t start1, zzz_scm_t end1,
			 zzz_scm_t start2, zzz_scm_t end2,
			 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2, len;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  len = 0;
  while (p1 < pend1 && p2 < pend2 &&
	 toupper (pend1[-1]) == toupper (pend2[-1]))
    {
      len++;
      pend1--;
      pend2--;
    }
  *result = zzz_make_integer (len);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-prefix?
  (string-prefix? s1 s2 [start1 end1 start2 end2]) => boolean
  Return @code{#t} if @var{s1} is a prefix of @var{s2}.
  doc:*/
#define FUNC_NAME "string-prefix?"
static result_t
string_prefix_p (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		 zzz_scm_t start1, zzz_scm_t end1,
		 zzz_scm_t start2, zzz_scm_t end2,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  while (p1 < pend1 && p2 < pend2)
    {
      if (*p1 != *p2)
	{
	  *result = zzz_false_value;
	  return RESULT_SUCCESS;
	}
      p1++;
      p2++;
    }
  *result = zzz_make_bool (p1 == pend1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-prefix-ci?
  (string-prefix-ci? s1 s2 [start1 end1 start2 end2]) => boolean
  Return @code{#t} if @var{s1} is a prefix of @var{s2}.  Case is ignored
  when comparing characters.
  doc:*/
#define FUNC_NAME "string-prefix-ci?"
static result_t
string_prefix_ci_p (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		    zzz_scm_t start1, zzz_scm_t end1,
		    zzz_scm_t start2, zzz_scm_t end2,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  while (p1 < pend1 && p2 < pend2)
    {
      if (toupper (*p1) != toupper (*p2))
	{
	  *result = zzz_false_value;
	  return RESULT_SUCCESS;
	}
      p1++;
      p2++;
    }
  *result = zzz_make_bool (p1 == pend1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-suffix?
  (string-suffix? s1 s2 [start1 end1 start2 end2]) => boolean
  Return @code{#t} if @var{s1} is a suffix of @var{s2}.
  doc:*/
#define FUNC_NAME "string-suffix?"
static result_t
string_suffix_p (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		 zzz_scm_t start1, zzz_scm_t end1,
		 zzz_scm_t start2, zzz_scm_t end2,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  while (p1 < pend1 && p2 < pend2)
    {
      if (pend1[-1] != pend2[-1])
	{
	  *result = zzz_false_value;
	  return RESULT_SUCCESS;
	}
      pend1--;
      pend2--;
    }
  *result = zzz_make_bool (p1 == pend1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-suffix-ci?
  (string-suffix-ci? s1 s2 [start1 end1 start2 end2]) => boolean
  Return @code{#t} if @var{s1} is a suffix of @var{s2}.  Case is
  ignored when comparing characters.
  doc:*/
#define FUNC_NAME "string-suffix-ci?"
static result_t
string_suffix_ci_p (zzz_scm_t env, zzz_scm_t s1, zzz_scm_t s2,
		    zzz_scm_t start1, zzz_scm_t end1,
		    zzz_scm_t start2, zzz_scm_t end2,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * p1, * p2, * pend1, * pend2;
  result_t err;

  CHECK_TYPE (1, string_p (s1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (s2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, s1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, s2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  p1 = string_val (s1) + cstart1;
  p2 = string_val (s2) + cstart2;
  pend1 = string_val (s1) + cend1;
  pend2 = string_val (s2) + cend2;
  while (p1 < pend1 && p2 < pend2)
    {
      if (toupper (pend1[-1]) != toupper (pend2[-1]))
	{
	  *result = zzz_false_value;
	  return RESULT_SUCCESS;
	}
      pend1--;
      pend2--;
    }
  *result = zzz_make_bool (p1 == pend1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-pad
  (string-pad s len [char start end]) => string
  Build a string of length @var{len} comprised of @var{s} padded on the
  left by as many occurences of the character @var{char} as needed.  If
  @var{s} has more than @var{len} characters, it is truncated on the left
  to length @var{len}.  @var{char} defaults to @code{#\space}.
  doc:*/
#define FUNC_NAME "string-pad"
static result_t
string_pad (zzz_scm_t env, zzz_scm_t s, zzz_scm_t len, zzz_scm_t chr,
	    zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend, l;
  char * p, * pend;
  int ch;
  zzz_scm_t res;
  result_t err;

  CHECK_TYPE (1, string_p (s), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (len) && integer_val (len) >= 0,
	      zzz_positive_integer_type_name);
  if (chr != zzz_undefined)
    {
      CHECK_TYPE (3, char_p (chr), zzz_character_type_name);
      ch = char_val (chr);
    }
  else
    ch = ' ';
  if ((err = zzz_parse_string_indices
       (s_func_name, 4, s, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  l = integer_val (len);
  p = string_val (s) + cstart;
  pend = string_val (s) + cend;

  res = zzz_make_nstring (l);
  while (l > 0 && p < pend)
    {
      l--;
      pend--;
      string_val (res)[l] = *pend;
    }
  while (l > 0)
    {
      l--;
      string_val (res)[l] = ch;
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-pad-right
  (string-pad-right s len [char start end]) => string
  Build a string of length @var{len} comprised of @var{s} padded on the
  rightt by as many occurences of the character @var{char} as needed.  If
  @var{s} has more than @var{len} characters, it is truncated on the right
  to length @var{len}.  @var{char} defaults to @code{#\space}.
  doc:*/
#define FUNC_NAME "string-pad-right"
static result_t
string_pad_right (zzz_scm_t env, zzz_scm_t s, zzz_scm_t len, zzz_scm_t chr,
		  zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend, l, x;
  char * p, * pend;
  int ch;
  zzz_scm_t res;
  result_t err;

  CHECK_TYPE (1, string_p (s), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (len) && integer_val (len) >= 0,
	      zzz_positive_integer_type_name);
  if (chr != zzz_undefined)
    {
      CHECK_TYPE (3, char_p (chr), zzz_character_type_name);
      ch = char_val (chr);
    }
  else
    ch = ' ';
  if ((err = zzz_parse_string_indices
       (s_func_name, 4, s, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  l = integer_val (len);
  p = string_val (s) + cstart;
  pend = string_val (s) + cend;

  res = zzz_make_nstring (l);
  x = 0;
  while (x < l && p < pend)
    {
      string_val (res)[x] = *p;
      x++;
      p++;
    }
  while (x < l)
    {
      string_val (res)[x] = ch;
      x++;
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-take
  (string-take s nchars) => string
  Return the first @var{nchars} characters of @var{s}.
  doc:*/
#define FUNC_NAME "string-take"
static result_t
string_take (zzz_scm_t env, zzz_scm_t string, zzz_scm_t nchars,
	     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int n;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (nchars), zzz_integer_type_name);
  n = integer_val (nchars);
  CHECK_RANGE (2, n >= 0 && n <= (int) string_len (string), 
	       zzz_non_negative_integer_type_name);
  *result = zzz_make_string (string_val (string), n);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-take-right
  (string-take-right s nchars) => string
  Return the last @var{nchars} characters of @var{s}.
  doc:*/
#define FUNC_NAME "string-take-right"
static result_t
string_take_right (zzz_scm_t env, zzz_scm_t string, zzz_scm_t nchars,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int n;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (nchars), zzz_integer_type_name);
  n = integer_val (nchars);
  CHECK_RANGE (2, n >= 0 && n <= (int) string_len (string), 
	       zzz_non_negative_integer_type_name);
  *result = zzz_make_string (string_val (string) + (string_len (string) - n),
			     n);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-drop
  (string-drop s nchars) => string
  Return all but the first @var{nchars} characters of @var{s}.
  doc:*/
#define FUNC_NAME "string-drop"
static result_t
string_drop (zzz_scm_t env, zzz_scm_t string, zzz_scm_t nchars,
	     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int n;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (nchars), zzz_integer_type_name);
  n = integer_val (nchars);
  CHECK_RANGE (2, n >= 0 && n <= (int) string_len (string),
	       zzz_non_negative_integer_type_name);
  *result = zzz_make_string (string_val (string) + n, string_len (string) - n);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-drop-right
  (string-drop-right s nchars) => string
  Return all but the last @var{nchars} characters of @var{s}.
  doc:*/
#define FUNC_NAME "string-drop-right"
static result_t
string_drop_right (zzz_scm_t env, zzz_scm_t string, zzz_scm_t nchars,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int n;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (nchars), zzz_integer_type_name);
  n = integer_val (nchars);
  CHECK_RANGE (2, n >= 0 && n <= (int) string_len (string),
	       zzz_non_negative_integer_type_name);
  *result = zzz_make_string (string_val (string), string_len (string) - n);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-hash
  (string-hash s [bound start end]) => integer
  Compute a hash value for the string @var{s}.  @var{bound} is either
  the boolean constant @code{#t} or a positive integer, then the
  result of the procedure will be in the range [0, @var{bound}).
  @var{start} and @var{end} are optional parameters delimiting the
  characters which are used to calculate the hash value, they default
  to 0 and the length of @var{s}.
  doc:*/
#define FUNC_NAME "string-hash"
static result_t
string_hash (zzz_scm_t env, zzz_scm_t string, zzz_scm_t bound,
	     zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend;
  char * p, * endp;
  result_t err;
  zzz_object_t hash_val = 0;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (bound) || zzz_eq (bound, zzz_false_value),
	      _("positive integer or #f"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, string, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (string) + cstart;
  endp = string_val (string) + cend;
  while (p < endp)
    {
      hash_val = (hash_val << 1) ^ ((zzz_object_t) *p);
      p++;
    }
  if (!zzz_eq (bound, zzz_false_value))
    hash_val = hash_val % integer_val (bound);
  *result = zzz_make_integer (hash_val);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-hash-ci
  (string-hash-ci s [bound start end]) => integer
  Compute a hash value for the string @var{s}.  @var{bound} is either
  the boolean constant @code{#t} or a positive integer, then the
  result of the procedure will be in the range [0, @var{bound}).
  @var{start} and @var{end} are optional parameters delimiting the
  characters which are used to calculate the hash value, they default
  to 0 and the length of @var{s}.  The case of the characters in @var{s}
  is ignored when computing the hash value.
  doc:*/
#define FUNC_NAME "string-hash-ci"
static result_t
string_hash_ci (zzz_scm_t env, zzz_scm_t string, zzz_scm_t bound,
		zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend;
  char * p, * endp;
  result_t err;
  zzz_object_t hash_val = 0;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (bound) || zzz_eq (bound, zzz_false_value),
	      _("positive integer or #f"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, string, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (string) + cstart;
  endp = string_val (string) + cend;
  while (p < endp)
    {
      hash_val = (hash_val << 1) ^ ((zzz_object_t) toupper (*p));
      p++;
    }
  if (!zzz_eq (bound, zzz_false_value))
    hash_val = hash_val % integer_val (bound);
  *result = zzz_make_integer (hash_val);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-index
  (string-index string ch/pred [from to]) => integer|#f
  Scans the string @var{string} for the leftmost appearance of character
  @var{ch} and returns the index or @code{#f} if not found.  If the second
  argument is a procedure, it must be a predicate which will be applied to
  each character in @var{string}, and the index of the first character for
  which the predicate yields true is returned.  @var{from} is
  the start index and defaults to zero, @var{to} is the end index and
  defaults to the length of @var{string} - 1.
  doc:*/
#define FUNC_NAME "string-index"
static result_t
string_index_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t ch,
		   zzz_scm_t from, zzz_scm_t to, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int from_idx, to_idx, idx;
  int chr;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (ch) || procedure_p (ch), 
	      _("character or predicate"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, str, from, to, &from_idx, &to_idx, result)) !=
      RESULT_SUCCESS)
    return err;
  if (char_p (ch))
    {
      chr = char_val (ch);
      for (idx = from_idx; idx < to_idx; idx++)
	{
	  if (string_val(str)[idx] == chr)
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  else
    {
      for (idx = from_idx; idx < to_idx; idx++)
	{
	  if ((err = zzz_apply
	       (env, ch,
		zzz_cons (zzz_make_char (string_val(str)[idx]), NULL),
		result)) != RESULT_SUCCESS)
	    return err;
	  if (!zzz_eq (*result, zzz_false_value))
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-index-right
  (string-index-right string ch [from to]) => integer|#f
  Scans the string @var{string} for the rightmost appearance of character
  @var{ch} and returns the index or @code{#f} if not found.  If the second
  argument is a procedure, it must be a predicate which will be applied to
  each character in @var{string} from right to left, and the index of the
  last character for which the predicate yields true is returned.  
  @var{from} is the start index and defaults to zero, @var{to} is the end
  index and defatuls to the length of @var{string} - 1.  This function
  searches from right to left, whereas @code{string-index} searches from
  left to right.
  doc:*/
#define FUNC_NAME "string-index-right"
static result_t
string_index_right_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t ch,
			 zzz_scm_t from, zzz_scm_t to, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int from_idx, to_idx, idx;
  int chr;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (ch) || procedure_p (ch),
	      _("character or predicate"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, str, from, to, &from_idx, &to_idx, result)) !=
      RESULT_SUCCESS)
    return err;
  if (char_p (ch))
    {
      chr = char_val (ch);
      for (idx = to_idx - 1 ; idx >= from_idx; idx--)
	{
	  if (string_val(str)[idx] == chr)
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  else
    {
      for (idx = to_idx - 1; idx >= from_idx; idx--)
	{
	  if ((err = zzz_apply
	       (env, ch,
		zzz_cons (zzz_make_char (string_val(str)[idx]), NULL),
		result)) != RESULT_SUCCESS)
	    return err;
	  if (!zzz_eq (*result, zzz_false_value))
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-skip
  (string-skip string ch/pred [start end]) => integer|#f
  Scans the string @var{string} for the leftmost appearance of a
  character different to @var{ch} and returns the index or @code{#f}
  if not found.  If the second argument is a procedure, it must be a
  predicate which will be applied to each character in @var{string},
  and the index of the first character for which the predicate yields
  false is returned.  @var{start} is the start index and defaults to
  zero, @var{end} is the end index and defaults to the length of
  @var{string} - 1.
  doc:*/
#define FUNC_NAME "string-skip"
static result_t
string_skip (zzz_scm_t env, zzz_scm_t str, zzz_scm_t ch,
	     zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend, idx;
  int chr;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (ch) || procedure_p (ch), 
	      _("character or predicate"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  if (char_p (ch))
    {
      chr = char_val (ch);
      for (idx = cstart; idx < cend; idx++)
	{
	  if (string_val(str)[idx] != chr)
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  else
    {
      for (idx = cstart; idx < cend; idx++)
	{
	  if ((err = zzz_apply
	       (env, ch,
		zzz_cons (zzz_make_char (string_val(str)[idx]), NULL),
		result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-skip-right
  (string-skip-right string ch [start end]) => integer|#f
  Scans the string @var{string} for the rightmost appearance of a
  character different from @var{ch} and returns the index or @code{#f}
  if not found.  If the second argument is a procedure, it must be a
  predicate which will be applied to each character in @var{string}
  from right to left, and the index of the last character for which
  the predicate yields false is returned.  @var{start} is the start
  index and defaults to zero, @var{end} is the end index and defatuls
  to the length of @var{string} - 1.  This function searches from
  right to left, whereas @code{string-index} searches from left to
  right.  
  doc:*/
#define FUNC_NAME "string-skip-right"
static result_t
string_skip_right (zzz_scm_t env, zzz_scm_t str, zzz_scm_t ch,
		   zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend, idx;
  int chr;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (ch) || procedure_p (ch),
	      _("character or predicate"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  if (char_p (ch))
    {
      chr = char_val (ch);
      for (idx = cend - 1 ; idx >= cstart; idx--)
	{
	  if (string_val(str)[idx] != chr)
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  else
    {
      for (idx = cend - 1; idx >= cstart; idx--)
	{
	  if ((err = zzz_apply
	       (env, ch,
		zzz_cons (zzz_make_char (string_val(str)[idx]), NULL),
		result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *result = zzz_make_integer (idx);
	      return RESULT_SUCCESS;
	    }
	}
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-count
  (string-count string ch/pred [start end]) => integer
  Return a count of the number of characters in @var{string} that satisfy
  the @var{ch/pred} argument.  If this argument is a procedure, it is
  applied to all characters as a predicate; if it is a character, it is
  used in a equality test.  @var{start} is the start index and defaults to
  zero, @var{end} is the end index and defatuls to the length of
  @var{string} - 1.  
  doc:*/
#define FUNC_NAME "string-count"
static result_t
string_count (zzz_scm_t env, zzz_scm_t str, zzz_scm_t ch,
	      zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart, cend, idx;
  int chr;
  int count = 0;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (ch) || procedure_p (ch), 
	      _("character or predicate"));
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  if (char_p (ch))
    {
      chr = char_val (ch);
      for (idx = cstart; idx < cend; idx++)
	{
	  if (string_val(str)[idx] == chr)
	    count++;
	}
    }
  else
    {
      for (idx = cstart; idx < cend; idx++)
	{
	  if ((err = zzz_apply
	       (env, ch,
		zzz_cons (zzz_make_char (string_val(str)[idx]), NULL),
		result)) != RESULT_SUCCESS)
	    return err;
	  if (!zzz_eq (*result, zzz_false_value))
	    count++;
	}
    }
  *result = zzz_make_integer (count);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-contains
  (string-contains string1 string2 [start1 end1 start2 end2]) => integer|#f
  Return the index in @var{string1} where @var{string2} occurs as a substring,
  or @code{#f}.  The optional @var{start/end} indices restrict the operation
  to the indicated substrings.  The returned index is in the range
  [@var{start1}, @var{end1}).  A successful match must lie entirely in the
  [@var{start1}, @var{end1}) range of @var{string1}.
  Note: The current implementation uses the naivest possible algorithm and
  is slow when @var{string1} is a long string.
  doc:*/
#define FUNC_NAME "string-contains"
static result_t
string_contains (zzz_scm_t env, zzz_scm_t string1, zzz_scm_t string2,
		 zzz_scm_t start1, zzz_scm_t end1,
		 zzz_scm_t start2, zzz_scm_t end2,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * str1, * str2, * limit1, * limit2;
  result_t err;

  CHECK_TYPE (1, string_p (string1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (string2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, string1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, string2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  if (cend2 - cstart2 == 0)
    {
      *result = zzz_make_integer (cstart1);
      return RESULT_SUCCESS;
    }
  else if (cend2 - cstart2 > cend1 - cstart1)
    {
      *result = zzz_false_value;
      return RESULT_SUCCESS;
    }
  str1 = string_val (string1) + cstart1;
  str2 = string_val (string2) + cstart2;
  limit1 = string_val (string1) + cend1;
  limit2 = string_val (string2) + cend2;
/*    limit1 -= cend2 - cstart2 - 2; */
  while (str1 < limit1)
    {
	char * p1 = str1;
	char * p2 = str2;
	while (p1 < limit1 && p2 < limit2 && *p2 == *p1)
	    {
		p1++;
		p2++;
	    }
	if (p2 == limit2)
	    {
		*result = zzz_make_integer (str1 - string_val (string1));
		return RESULT_SUCCESS;
	    }
	str1++;
    }
	  
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-contains-ci
  (string-contains-ci string1 string2 [start1 end1 start2 end2]) => integer|#f
  Return the index in @var{string1} where @var{string2} occurs as a substring,
  or @code{#f}.  The optional @var{start/end} indices restrict the operation
  to the indicated substrings.  The returned index is in the range
  [@var{start1}, @var{end1}).  A successful match must lie entirely in the
  [@var{start1}, @var{end1}) range of @var{string1}.  Case is ignored when
  comparing individual characters.
  Note: The current implementation uses the naivest possible algorithm and
  is slow when @var{string1} is a long string.
  doc:*/
#define FUNC_NAME "string-contains-ci"
static result_t
string_contains_ci (zzz_scm_t env, zzz_scm_t string1, zzz_scm_t string2,
		    zzz_scm_t start1, zzz_scm_t end1,
		    zzz_scm_t start2, zzz_scm_t end2,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cstart1, cend1, cstart2, cend2;
  char * str1, * str2, * limit1, * limit2;
  result_t err;

  CHECK_TYPE (1, string_p (string1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (string2), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 3, string1, start1, end1, &cstart1, &cend1, result)) !=
      RESULT_SUCCESS)
    return err;
  if ((err = zzz_parse_string_indices
       (s_func_name, 5, string2, start2, end2, &cstart2, &cend2, result)) !=
      RESULT_SUCCESS)
    return err;
  if (cend2 - cstart2 == 0)
    {
      *result = zzz_make_integer (cstart1);
      return RESULT_SUCCESS;
    }
  else if (cend2 - cstart2 > cend1 - cstart1)
    {
      *result = zzz_false_value;
      return RESULT_SUCCESS;
    }
  str1 = string_val (string1) + cstart1;
  str2 = string_val (string2) + cstart2;
  limit1 = string_val (string1) + cend1;
  limit2 = string_val (string2) + cend2;
/*    limit1 -= cend2 - cstart2 - 2; */
  while (str1 < limit1)
    {
	char * p1 = str1;
	char * p2 = str2;
	while (p1 < limit1 && p2 < limit2 && toupper (*p2) == toupper (*p1))
	    {
		p1++;
		p2++;
	    }
	if (p2 == limit2)
	    {
		*result = zzz_make_integer (str1 - string_val (string1));
		return RESULT_SUCCESS;
	    }
	str1++;
    }
	  
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  reverse-list->string
  (reverse-list->string char-list) => string
  An efficient implementation of (compose string->list reverse):
  (reverse-list->string '(#\a #\B #\c)) => "cBa"
  doc:*/
#define FUNC_NAME "reverse-list->string"
static result_t
reverse_list_to_string (zzz_scm_t env, zzz_scm_t char_list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;
  int len;

  len = zzz_list_length (char_list);
  CHECK_TYPE (1, len >= 0, _("list of characters"));
  res = zzz_make_nstring (len);
  while (cons_p (char_list))
    {
      CHECK_TYPE (1, char_p (car (char_list)), _("list of characters"));
      len--;
      string_val (res)[len] = char_val (car (char_list));
      char_list = cdr (char_list);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-reverse!
  (string-reverse! s [start end]) => *unspecified*
  Reverse the string @var{s}.
  doc:*/
#define FUNC_NAME "string-reverse!"
static result_t
string_reverse_x (zzz_scm_t env, zzz_scm_t s, zzz_scm_t start,
		  zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;
  int i, j;
  
  CHECK_TYPE (1, string_p (s) && !ro_string_p (s),
	      zzz_mutable_string_type_name);
  if ((err = zzz_parse_string_indices (s_func_name, 1, s, start, end,
				       &i, &j, result)) != RESULT_SUCCESS)
    return err;
  j--;
  while (i < j)
    {
      int c = string_val (s)[i];
      string_val (s)[i] = string_val (s)[j];
      string_val (s)[j] = c;
      i++, j--;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-reverse
  (string-reverse s [start end]) => string
  Return a reverse version of the string @var{s}.
  doc:*/
#define FUNC_NAME "string-reverse"
static result_t
string_reverse (zzz_scm_t env, zzz_scm_t s, zzz_scm_t start,
		zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;
  zzz_scm_t res;
  
  CHECK_TYPE (1, string_p (s), zzz_string_type_name);
  res = zzz_make_string (string_val (s), string_len (s));
  if ((err = string_reverse_x (env, res, start, end, result)) !=
      RESULT_SUCCESS)
    return err;
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#if 0
/*: doc

  doc:*/
#define FUNC_NAME ""
static result_t
 (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t list,
		     zzz_scm_t pred, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#endif

result_t
zzz_init_srfi_13 (void)
{
  zzz_define_function ("string-null?", (zzz_prim_t) string_null_p_func,
		       argv_1_0_0);
  zzz_define_function ("string-upcase!", (zzz_prim_t) string_upcase_x,
		       argv_1_2_0);
  zzz_define_function ("string-upcase", (zzz_prim_t) string_upcase,
		       argv_1_2_0);
  zzz_define_function ("string-downcase!", (zzz_prim_t) string_downcase_x,
		       argv_1_2_0);
  zzz_define_function ("string-downcase", (zzz_prim_t) string_downcase,
		       argv_1_2_0);
  zzz_define_function ("string-titlecase!", (zzz_prim_t) string_titlecase_x,
		       argv_1_2_0);
  zzz_define_function ("string-titlecase", (zzz_prim_t) string_titlecase,
		       argv_1_2_0);
  zzz_define_function ("string-trim", (zzz_prim_t) string_trim, argv_1_3_0);
  zzz_define_function ("string-trim-right", (zzz_prim_t) string_trim_right,
		       argv_1_3_0);
  zzz_define_function ("string-trim-both", (zzz_prim_t) string_trim_both,
		       argv_1_3_0);
  zzz_define_function ("string-every", (zzz_prim_t) string_every, argv_2_2_0);
  zzz_define_function ("string-any", (zzz_prim_t) string_any, argv_2_2_0);
  zzz_define_function ("string-tabulate", (zzz_prim_t) string_tabulate,
		       argv_2_0_0);
  zzz_define_function ("string-join", (zzz_prim_t) string_join,
		       argv_1_2_0);

  zzz_protect_global (&infix_sym);
  zzz_protect_global (&strict_infix_sym);
  zzz_protect_global (&prefix_sym);
  zzz_protect_global (&suffix_sym);

  infix_sym = zzz_make_symbol ("infix", -1);
  strict_infix_sym = zzz_make_symbol ("strict-infix", -1);
  prefix_sym = zzz_make_symbol ("prefix", -1);
  suffix_sym = zzz_make_symbol ("suffix", -1);

  zzz_define_function ("string-prefix-length",
		       (zzz_prim_t) string_prefix_length, argv_2_4_0);
  zzz_define_function ("string-prefix-length-ci",
		       (zzz_prim_t) string_prefix_length_ci, argv_2_4_0);
  zzz_define_function ("string-suffix-length",
		       (zzz_prim_t) string_suffix_length, argv_2_4_0);
  zzz_define_function ("string-suffix-length-ci",
		       (zzz_prim_t) string_suffix_length_ci, argv_2_4_0);
  zzz_define_function ("string-prefix?",
		       (zzz_prim_t) string_prefix_p, argv_2_4_0);
  zzz_define_function ("string-prefix-ci?",
		       (zzz_prim_t) string_prefix_ci_p, argv_2_4_0);
  zzz_define_function ("string-suffix?",
		       (zzz_prim_t) string_suffix_p, argv_2_4_0);
  zzz_define_function ("string-suffix-ci?",
		       (zzz_prim_t) string_suffix_ci_p, argv_2_4_0);
  zzz_define_function ("string-pad", (zzz_prim_t) string_pad, argv_2_3_0);
  zzz_define_function ("string-pad-right",
		       (zzz_prim_t) string_pad_right, argv_2_3_0);
  zzz_define_function ("string-take", (zzz_prim_t) string_take, argv_2_0_0);
  zzz_define_function ("string-take-right", (zzz_prim_t) string_take_right,
		       argv_2_0_0);
  zzz_define_function ("string-drop", (zzz_prim_t) string_drop, argv_2_0_0);
  zzz_define_function ("string-drop-right", (zzz_prim_t) string_drop_right,
		       argv_2_0_0);
  zzz_define_function ("string-hash", (zzz_prim_t) string_hash, argv_2_2_0);
  zzz_define_function ("string-hash-ci", (zzz_prim_t) string_hash_ci,
		       argv_2_2_0);
  zzz_define_function ("string-index", (zzz_prim_t) string_index_func,
		       argv_2_2_0);
  zzz_define_function ("string-index-right",
		       (zzz_prim_t) string_index_right_func,
		       argv_2_2_0);
  zzz_define_function ("string-skip", (zzz_prim_t) string_skip, argv_2_2_0);
  zzz_define_function ("string-skip-right", (zzz_prim_t) string_skip_right,
		       argv_2_2_0);
  zzz_define_function ("string-count", (zzz_prim_t) string_count, argv_2_2_0);
  zzz_define_function ("string-contains", (zzz_prim_t) string_contains,
		       argv_2_4_0);
  zzz_define_function ("string-contains-ci", (zzz_prim_t) string_contains_ci,
		       argv_2_4_0);
  zzz_define_function ("reverse-list->string",
		       (zzz_prim_t) reverse_list_to_string, argv_1_0_0);
  zzz_define_function ("string-reverse!",
		       (zzz_prim_t) string_reverse_x, argv_1_2_0);
  zzz_define_function ("string-reverse",
		       (zzz_prim_t) string_reverse, argv_1_2_0);
#if 0
  zzz_define_function ("", (zzz_prim_t) , argv_);
#endif

  return RESULT_SUCCESS;
}
