/* libsizzle/srfi-1.c - list operations from SRFI-1
 
  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 

#include <stdlib.h>

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

#include "node.h"
#include "validate.h"
#include "vector.h"
#include "capi.h"
#include "values.h"
#include "port.h"
#include "list.h"
#include "modules.h"

/* Module for holding the list-lib procedures.  */
static zzz_scm_t core_list_lib_module;

/*:doc
  length+
  (length+ list) => integer | #f
  Return the length of @var{list}.  If @var{list} is a circular, @code{#f}
  is returned.
  doc:*/
#define FUNC_NAME "length+"
static result_t
length_plus (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tortoise, hare;
  int length = 0;

  tortoise = list;
  hare = list;
  do
    {
      if (!cons_p (hare)) 
	{
	  *result = zzz_make_integer (length);
	  return RESULT_SUCCESS;
	}
      hare = cdr (hare);
      length++;
      if (!cons_p (hare)) 
	{
	  *result = zzz_make_integer (length);
	  return RESULT_SUCCESS;
	}
      hare = cdr (hare);
      length++;
      /* For every two steps the hare takes, the tortoise takes one.  */
      tortoise = cdr (tortoise);
    }
  while (!zzz_eq (hare, tortoise));
  /* If the tortoise ever catches the hare, then the list must contain
     a cycle.  */
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  take
  (take list k) => list
  Return a list containing the first @var{k} elements of
  @var{list}. Return @var{list} if @var{k} is larger then the length
  of @var{list}.
  doc:*/
#define FUNC_NAME "take"
static result_t
take_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  while (cons_p (list) && value-- > 0)
    {
      *resp = zzz_cons (car (list), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  take!
  (take! list k) => list
  Return a list containing the first @var{k} elements of
  @var{list}. Return @var{list} if @var{k} is larger then the length
  of @var{list}.  The parameter list @var{list} may be modified as a 
  side effect.
  doc:*/
#define FUNC_NAME "take!"
static result_t
take_x (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t temp;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  if (value <= 0)
    *result = NULL;
  else
    {
      value--;
      temp = list;
      while (cons_p (temp) && value-- > 0)
	temp = cdr (temp);
      if (cons_p (temp))
	set_cdr (temp, NULL);
      *result = list;
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  take-right
  (take-right list k) => list
  Return a list containing the last @var{k} elements of @var{list}.  Return
  @var{list} if @var{k} is greater than or equal to the length of the list,
  return the empty list if @var{k} is <= 0.
  doc:*/
#define FUNC_NAME "take-right"
static result_t
take_right (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t temp;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  temp = list;
  while (cons_p (temp) && value-- > 0)
    temp = cdr (temp);
  while (cons_p (temp))
    {
      temp = cdr (temp);
      list = cdr (list);
    }
  *result = list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  drop
  (drop list k) => list
  Return a list containing the elements of @var{list}, but without the
  first @var{k} elements. Return @var{list} if @var{k} is less or equal to
  zero, returns the empty list if @var{k} is larger than the length of
  @var{list}.
  doc:*/
#define FUNC_NAME "drop"
static result_t
drop_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  while (cons_p (list) && value-- > 0)
    list = cdr (list);
  *result = list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  drop-right
  (drop-right list k) => list
  Return a list containing the elements of @var{list}, but without the last
  @var{k} elements.  Return @var{list} if @var{k} is <= 0, and return the
  empty list if @var{k} is greater than the length of the list.
  doc:*/
#define FUNC_NAME "drop-right"
static result_t
drop_right (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  zzz_scm_t temp;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  temp = list;
  while (cons_p (temp) && value-- > 0)
    temp = cdr (temp);
  while (cons_p (temp))
    {
      temp = cdr (temp);
      *resp = zzz_cons (car (list), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  drop-right!
  (drop-right! list k) => list
  Return a list containing the elements of @var{list}, but without the last
  @var{k} elements.  Return @var{list} if @var{k} is <= 0, and return the
  empty list if @var{k} is greater than the length of the list.  This procedure
  may modify the parameter @var{list} as a side effect.
  doc:*/
#define FUNC_NAME "drop-right!"
static result_t
drop_right_x (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t temp;
  int value;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  if (value <= 0)
    *result = list;
  else
    {
      temp = list;
      while (cons_p (temp) && value-- > 0)
	temp = cdr (temp);
      if (cons_p (temp))
	{
	  *result = list;
	  temp = cdr (temp);
	  while (cons_p (temp))
	    {
	      temp = cdr (temp);
	      list = cdr (list);
	    }
	  set_cdr (list, NULL);
	}
      else
	*result = NULL;
  }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  split-at
  (split-at list k) => list1 list2
  Split the list @var{list} at index @var{k} and return two values: the list
  of the first @var{k} elements and the list of the remaining elements.
  doc:*/
#define FUNC_NAME "split-at"
static result_t
split_at (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int value;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  while (cons_p (list) && value-- > 0)
    {
      *resp = zzz_cons (car (list), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  *result = zzz_make_values (zzz_make_n_list (2, res, list));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  split-at!
  (split-at! list k) => list1 list2
  Split the list @var{list} at index @var{k} and return two values: the list
  of the first @var{k} elements and the list of the remaining elements.  This
  procedure may modify its @var{list} argument as a side effect.
  doc:*/
#define FUNC_NAME "split-at!"
static result_t
split_at_x (zzz_scm_t env, zzz_scm_t list, zzz_scm_t k, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int value;
  zzz_scm_t temp, tail;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  CHECK_TYPE (2, integer_p (k), zzz_integer_type_name);
  value = integer_val (k);
  if (value <= 0)
    *result = zzz_make_values (zzz_make_n_list (2, NULL, list));
  else
    {
      temp = list;
      value--;
      while (cons_p (temp) && value-- > 0)
	temp = cdr (temp);
      if (cons_p (temp))
	{
	  tail = cdr (temp);
	  set_cdr (temp, NULL);
	  *result = zzz_make_values (zzz_make_n_list (2, list, tail));
	}
      else
	*result = zzz_make_values (zzz_make_n_list (2, list, NULL));
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  xcons
  (xcons d a) => pair
  Equivalent to @code{(cons obj2 obj1)}, and is of utility only as a value
  to be conveniently passed to higher--order procedures. (@code{xcons}
  stands for @i{exchanged cons}.)
  doc:*/
#define FUNC_NAME "xcons"
static result_t
xcons_func (zzz_scm_t env, zzz_scm_t d, zzz_scm_t a, zzz_scm_t * result)
{
  *result = zzz_cons (a, d);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  cons*
  (cons* elt1 elt2 ...) => dotted-list
  Like @code{list}, but the last argument provides the tail of the
  constructed list.
  doc:*/
#define FUNC_NAME "cons*"
static result_t
cons_star_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL, elt;
  zzz_scm_t *resp = &res;

  while (cons_p (list) && cons_p (cdr (list)))
    {
      ZZZ_TICK ();
      elt = car (list);
      list = cdr (list);
      *resp = zzz_cons (elt, NULL);
      resp = cdr_addr (*resp);
    }
  if (cons_p (list))
    *resp = car (list);
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-list
  (make-list n [fill]) => list
  Return an @var{n}-element list, whose elements are all the value
  @var{fill}. If the @var{fill} argument is not given, the elements of the
  list are unspecified.
  doc:*/
#define FUNC_NAME "make-list"
static result_t
make_list_func (zzz_scm_t env, zzz_scm_t n, zzz_scm_t fill, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  int cnt, c = 0;

  CHECK_TYPE (1, integer_p (n) && integer_val (n) >= 0,
	      zzz_non_negative_integer_type_name);
  if (fill == zzz_undefined)
    fill = NULL;
  cnt = integer_val (n);
  /* We lock garbage collection here, because we know that it will not
     gain us anything, we *know* that we will need memory and that we do
     not produce any garbage.  */
  zzz_gc_lock ();
  while (cnt-- > 0)
    {
      c++;
      res = zzz_cons (fill, res);
    }
  *result = res;
  zzz_gc_unlock ();
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list-tabulate
  (list-tabulate len proc) => string
  Returns an @var{n}-element list. Element @var{i} ofthe list, where 0 <=
  @var{i} < @var{n}, is produced by calling @code{(init-proc i)}.  The
  dynamic order in which @code{init-proc} is applied to the indices is not
  specified.
  doc:*/
#define FUNC_NAME "list-tabulate"
static result_t
list_tabulate_func (zzz_scm_t env, zzz_scm_t n, zzz_scm_t init_proc,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t temp;
  int cnt;
  result_t err;

  CHECK_TYPE (1, integer_p (n) && integer_val (n) >= 0,
	      zzz_non_negative_integer_type_name);
  CHECK_TYPE (2, procedure_p (init_proc), zzz_procedure_type_name);
  cnt = integer_val (n);
  while (cnt-- > 0)
    {
      /* No ZZZ_TICK() necessary here, because zzz_apply() will do it.  */
      if ((err = zzz_apply (env, init_proc,
			    zzz_cons (zzz_make_integer (cnt), NULL),
			    &temp) !=
	   RESULT_SUCCESS))
	{
	  *result = temp;
	  return err;
	}
      res = zzz_cons (temp, res);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list-copy
  (list-copy list) => list
  Copies the spine of the argument list.
  doc:*/
#define FUNC_NAME "list-copy"
static result_t
list_copy_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;

  CHECK_TYPE (1, zzz_list_length (list) > -2, zzz_finite_list_type_name);
  while (cons_p (list))
    {
      ZZZ_TICK ();
      *resp = zzz_cons (car (list), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  *resp = list;
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  circular-list
  (circular-list elt1 elt2 ...) => circular-list
  Constructs a circular list of the elements.
  doc:*/
#define FUNC_NAME "circular-list"
static result_t
circular_list_func (zzz_scm_t env, zzz_scm_t first, zzz_scm_t rest,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  zzz_scm_t elt;

  *resp = zzz_cons (first, NULL);
  resp = cdr_addr (*resp);
  while (cons_p (rest))
    {
      ZZZ_TICK ();
      elt = car (rest);
      rest = cdr (rest);
      *resp = zzz_cons (elt, NULL);
      resp = cdr_addr (*resp);
    }
  *resp = res;
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  iota
  (iota count [start step]) =>
  Returns a list containing the elements
  (start start + step ... start + (count - 1) * step)
  The @var{start} and @var{step} parameters default to 0 and 1, 
  respectively. This procedure takes its name from the APL primitive.
  doc:*/
#define FUNC_NAME "iota"
static result_t
iota_func (zzz_scm_t env, zzz_scm_t count, zzz_scm_t start, zzz_scm_t step,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  int start_real = 0, step_real = 0;
  int istart = 0, istep = 1;
  double rstart = 0.0, rstep = 1.0;
  int cnt;

  CHECK_TYPE (1, integer_p (count) && integer_val (count) >= 0,
	      zzz_non_negative_integer_type_name);
  if (start != zzz_undefined)
    {
      if (step == zzz_undefined)
	{
          *result = zzz_make_wna_exception
            (zzz_make_list
	     (zzz_make_string (zzz_too_few_arguments, -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      CHECK_TYPE (2, number_p (start), zzz_number_type_name);
      CHECK_TYPE (3, number_p (step), zzz_number_type_name);
      if (integer_p (start))
	{
	  istart = integer_val (start);
	  start_real = 0;
	}
      else
	{
	  rstart = float_val (start);
	  start_real = 1;
	}
      if (integer_p (step))
	{
	  istep = integer_val (step);
	  step_real = 0;
	}
      else
	{
	  rstep = float_val (step);
	  step_real = 1;
	}
    }
  if (start_real && !step_real)
    {
      step_real = 1;
      rstep = istep;
    }
  if (!start_real && step_real)
    {
      start_real = 1;
      rstart = istart;
    }
  cnt = integer_val (count);
  while (cnt-- > 0)
    {
      ZZZ_TICK ();
      if (start_real)
	{
	  *resp = zzz_cons (zzz_make_float (rstart), NULL);
	  if (step_real)
	    rstart += rstep;
	  else
	    rstart += istep;
	}
      else
	{
	  *resp = zzz_cons (zzz_make_integer (istart), NULL);
	  if (step_real)
	    istart += (int) rstep;
	  else
	    istart += istep;
	}
      resp = cdr_addr (*resp);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  proper-list?
  (proper-list? list) => boolean
  Return @code{#t} if @var{x} is a proper list -- a finite,
  nil-terminated list.  Return @var{#f} for any other object.
  doc:*/
#define FUNC_NAME "proper-list?"
static result_t
proper_list_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (zzz_list_length (obj) >= 0)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  circular-list?
  (circular-list? list) => boolean
  Return @code{#t} if @var{x} is a circular list.
  doc:*/
#define FUNC_NAME "circular-list?"
static result_t
circular_list_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (zzz_list_length (obj) == -2)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  dotted-list?
  (dotted-list? obj) => boolean
  Return @code{#t} if @var{x} is a finite, non-nil-terminated list.  This
  includes non-pair, non-() values (e.g. symbols, numbers), which are
  considered to be dotted lists of length 0.
  doc:*/
#define FUNC_NAME "dotted-list?"
static result_t
dotted_list_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (zzz_list_length (obj) == -1)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  null-list?
  (null-list? list) => boolean
  @var{list} is a proper or circular list.  Returns @code{#t} if the
  argument is the empty list (), and @code{#f} otherwise.  It is an error
  to pass this procedure a value which is not a proper or circular list.
  This procedure is recommended as the termination condition for
  list--processing procedures that are not defined on dotted lists.
  doc:*/
#define FUNC_NAME "null-list?"
static result_t
null_list_p_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, zzz_list_length (list) != -1,
	      zzz_proper_or_circular_list_type_name);
  if (zzz_eq (list, NULL))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  not-pair?
  (not-pair? obj) => boolean
  Return @code{#t} if @var{x} is not a pair.  Provided as a procedure as
  it can be useful as the termination condition for list-processing
  procedures that wish to handle all lists, both proper and dotted.
  doc:*/
#define FUNC_NAME "not-pair?"
static result_t
not_pair_p_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (cons_p (obj))
    *result = zzz_false_value;
  else
    *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list=
  (list= elt= list1 ...) =>
  Determine list equality, given an element-equality procedure.  Proper
  list @var{A} equals proper list @var{B} if they are of the same length
  and their corresponding elements are equal, as determined by @var{elt=}.

It is an error to apply @code{list=} to anything except proper lists.
  doc:*/
#define FUNC_NAME "list="
static result_t
list_eq_func (zzz_scm_t env, zzz_scm_t pred, zzz_scm_t param,
	      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t cur_list, next_list;
  zzz_scm_t tmp1, tmp2, temp;
  int argnum = 3;
  result_t err;

  CHECK_TYPE (1, procedure_p (pred), zzz_procedure_type_name);
  if (!cons_p (param))
    {
      *result = zzz_true_value;
      return RESULT_SUCCESS;
    }
  NEXT_ARG (cur_list);
  CHECK_TYPE (2, zzz_list_length (cur_list) != -1,
	      zzz_proper_or_circular_list_type_name);
  while (cons_p (param))
    {
      NEXT_ARG (next_list);
      CHECK_TYPE (argnum, zzz_list_length (next_list) != -1,
		  zzz_proper_or_circular_list_type_name);
      argnum++;

      tmp1 = cur_list;
      tmp2 = next_list;
      while (cons_p (tmp1) && cons_p (tmp2))
	{
	  ZZZ_TICK ();
	  if ((err = zzz_apply
	       (env, pred,
		zzz_cons (car (tmp1), zzz_cons (car (tmp2), NULL)),
		&temp)) != RESULT_SUCCESS)
	    {
	      *result = temp;
	      return err;
	    }
	  if (zzz_eq (temp, zzz_false_value))
	    {
	      *result = zzz_false_value;
	      return RESULT_SUCCESS;
	    }
	  tmp1 = cdr (tmp1);
	  tmp2 = cdr (tmp2);
	  if (tmp1 == cur_list || tmp2 == next_list)
	    {
	      *result = zzz_false_value;
	      return RESULT_SUCCESS;
	    }
	}
      if (cons_p (tmp1) || cons_p (tmp2))
	{
	  *result = zzz_false_value;
	  return RESULT_SUCCESS;
	}
      cur_list = next_list;
    }
  LAST_ARG ();
  *result = zzz_true_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  first
  (first list) => object
  Return the first element from @var{list}.
  doc:*/
#define FUNC_NAME "first"
static result_t
first_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  *result = car (list);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  second
  (second list) => object
  Return the second element from @var{list}.
  doc:*/
#define FUNC_NAME "second"
static result_t
second_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  *result = car (cdr (list));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  third
  (third list) => object
  Return the third element from @var{list}.
  doc:*/
#define FUNC_NAME "third"
static result_t
third_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  *result = car (cdr (cdr (list)));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  fourth
  (fourth list) => object
  Return the fourth element from @var{list}.
  doc:*/
#define FUNC_NAME "fourth"
static result_t
fourth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (list))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  fifth
  (fifth list) => object
  Return the fifth element from @var{list}.
  doc:*/
#define FUNC_NAME "fifth"
static result_t
fifth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (list)))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  sixth
  (sixth list) => object
  Return the sixth element from @var{list}.
  doc:*/
#define FUNC_NAME "sixth"
static result_t
sixth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (list)))))),
	      zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (cdr (list))))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  seventh
  (seventh list) => object
  Return the seventh element from @var{list}.
  doc:*/
#define FUNC_NAME "seventh"
static result_t
seventh_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (list)))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (list))))))),
	      zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (cdr (cdr (list)))))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  eighth
  (eighth list) => object
  Return the eighth element from @var{list}.
  doc:*/
#define FUNC_NAME "eighth"
static result_t
eighth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (list)))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (list))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list)))))))),
	      zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list))))))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  ninth
  (ninth list) => object
  Return the ninth element from @var{list}.
  doc:*/
#define FUNC_NAME "ninth"
static result_t
ninth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (list)))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (list))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list)))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p
	      (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list))))))))),
	      zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list)))))))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  tenth
  (tenth list) => object
  Return the tenth element from @var{list}.
  doc:*/
#define FUNC_NAME "tenth"
static result_t
tenth_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (list), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (list)), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (list))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (list)))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (list))))), zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (list)))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (list))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list)))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p
	      (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list))))))))),
	      zzz_pair_type_name);
  CHECK_TYPE (1, cons_p
	     (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list)))))))))),
	      zzz_pair_type_name);
  *result = car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (list))))))))));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  car+cdr
  (car+cdr pair) => [obj1 obj2]
  The fundamental pair deconstructor.  Return two values, the first being
  the @i{car}, the second being the @i{cdr} of the pair.
  doc:*/
#define FUNC_NAME "car+cdr"
static result_t
car_plus_cdr_func (zzz_scm_t env, zzz_scm_t pair, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, cons_p (pair), zzz_pair_type_name);
  *result = zzz_make_values
    (zzz_cons (car (pair), zzz_cons (cdr (pair), NULL)));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Helper function which takes a list of lists (@var{param}) and
   returns a vector of (length param) elements, where in the 0th
   vector element a list of the 0th list elements is stored, in the
   1st vector element a list of all 1st list elements, etc.
   @var{s_func_name} is used as the called function in error messages,
   @var{param_position} tells the parameter position of @var{param} in
   the caller and @var{result} points to the location where the result
   vector will be stored.  */
static result_t
collect_params_in_vector (char * s_func_name, 
			  int param_position,
			  zzz_scm_t param, zzz_scm_t * result)
{
  int list_count = 0, i;
  zzz_scm_t arg_list, vec, list;

  arg_list = param;
  do
    {
      ZZZ_TICK ();
      NEXT_ARG (list);
      CHECK_TYPE (list_count + param_position, list_p (list),
		  zzz_list_type_name);
      list_count++;
    }
  while (cons_p (param));
  vec = zzz_make_vector (list_count);
  i = 0;
  while (cons_p (arg_list))
    {
      zzz_vector_put (vec, i, car (arg_list));
      arg_list = cdr (arg_list);
      i++;
    }
  *result = vec;
  return RESULT_SUCCESS;
}

/*:doc
  count
  (count pred list1 list2 ...) => integer
  @var{pred} is a procedure taking as many arguments as there are lists
  and returning a single value.  It is applied element-wise to the
  elements of the @var{lists}, and a count is tallied of the number of
  elements that return a true value. This count is returned.  @code{count}
  is iterative in that it is guarateed to apply @var{pred} to the
  @var{list} elements in a left-to-right order.  The counting stops when
  the shortest list expires.  At least one of the argument lists must be
  finite.
  doc:*/
#define FUNC_NAME "count"
static result_t
count_func (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t arg_list = NULL, vec = NULL;
  int list_count = 0, i;
  zzz_scm_t * cellp;
  int count_accu = 0;
  result_t err;

  CHECK_TYPE (1, procedure_p (proc), zzz_procedure_type_name);
  if ((err = collect_params_in_vector (s_func_name, 2, param, 
				       result)) != RESULT_SUCCESS)
    return err;
  vec = *result;
  list_count = vector_len (vec);
  for (;;)
    {
      /* No ZZZ_TICK() necessary here, because zzz_apply() will do it.  */
      arg_list = NULL;
      cellp = &arg_list;
      for (i = 0; i < list_count; i++)
	{
	  if (!cons_p (zzz_vector_get (vec, i)))
	    {
	      *result = zzz_make_integer (count_accu);
	      return RESULT_SUCCESS;
	    }
	  *cellp = zzz_cons (car (zzz_vector_get (vec, i)), NULL);
	  cellp = cdr_addr (*cellp);
	  zzz_vector_put (vec, i, cdr (zzz_vector_get (vec, i)));
	}
      if ((err = zzz_apply (env, proc, arg_list, result)) != RESULT_SUCCESS)
	return err;
      if (!zzz_eq (*result, zzz_false_value))
	count_accu++;
    }
  abort ();			/* Should never reach this. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  fold
  (fold kons knil list1 list2 ...) => object
  The fundamental list iterator.
  First, consider the single list-parameter case if clist1=(e1 e2
  @dots{} en) then this procedure returns
  @example
  (kons en @dots{} (kons e1 (kons e1 knil)))
  @end example
  That is, it obeys the (tail) recursion
  @example
  (fold kons knil lis) = (fold kons (kons (car lis) knil) (cdr lis))
  (fold kons knil '()) = knil
  @end example
  If @var{n} argument lists are provided, then the @var{kons} procedure
  must take @var{n}+1 parameters: one element from each list, and the
  ``seed'' or fold state, which is initially @var{knil}.  The fold
  operation terminates when the shortest list runs out of values.  At
  least one of the argument lists must be finite.
  doc:*/
#define FUNC_NAME "fold"
static result_t
fold_func (zzz_scm_t env, zzz_scm_t kons, zzz_scm_t knil, zzz_scm_t param,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t vec, arg_list;
  zzz_scm_t * cellp;
  int list_count, i, count_accu = 0;
  result_t err;

  CHECK_TYPE (1, procedure_p (kons), zzz_procedure_type_name);
  if ((err = collect_params_in_vector (s_func_name, 3, param, result)) !=
      RESULT_SUCCESS)
    return err;
  vec = *result;
  list_count = vector_len (vec);
  for (;;)
    {
      /* No ZZZ_TICK() necessary here, because zzz_apply() will do it.  */
      arg_list = NULL;
      cellp = &arg_list;
      for (i = 0; i < list_count; i++)
	{
	  if (!cons_p (zzz_vector_get (vec, i)))
	    {
	      *result = knil;
	      return RESULT_SUCCESS;
	    }
	  *cellp = zzz_cons (car (zzz_vector_get (vec, i)), NULL);
	  cellp = cdr_addr (*cellp);
	  zzz_vector_put (vec, i, cdr (zzz_vector_get (vec, i)));
	}
      *cellp = zzz_cons (knil, NULL);
      if ((err = zzz_apply (env, kons, arg_list, result)) != RESULT_SUCCESS)
	return err;
      knil = *result;
    }
  abort ();			/* Should never reach this. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  pair-fold
  (pair-fold kons knil list1 list2 ...) => object
  Analogous to @code{fold}, but @var{kons} is applied to successive
  sublists of the lists, rather than successive elements -- that is,
  @var{kons} is applied to the pairs making up the lists.
  For finite lists, the @var{kons} function may reliably apply
  @code{set-cdr!} to the pairs it is given without altering the sequence
  of execution.
  doc:*/
#define FUNC_NAME "pair-fold"
static result_t
pair_fold_func (zzz_scm_t env, zzz_scm_t kons, zzz_scm_t knil,
		zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t vec, arg_list;
  zzz_scm_t * cellp;
  int list_count, i, count_accu = 0;
  result_t err;

  CHECK_TYPE (1, procedure_p (kons), zzz_procedure_type_name);
  if ((err = collect_params_in_vector (s_func_name, 3, param, result)) !=
      RESULT_SUCCESS)
    return err;
  vec = *result;
  list_count = vector_len (vec);
  for (;;)
    {
      /* No ZZZ_TICK() necessary here, because zzz_apply() will do it.  */
      arg_list = NULL;
      cellp = &arg_list;
      for (i = 0; i < list_count; i++)
	{
	  if (!cons_p (zzz_vector_get (vec, i)))
	    {
	      *result = knil;
	      return RESULT_SUCCESS;
	    }
	  *cellp = zzz_cons (zzz_vector_get (vec, i), NULL);
	  cellp = cdr_addr (*cellp);
	  zzz_vector_put (vec, i, cdr (zzz_vector_get (vec, i)));
	}
      *cellp = zzz_cons (knil, NULL);
      if ((err = zzz_apply (env, kons, arg_list, result)) != RESULT_SUCCESS)
	return err;
      knil = *result;
    }
  abort ();			/* Should never reach this. */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  delete
  (delete obj list [=]) => list
  @code{delete} uses the comparison procedure @var{=}, which defaults to
  @code{equal?}, to find all elements of @var{list} that are equal to
  @var{x}, and deletes them from @var{list}.  The dymanic order in which
  the various applications of @var{=} are made is not specified.
  The list is not disordered -- elements that appear in the result
  list occur in the same order as they occur in the argument list.
  doc:*/
#define FUNC_NAME "delete"
static result_t
delete_func (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;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (2, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (3, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  ZZZ_TICK ();
	  if (!zzz_equal (obj, car (list)))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
    }
  else
    {
      while (cons_p (list))
	{
	  /* No ZZZ_TICK() necessary here, because zzz_apply() will do
             it.  */
	  if ((err = zzz_apply (env, pred,
				zzz_make_n_list (2, obj, car(list)),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  delete!
  (delete! obj list [=]) => list
  @code{delete!} is the destructive variant of @code{delete}. It is
  allowed to alter the cons cells in its argument list to construct the
  result.
  doc:*/
#define FUNC_NAME "delete!"
static result_t
delete_x_func (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;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (2, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (3, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  ZZZ_TICK ();
	  if (!zzz_equal (obj, car (list)))
	    {
	      *resp = list;
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
      *resp = NULL;
    }
  else
    {
      while (cons_p (list))
	{
	  /* No ZZZ_TICK() necessary here, because zzz_apply() will do
             it.  */
	  if ((err = zzz_apply (env, pred,
				zzz_make_n_list (2, obj, car(list)),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *resp = list;
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
      *resp = NULL;		/* Terminate result list. */
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  delete-duplicates
  (delete-duplicates list [=]) => list
  @code{delete-duplicates} removes duplicate elements from the list
  argument.  If there are multiple equal elements in the argument list,
  the result list only contains the first or leftmost of these elements in
  the result.  The order of the surviving elements is the same as in the
  original list.
  doc:*/
#define FUNC_NAME "delete-duplicates"
static result_t
delete_duplicates_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t pred,
			zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t rest, res = NULL, tail;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (2, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  tail = cdr (list);
	  rest = res;
	  while (cons_p (rest))
	    {
	      ZZZ_TICK ();
	      if (zzz_equal (car (list), car (rest)))
		break;
	      rest = cdr (rest);
	    }
	  if (!cons_p (rest))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = tail;
	}
    }
  else
    {
      while (cons_p (list))
	{
	  tail = cdr (list);
	  rest = res;
	  while (cons_p (rest))
	    {
	      /* No ZZZ_TICK() necessary here, because zzz_apply()
                 will do it.  */
	      if ((err = zzz_apply
		   (env, pred, zzz_make_n_list (2, car (list), car (rest)),
		    result)) !=
		  RESULT_SUCCESS)
		return err;
	      if (!zzz_eq (*result, zzz_false_value))
		break;
	      rest = cdr (rest);
	    }
	  if (!cons_p (rest))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = tail;
	}
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  delete-duplicates!
  (delete-duplicates! list [=]) => list
  @code{delete-duplicates!} is the destructive variant of
  @code{delete-duplicates}. It is allowed to alter the argument list to
  produce the result.
  doc:*/
#define FUNC_NAME "delete-duplicates!"
static result_t
delete_duplicates_x_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t pred,
			  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t rest, res = NULL, tail;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (1, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (2, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  tail = cdr (list);
	  rest = res;
	  while (cons_p (rest))
	    {
	      ZZZ_TICK ();
	      if (zzz_equal (car (list), car (rest)))
		break;
	      rest = cdr (rest);
	    }
	  if (!cons_p (rest))
	    {
	      *resp = list;
	      set_cdr (list, NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = tail;
	}
    }
  else
    {
      while (cons_p (list))
	{
	  tail = cdr (list);
	  rest = res;
	  while (cons_p (rest))
	    {
	      /* No ZZZ_TICK() necessary here, because zzz_apply()
                 will do it.  */
	      if ((err = zzz_apply
		   (env, pred, zzz_make_n_list (2, car (list), car (rest)),
		    result)) !=
		  RESULT_SUCCESS)
		return err;
	      if (!zzz_eq (*result, zzz_false_value))
		break;
	      rest = cdr (rest);
	    }
	  if (!cons_p (rest))
	    {
	      *resp = list;
	      set_cdr (list, NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = tail;
	}
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  alist-cons
  (alist-cons key datum alist) => alist
  Cons a new alist entry mapping from @var{key} to @var{datum} onto
  @var{alist}.
  doc:*/
#define FUNC_NAME "alist-cons"
static result_t
alist_cons_func (zzz_scm_t env, zzz_scm_t key, zzz_scm_t datum,
		 zzz_scm_t alist, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (3, zzz_list_length (alist) >= 0, zzz_proper_alist_type_name);
  *result = zzz_cons (zzz_cons (key, datum), alist);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  alist-copy
  (alist-copy alist) => alist
  Make a fresh copy of @var{alist}.  This means copying each pair that
  forms an association as well as the spine of the list.
  doc:*/
#define FUNC_NAME "alist-copy"
static result_t
alist_copy_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;

  CHECK_TYPE (1, zzz_list_length (list) >= 0, zzz_proper_alist_type_name);
  while (cons_p (list))
    {
      ZZZ_TICK ();
      if (!cons_p (car (list)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("proper alist expected in call to `"), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      *resp = zzz_cons (zzz_cons (car (car (list)), cdr (car (list))), NULL);
      resp = cdr_addr (*resp);
      list = cdr (list);
    }
  *resp = list;
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  alist-delete
  (alist-delete obj alist [=]) => alist
  @code{alist-delete} deletes all associations from @var{alist} with the
  given @var{key}, using key-comparison procedure @var{=}, which defaults
  to @code{equal?}.  The dynamic order in which the various applications
  of @var{=} are made is not specified.
  doc:*/
#define FUNC_NAME "alist-delete"
static result_t
alist_delete_func (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;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (2, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (3, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  ZZZ_TICK ();
	  if (!cons_p (car (list)))
	    {
	      *result = zzz_make_wta_exception
		(zzz_make_list
		 (zzz_make_string
		  (_("proper alist expected in call to `"), -1),
		  zzz_make_string (s_func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  if (!zzz_equal (obj, car (car (list))))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
    }
  else
    {
      while (cons_p (list))
	{
	  /* No ZZZ_TICK() necessary here, because zzz_apply() will do
             it.  */
	  if (!cons_p (car (list)))
	    {
	      *result = zzz_make_wta_exception
		(zzz_make_list
		 (zzz_make_string
		  (_("proper alist expected in call to `"), -1),
		  zzz_make_string (s_func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  if ((err = zzz_apply
	       (env, pred, zzz_make_n_list (2, obj, car (car (list))),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *resp = zzz_cons (car (list), NULL);
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  alist-delete!
  (alist-delete! obj alist [=]) => alist
  @code{alist-delete!} is the destructive variant of @code{alist-delete}.
  It may modify its argument list in order to produce its result.
  doc:*/
#define FUNC_NAME "alist-delete!"
static result_t
alist_delete_x_func (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;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
  result_t err;

  CHECK_TYPE (2, list_p (list), zzz_list_type_name);
  if (pred != zzz_undefined)
    CHECK_TYPE (3, procedure_p (pred), zzz_procedure_type_name);
  if (zzz_eq (pred, zzz_undefined))
    {
      while (cons_p (list))
	{
	  ZZZ_TICK ();
	  if (!cons_p (car (list)))
	    {
	      *result = zzz_make_wta_exception
		(zzz_make_list
		 (zzz_make_string (_("proper alist expected in call to `"),
				   -1),
		  zzz_make_string (s_func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  if (!zzz_equal (obj, car (car (list))))
	    {
	      *resp = list;
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
      *resp = NULL;
    }
  else
    {
      while (cons_p (list))
	{
	  /* No ZZZ_TICK() necessary here, because zzz_apply() will do
             it.  */
	  if (!cons_p (car (list)))
	    {
	      *result = zzz_make_wta_exception
		(zzz_make_list
		 (zzz_make_string (_("proper alist expected in call to `"),
				   -1),
		  zzz_make_string (s_func_name, -1),
		  zzz_make_string ("'", -1),
		  NULL));
	      return RESULT_EXCEPTION;
	    }
	  if ((err = zzz_apply
	       (env, pred, zzz_make_n_list (2, obj, car (car(list))),
				result)) != RESULT_SUCCESS)
	    return err;
	  if (zzz_eq (*result, zzz_false_value))
	    {
	      *resp = list;
	      resp = cdr_addr (*resp);
	    }
	  list = cdr (list);
	}
      *resp = NULL;		/* Terminate result list. */
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  concatenate
  (concatenate list-of-lists) => list
  Concatenate all lists in the list @var{list-of-lists} and return the
  newly created list.
  doc:*/
#define FUNC_NAME "concatenate"
static result_t
concatenate (zzz_scm_t env, zzz_scm_t list_of_lists, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t list = NULL;
  zzz_scm_t * listp = &list;
  zzz_scm_t l;

  CHECK_TYPE (1, zzz_list_length (list_of_lists) >= 0,
	      _("list of lists"));
  while (cons_p (list_of_lists))
    {
      l = car (list_of_lists);
      while (cons_p (l))
	{
	  *listp = zzz_cons (car (l), NULL);
	  listp = cdr_addr (*listp);
	  l = cdr (l);
	}
      list_of_lists = cdr (list_of_lists);
    }
  *result = list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  concatenate!
  (concatenate! list-of-lists) => list
  Concatenate all lists in the list @var{list-of-lists} and return the
  result list.  This procedure may alter the lists contained in
  the parameter when constructing the result.
  doc:*/
#define FUNC_NAME "concatenate!"
static result_t
concatenate_x (zzz_scm_t env, zzz_scm_t list_of_lists, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t list = NULL;
  zzz_scm_t * listp = &list;
  zzz_scm_t l;

  CHECK_TYPE (1, zzz_list_length (list_of_lists) >= 0,
	      _("list of lists"));
  while (cons_p (list_of_lists))
    {
      l = car (list_of_lists);
      *listp = l;
      while (cons_p (l))
	{
	  listp = cdr_addr (l);
	  l = cdr (l);
	}
      list_of_lists = cdr (list_of_lists);
    }
  *result = list;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  append-reverse
  (append-reverse rev-head tail)
  @code{append-reverse} returns @code{(append (reverse rev-head) tail)}.
  It is provided because it is a common operation.
  doc:*/
#define FUNC_NAME "append-reverse"
static result_t
append_reverse (zzz_scm_t env, zzz_scm_t rev_head, zzz_scm_t tail,
		zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;

  CHECK_TYPE (1, zzz_list_length (rev_head) >= 0, zzz_proper_list_type_name);
  res = tail;
  while (cons_p (rev_head))
    {
      res = zzz_cons (car (rev_head), res);
      rev_head = cdr (rev_head);
    }
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  append-reverse!
  (append-reverse! rev-head tail)
  @code{append-reverse!} returns @code{(append! (reverse rev-head) tail)}.
  It is provided because it is a common operation.
  @code{append-reverse!} is just the destructive variant of
  @code{append-reverse}.
  doc:*/
#define FUNC_NAME "append-reverse!"
static result_t
append_reverse_x (zzz_scm_t env, zzz_scm_t rev_head, zzz_scm_t tail,
		zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t prev, tmp;

  CHECK_TYPE (1, zzz_list_length (rev_head) >= 0, zzz_proper_list_type_name);
  prev = tail;
  while (cons_p (rev_head))
    {
      tmp = cdr (rev_head);
      set_cdr (rev_head, prev);
      prev = rev_head;
      rev_head = tmp;
    }
  *result = prev;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#if 0
/*: doc

  doc:*/
#define FUNC_NAME ""
static result_t
 (zzz_scm_t env, , 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_1 (void)
{
  zzz_c_create_module ("core list-lib", &core_list_lib_module);

  /* Procedures defined in SRFI-1. */
  zzz_c_define_function (core_list_lib_module, "length+",
			 (zzz_prim_t) length_plus, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "take",
			 (zzz_prim_t) take_func, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "take!",
			 (zzz_prim_t) take_x, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "take-right",
			 (zzz_prim_t) take_right, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "drop",
			 (zzz_prim_t) drop_func, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "drop-right",
			 (zzz_prim_t) drop_right, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "drop-right!",
			 (zzz_prim_t) drop_right_x, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "split-at",
			 (zzz_prim_t) split_at, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "split-at!",
			 (zzz_prim_t) split_at_x, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "xcons",
			 (zzz_prim_t) xcons_func, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "cons*",
			 (zzz_prim_t) cons_star_func, argv_0_0_1);
  zzz_c_define_function (core_list_lib_module, "make-list",
			 (zzz_prim_t) make_list_func, argv_1_1_0);
  zzz_c_define_function (core_list_lib_module, "list-tabulate",
			 (zzz_prim_t) list_tabulate_func,
		       argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "list-copy",
			 (zzz_prim_t) list_copy_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "circular-list",
			 (zzz_prim_t) circular_list_func,
		       argv_1_0_1);
  zzz_c_define_function (core_list_lib_module, "iota",
			 (zzz_prim_t) iota_func, argv_1_2_0);
  zzz_c_define_function (core_list_lib_module, "proper-list?",
			 (zzz_prim_t) proper_list_p_func,
		       argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "circular-list?",
			 (zzz_prim_t) circular_list_p_func,
		       argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "dotted-list?",
			 (zzz_prim_t) dotted_list_p_func,
		       argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "null-list?",
			 (zzz_prim_t) null_list_p_func,
		       argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "not-pair?",
			 (zzz_prim_t) not_pair_p_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "list=",
			 (zzz_prim_t) list_eq_func, argv_1_0_1);
  zzz_c_define_function (core_list_lib_module, "first",
			 (zzz_prim_t) first_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "second",
			 (zzz_prim_t) second_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "third",
			 (zzz_prim_t) third_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "fourth",
			 (zzz_prim_t) fourth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "fifth",
			 (zzz_prim_t) fifth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "sixth",
			 (zzz_prim_t) sixth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "seventh",
			 (zzz_prim_t) seventh_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "eighth",
			 (zzz_prim_t) eighth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "ninth",
			 (zzz_prim_t) ninth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "tenth",
			 (zzz_prim_t) tenth_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "car+cdr",
			 (zzz_prim_t)  car_plus_cdr_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "count",
			 (zzz_prim_t) count_func, argv_1_0_1);
  zzz_c_define_function (core_list_lib_module, "fold",
			 (zzz_prim_t) fold_func, argv_2_0_1);
  zzz_c_define_function (core_list_lib_module, "pair-fold",
			 (zzz_prim_t) pair_fold_func, argv_2_0_1);
  zzz_c_define_function (core_list_lib_module, "delete",
			 (zzz_prim_t) delete_func, argv_2_1_0);
  zzz_c_define_function (core_list_lib_module, "delete!",
			 (zzz_prim_t) delete_x_func, argv_2_1_0);
  zzz_c_define_function (core_list_lib_module, "delete-duplicates",
			 (zzz_prim_t) delete_duplicates_func, argv_1_1_0);
  zzz_c_define_function (core_list_lib_module, "delete-duplicates!",
			 (zzz_prim_t) delete_duplicates_x_func, argv_1_1_0);
  zzz_c_define_function (core_list_lib_module, "alist-cons",
			 (zzz_prim_t) alist_cons_func, argv_3_0_0);
  zzz_c_define_function (core_list_lib_module, "alist-copy",
			 (zzz_prim_t) alist_copy_func, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "alist-delete",
			 (zzz_prim_t) alist_delete_func,
			 argv_2_1_0);
  zzz_c_define_function (core_list_lib_module, "alist-delete!",
			 (zzz_prim_t) alist_delete_x_func,
			 argv_2_1_0);
  zzz_c_define_function (core_list_lib_module, "concatenate",
			 (zzz_prim_t) concatenate, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "concatenate!",
			 (zzz_prim_t) concatenate_x, argv_1_0_0);
  zzz_c_define_function (core_list_lib_module, "append-reverse",
			 (zzz_prim_t) append_reverse, argv_2_0_0);
  zzz_c_define_function (core_list_lib_module, "append-reverse!",
			 (zzz_prim_t) append_reverse_x, argv_2_0_0);

  return RESULT_SUCCESS;
}
