/* libsizzle/stringfun.c - string functions
 
  Copyright (C) 1999, 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 

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

#ifdef _AIX
# undef _NO_PROTO
# ifndef _USE_IRS
#  define _USE_IRS 1
# endif
# define _XOPEN_SOURCE_EXTENDED 1
# define _ALL_SOURCE 1
#if HAVE_STRINGS_H
# include <strings.h>
#endif
#endif

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

#include "alloc.h"
#include "node.h"
#include "validate.h"
#include "capi.h"
#include "stringfun.h"
#include "list.h"
#include "port.h"
#include "srfi-13.h"

/* Do the dirty work for extracting start and end indices from
   optional arguments.  @var{s_func_name} is the name of the calling
   function and is used in error messages, @var{arg_index} is the
   number of the start index in the source parameter list and is used
   for error messages, too.  @var{string} is the string for which the
   indices should be value, @var{start} is the start and @var{end} is
   the end index, both may be undefined; then they will default to 0
   and the length of @var{string}, respectively.  The extracted start
   and end indices will be stored in the locations pointed to by
   @var{cstart} and @var{cend}.  The location pointed to by
   @var{result} will take an exception object, if
   @code{RESULT_EXCEPTION} is returned.  */
result_t
zzz_parse_string_indices (char * s_func_name, int arg_index,
			  zzz_scm_t string, zzz_scm_t start, zzz_scm_t end,
			  int * cstart, int * cend, zzz_scm_t * result)
{
  if (start != zzz_undefined)
    {
      CHECK_TYPE (arg_index, integer_p (start), zzz_integer_type_name);
      *cstart = integer_val (start);
      CHECK_RANGE (arg_index, *cstart >= 0 &&
		   *cstart <= (int) string_len (string),
		   _("valid string start index"));
    }
  else
    *cstart = 0;
  if (end != zzz_undefined)
    {
      CHECK_TYPE (arg_index + 1, integer_p (end), zzz_integer_type_name);
      *cend = integer_val (end);
      CHECK_RANGE (arg_index + 1, *cend >= *cstart &&
		   *cend <= (int) string_len (string),
		   _("valid string end index"));
    }
  else
    *cend = string_len (string);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}

/*:doc
  string?
  (string? obj) => boolean
  Return @code{#t} if @var{obj} is a string, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string?"
static result_t
string_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (string_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-string
  (make-string k [char]) => string
  Return a newly allocated string of length @var{k}. @var{char} is used to
  initialize the string, if omitted, the contents of the string is
  unspecified.
  doc:*/
#define FUNC_NAME "make-string"
static result_t
make_string_func (zzz_scm_t env, zzz_scm_t k, zzz_scm_t fill,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  int len, fill_char;
  char * p;

  CHECK_TYPE (1, integer_p (k), zzz_integer_type_name);
  if (fill == zzz_undefined)
    fill_char = ' ';
  else
    {
      CHECK_TYPE (2, char_p (fill), zzz_character_type_name);
      fill_char = char_val (fill);
    }
  len = integer_val (k);
  if (len < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("length must be greater or equal than zero in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  res = zzz_make_nstring (len);
  p = string_val (res);
  while (len-- > 0)
    *p++ = fill_char;
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string
  (string char ...) => string
  Return a newly allocated string composed of its arguments, which all
  must be characters.
  doc:*/
#define FUNC_NAME "string"
static result_t
string_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t temp;
  zzz_scm_t res = NULL;
  int len;
  char * p;

  len = 0;
  temp = param;
  while (cons_p (temp))
    {
      len++;
      CHECK_TYPE (len, char_p (car (temp)), zzz_character_type_name);
      temp = cdr (temp);
    }
  res = zzz_make_nstring (len);
  p = string_val (res);
  len = 0;
  temp = param;
  while (cons_p (temp))
    {
      len++;
      *p++ = char_val (car (temp));
      temp = cdr (temp);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-length
  (string-length string) => integer
  Return the number of characters in @var{string}.
  doc:*/
#define FUNC_NAME "string-length"
static result_t
string_length_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  *result = zzz_make_integer (string_len (string));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-ref
  (string-ref string k) => character
  Return the @var{k}th character of @var{string}. The index is
  zero-based. @var{k} must be a valid index into @var{string}, or an error
  will be signalled.
  doc:*/
#define FUNC_NAME "string-ref"
static result_t
string_ref_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t k,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int index;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  index = integer_val (k);
  if (index < 0 || index >= (int) string_len (string))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("index out of range in call to "), -1),
	  zzz_make_string (s_func_name, -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_char (string_val (string)[index]);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-set!
  (string k char) => *unspecified*
  Store @var{char} in element @var{k} of @var{string}. An error will be
  signalled if @var{k} is not a valid index into @var{string}.
  doc:*/
#define FUNC_NAME "string-set!"
static result_t
string_set_x_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t k,
		   zzz_scm_t ch, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int index;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  CHECK_TYPE (3, char_p (ch), zzz_character_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;
    }
  index = integer_val (k);
  if (index < 0 || index >= (int) string_len (string))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("index out of range in call to "), -1),
	  zzz_make_string (s_func_name, -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  string_val (string)[index] = char_val (ch);
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string=?
  (string=? string1 string2) => 
  Return @code{#t} if @var{string1} is the same string as @var{string2},
  @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string=?"
static result_t
string_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) != string_len (str2))
    *result = zzz_false_value;
  else
    {
      cmp = strncmp (string_val (str1), string_val (str2), string_len (str1));
      if (cmp == 0)
	*result = zzz_true_value;
      else
	*result = zzz_false_value;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string<?
  (string<? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically less than
  @var{string2}, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string<?"
static result_t
string_less_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = strncmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) < string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp < 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string<=?
  (string<=? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically less or equal to
  @var{string2}, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string<=?"
static result_t
string_less_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
			zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = strncmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) <= string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp <= 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string>?
  (string>? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically greater than
  @var{string2}, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string>?"
static result_t
string_greater_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
		     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = strncmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) > string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp > 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string>=?
  (string>=? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically greater or equal
  to @var{string2}, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "string>=?"
static result_t
string_greater_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
			   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = strncmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) >= string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp >= 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*
 * That function is a wrapper for strncasecmp.
 */
int
string_strncasecmp (const char *str1, const char *str2, size_t n)
{
#if defined HAVE_STRNCASECMP
  return strncasecmp (str1, str2, n);
#elif defined HAVE_STRNICMP
  return strnicmp (str1, str2, n);
#else
  const char *p1 = str1;
  const char *p2 = str2;
  unsigned char c1, c2;

  if (p1 == p2) return 0;

  do
    {
      c1 = isupper (*p1) ? tolower (*p1) : *p1;
      c2 = isupper (*p2) ? tolower (*p2) : *p2;
      if (c1 == '\0') break;
      ++p1;
      ++p2;
    }
  while (c1 == c2 && --n > 0);

  return c1 - c2;
#endif
}

/*:doc
  string-ci=?
  (string-ci=? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is the same string as @var{string2},
  @code{#f} otherwise. This function ignores case when comparing.
  doc:*/
#define FUNC_NAME "string-ci=?"
static result_t
string_ci_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
		      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) != string_len (str2))
    *result = zzz_false_value;
  else
    {
      cmp = string_strncasecmp (string_val (str1), string_val (str2),
				string_len (str1));
      if (cmp == 0)
	*result = zzz_true_value;
      else
	*result = zzz_false_value;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-ci<?
  (string-ci<? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically less than
  @var{string2}, @code{#f} otherwise. This function ignores case when
  comparing.
  doc:*/
#define FUNC_NAME "string-ci<?"
static result_t
string_ci_less_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
		     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = string_strncasecmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) < string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp < 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-ci<=?
  (string-ci<=? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically less or equal to
  @var{string2}, @code{#f} otherwise. This function ignores case when
  comparing.
  doc:*/
#define FUNC_NAME "string-ci<=?"
static result_t
string_ci_less_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
			   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = string_strncasecmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) <= string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp <= 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-ci>?
  (string-ci>? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically greater than
  @var{string2}, @code{#f} otherwise. This function ignores case when
  comparing.
  doc:*/
#define FUNC_NAME "string-ci>?"
static result_t
string_ci_greater_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
			zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = string_strncasecmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) > string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp > 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-ci>=?
  (string-ci>=? string1 string2) => boolean
  Returns @code{#t} if @var{string1} is lexicographically greater or equal
  to @var{string2}, @code{#f} otherwise. This function ignores case when
  comparing.
  doc:*/
#define FUNC_NAME "string-ci>=?"
static result_t
string_ci_greater_equal_func (zzz_scm_t env, zzz_scm_t str1, zzz_scm_t str2,
			      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int len;
  int cmp;

  CHECK_TYPE (1, string_p (str1), zzz_string_type_name);
  CHECK_TYPE (2, string_p (str2), zzz_string_type_name);
  if (string_len (str1) < string_len (str2))
    len = string_len (str1);
  else
    len = string_len (str2);
  cmp = string_strncasecmp (string_val (str1), string_val (str2), len);
  if (cmp == 0)
    *result = string_len (str1) >= string_len (str2) ? zzz_true_value :
    zzz_false_value;
  else
    *result = cmp >= 0 ? zzz_true_value : zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  substring
  (substring string start end) => string
  Return a string formed from the characters of @var{string} starting at
  @var{start} (inclusive) and ending with @var{end} (exclusive).  An error
  is signalled if the following equation is not satisfied: 0 <=
  @var{start} <= @var{end} <= @code{(string-length} @var{string}@code{)}
  doc:*/
#define FUNC_NAME "substring"
static result_t
substring_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t start,
		zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  int s, e;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (start), zzz_integer_type_name);
  CHECK_TYPE (3, integer_p (end), zzz_integer_type_name);
  s = integer_val (start);
  e = integer_val (end);
  if (s < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("start must be non-negative in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if (e < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("end must be non-negative in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if (s > (int) string_len (str))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("start index greater than string length in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if (e > (int) string_len (str))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("end index greater than string length in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  if (s > e)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string
	  (_("end index greater than start index in call to `"), -1),
	  zzz_make_string (s_func_name, -1),
	  zzz_make_string("'", -1),
	  NULL));
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_string (string_val (str) + s, e - s);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-append
  (string-append string ...) => string
  Return a string made out of the concatenation of all string arguments.
  An empty string is returned if called without arguments.
  doc:*/
#define FUNC_NAME "string-append"
static result_t
string_append_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t exp = NULL, res = NULL;
  char * buf = NULL;
  int buf_len = 16;
  char * buf_end;

  if (!cons_p (param))
    {
      *result = zzz_make_string ("", 0);
      return RESULT_SUCCESS;
    }
  buf = zzz_malloc (buf_len);
  buf_end = buf;
  do
    {
      if (!cons_p (param))
	{
	  zzz_free (buf, buf_len);
	  *result = zzz_make_wna_exception
	    (zzz_make_list
	     (zzz_make_string (_("too few arguments in call to "), -1),
	      zzz_make_string (s_func_name, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      exp = car (param);
      param = cdr (param);
      if (!string_p (exp))
	{
	  zzz_free (buf, buf_len);
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("arguments to "), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string (_(" must be strings"), -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (string_len (exp) > 0)
	{
	  while ((buf_end - buf) + ((int) string_len (exp)) >= buf_len)
	    {
	      int diff = buf_end - buf;
	      buf = zzz_realloc (buf, buf_len * 2, buf_len);
	      buf_len *= 2;
	      buf_end = buf + diff;
	    }
	  memmove (buf_end, string_val (exp), string_len (exp));
	  buf_end += string_len (exp);
	}
    }
  while (!null_p (param));
  res = zzz_make_string (buf, buf_end - buf);
  zzz_free (buf, buf_len);
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string->list
  (string->list string [start end]) => string
  Convert the string @var{string} to a list of all characters of
  @var{string}.
  @var{start} and @var{end} delimit the region of operation and default to
  0 and the length of @var{string}.
  doc:*/
#define FUNC_NAME "string->list"
static result_t
string_to_list_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t start,
		     zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t list = NULL;
  int cstart, cend;
  char * p, * endp;
  result_t err;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  if ((err = zzz_parse_string_indices
       (s_func_name, 2, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  p = string_val (str) + cstart;
  endp = string_val (str) + cend;
  while (endp > p)
    {
      endp--;
      list = zzz_cons (zzz_make_char (*endp), list);
    }
  *result = list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list->string
  (list->string list) => string
  Convert the list @var{list}, which must be made up from character
  values, to a string.
  doc:*/
#define FUNC_NAME "list->string"
static result_t
list_to_string_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t str = NULL, temp = NULL;
  int len = 0;
  char * buf;

  CHECK_TYPE (1, zzz_list_length (list) >= 0, zzz_proper_list_type_name);
  temp = list;
  while (cons_p (temp))
    {
      if (!char_p (car (temp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("character list expected in call to "), -1),
	      zzz_make_string (s_func_name, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      len++;
      temp = cdr (temp);
    }
  buf = zzz_malloc (len);
  len = 0;
  temp = list;
  while (cons_p (temp))
    {
      buf[len] = char_val (car (temp));
      len++;
      temp = cdr (temp);
    }
  str = zzz_make_string (buf, len);
  zzz_free (buf, len);
  *result = str;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-copy
  (string-copy string [start end]) => string
  Returns a newly allocated string with the same contents as @var{string}.
  @var{start} and @var{end} delimit the string to be copied, they default to
  0 and the length of @var{string}.
  doc:*/
#define FUNC_NAME "string-copy"
static result_t
string_copy_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t start,
		  zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  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, 2, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  *result = zzz_make_string (string_val (str) + cstart, cend - cstart);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-fill!
  (string-fill! string char [start end]) => 
  Stores the character @var{char} in all elements of @var{string}. The
  return value is not specified.
  @var{start} and @var{end} delimit the region which is filled and default
  to 0 and the length of @var{string}.
  doc:*/
#define FUNC_NAME "string-fill!"
static result_t
string_fill_x_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t fill,
		    zzz_scm_t start, zzz_scm_t end, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  int fill_char;
  int cstart, cend;
  result_t err;
  char * p, * pend;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_TYPE (2, char_p (fill), zzz_character_type_name);
  if (ro_string_p (str))
    {
      *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, 3, str, start, end, &cstart, &cend, result)) !=
      RESULT_SUCCESS)
    return err;
  fill_char = char_val (fill);
  p = string_val (str) + cstart;
  pend = string_val (str) + cend;
  while (p < pend)
    *p++ = fill_char;
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-split
  (string-split ch string) => list
  Splits the string @var{string} into pieces, using @var{ch} as the
  delimiting character. Returns a list of strings, where the stings may be
  empty if two or more delimiting characters are in @var{string} without
  characters inbetween.
  doc:*/
#define FUNC_NAME "string-split"
static result_t
string_split_func (zzz_scm_t env, zzz_scm_t ch, zzz_scm_t string,
		   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  char * p, * endp, * lastp;
  int c;

  CHECK_TYPE (1, char_p (ch), zzz_character_type_name);
  CHECK_TYPE (2, string_p (string), zzz_string_type_name);
  c = char_val (ch);
  p = string_val (string);
  endp = string_val (string) + string_len (string);
  lastp = p;
  while (p < endp)
    {
      if (*p == c)
	{
	  *resp = zzz_cons (zzz_make_string (lastp, p - lastp), NULL);
	  resp = cdr_addr (*resp);
	  p++;
	  lastp = p;
	}
      else
	p++;
    }
  if (lastp <= endp)
    {
      *resp = zzz_cons (zzz_make_string (lastp, endp - lastp), NULL);
      resp = cdr_addr (*resp);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  basename
  (basename name [suffix]) => string
  Removes any leading directory components from @var{name}; if
  @var{suffix} is specified and is identical to the end of name, it is
  removed from @var{name} as well.
  doc:*/
#define FUNC_NAME "basename"
static result_t
basename_func (zzz_scm_t env, zzz_scm_t name, zzz_scm_t suffix,
	       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * endp, * startp;

  CHECK_TYPE (1, string_p (name), zzz_string_type_name);
  CHECK_TYPE (2, (suffix == zzz_undefined) || string_p (suffix),
	      zzz_string_type_name);
  endp = string_val (name) + string_len (name);
  startp = endp;
  /* FIXME: This is Unix-specific.  Maybe generalize.  */
  while (startp > string_val (name) && startp[-1] != '/')
    startp--;
  if (suffix != zzz_undefined && string_len (suffix) > 0)
    {
      if (endp - string_len (suffix) > startp &&
	  !memcmp (string_val (suffix), endp - string_len (suffix),
		   string_len (suffix)))
	endp -= string_len (suffix);
    }
  *result = zzz_make_string (startp, endp - startp);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  dirname
  (dirname filename) => string
  Returns a string of all but the final slash-delimited component of
  @var{filename}.  If @var{filename} is a single component, @code{dirname}
  returns @code{.} (meaning the current directory).
  doc:*/
#define FUNC_NAME "dirname"
static result_t
dirname_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * slashp;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  slashp = string_val (filename) + string_len (filename);
  /* FIXME: This is Unix-specific.  Maybe generalize.  */
  while (slashp > string_val (filename) && *slashp == '/')
    slashp--;
  while (slashp > string_val (filename) && *slashp != '/')
    slashp--;
  if (slashp == string_val (filename))
    {
      if (*slashp != '/')
	*result = zzz_make_string (".", 1);
      else
	*result = zzz_make_string ("/", 1);
    }
  else
    *result = zzz_make_string (string_val (filename),
			       slashp - string_val (filename));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static void
cleanup_path (char * path)
{
  char *p = path;
  char *endp;
  char *dst, *src;

  endp = path;
  while (*endp)
    endp++;

  while (*p)
    {
      if (p[0] == '.' && (p[1] == '/'/* || p[1] == '\0'*/))
	{
	  if (p[1] == '\0')
	    {
	      p[0] = '\0';
	      break;
	    }
	  dst = p;
	  src = p + 2;
	  while (src <= endp)
	    *dst++ = *src++;
	}
      else if (p[0] == '.' && p[1] == '.' && (p[2] == '/' || p[2] == '\0'))
	{
	  src = p + 3;
	  if (p > path)
	    {
	      p--;
	      while (p > path && p[-1] != '/')
		p--;
	    }
	  if (src[-1] == '\0')
	    {
	      p[0] = '\0';
	      break;
	    }
	  dst = p;
	  while (src <= endp)
	    *dst++ = *src++;
	}
      else if (p[0] == '/' && p[1] == '/')
	{
	  if (p[1] == '\0')
	    {
	      p[0] = '\0';
	      break;
	    }
	  dst = p;
	  src = p + 1;
	  while (src <= endp)
	    *dst++ = *src++;
	}
      else
	p++;
    }
  /* kill tailing slashes but don't kill `/' */
  if (p > path + 1 && p[-1] == '/')
    p[-1] = '\0';
}

/*:doc
  cleanup-filename
  (cleanup-filename filename) => string
  Clean the given @var{filename} up and convert it to a canonical form by
  removing all appearences of parent directory references
  (@code{/foo/..}), current directory marks (@code{./}), multiple slashes
  (@code{//}) and trailing slashes. The root directory indicator @code{/}
  is not deleted, though it is a trailing slash.
  doc:*/
#define FUNC_NAME "cleanup-fileanme"
static result_t
cleanup_filename_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * res;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  res = zzz_malloc (string_len (filename) + 1);
  memmove (res, string_val (filename), string_len (filename) + 1);
  cleanup_path (res);
  *result = zzz_make_string (res, -1);
  zzz_free (res, string_len (filename) + 1);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  string-chop
  (string-chop s) => string
  Return a newly allocated string with the contents of @var{s}, but with all
  trailing newline characters removed.
  doc:*/
#define FUNC_NAME "string-chop"
static result_t
string_chop (zzz_scm_t env, zzz_scm_t string, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * p, *endp;

  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  p = string_val (string);
  endp = string_val (string) + string_len (string);
  while (p < endp && endp[-1] == '\n')
    endp--;
  *result = zzz_make_string (string_val (string), endp - p);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

result_t
zzz_init_stringfun (void)
{
  zzz_define_function ("string?", (zzz_prim_t) string_p_func, argv_1_0_0);
  zzz_define_function ("make-string", (zzz_prim_t) make_string_func,
		       argv_1_1_0);
  zzz_define_function ("string", (zzz_prim_t) string_func, argv_0_0_1);
  zzz_define_function ("string-length", (zzz_prim_t) string_length_func,
		       argv_1_0_0);
  zzz_define_function ("string-ref", (zzz_prim_t) string_ref_func, argv_2_0_0);
  zzz_define_function ("string-set!", (zzz_prim_t) string_set_x_func,
		       argv_3_0_0);
  zzz_define_function ("string=?", (zzz_prim_t) string_equal_func, argv_2_0_0);
  zzz_define_function ("string<?", (zzz_prim_t) string_less_func, argv_2_0_0);
  zzz_define_function ("string<=?", (zzz_prim_t) string_less_equal_func,
		       argv_2_0_0);
  zzz_define_function ("string>?", (zzz_prim_t) string_greater_func,
		       argv_2_0_0);
  zzz_define_function ("string>=?", (zzz_prim_t) string_greater_equal_func,
		       argv_2_0_0);
  zzz_define_function ("string-ci=?", (zzz_prim_t) string_ci_equal_func,
		       argv_2_0_0);
  zzz_define_function ("string-ci<?", (zzz_prim_t) string_ci_less_func,
		       argv_2_0_0);
  zzz_define_function ("string-ci<=?", (zzz_prim_t) string_ci_less_equal_func,
		       argv_2_0_0);
  zzz_define_function ("string-ci>?", (zzz_prim_t) string_ci_greater_func,
		       argv_2_0_0);
  zzz_define_function ("string-ci>=?",
		       (zzz_prim_t) string_ci_greater_equal_func, argv_2_0_0);
  zzz_define_function ("substring", (zzz_prim_t) substring_func, argv_3_0_0);
  zzz_define_function ("string-append", (zzz_prim_t) string_append_func,
		       argv_0_0_1);
  zzz_define_function ("string->list", (zzz_prim_t) string_to_list_func,
		       argv_1_2_0);
  zzz_define_function ("list->string", (zzz_prim_t) list_to_string_func,
		       argv_1_0_0);
  zzz_define_function ("string-copy", (zzz_prim_t) string_copy_func,
		       argv_1_2_0);
  zzz_define_function ("string-fill!", (zzz_prim_t) string_fill_x_func,
		       argv_2_2_0);

  zzz_define_function ("string-split", (zzz_prim_t) string_split_func,
		       argv_2_0_0);
  zzz_define_function ("basename", (zzz_prim_t) basename_func, argv_1_1_0);
  zzz_define_function ("dirname", (zzz_prim_t) dirname_func, argv_1_0_0);
  zzz_define_function ("cleanup-filename",
		       (zzz_prim_t) cleanup_filename_func, argv_1_0_0);
  zzz_define_function ("string-chop", (zzz_prim_t) string_chop, argv_1_0_0);

  /* Register all primitives from SRFI-13.  */
  zzz_init_srfi_13 ();
  return RESULT_SUCCESS;
}
