/* libsizzle/hashtab.c - hash functions
 
  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 

#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 "list.h"
#include "hashtab.h"

zzz_object_t
zzz_hashq_function (zzz_scm_t object)
{
  return ((zzz_object_t) object);
}

zzz_object_t
zzz_hashv_function (zzz_scm_t object)
{
  if (null_p (object))
    return 0;
  else if (fixnum_p (object))
    return (fixnum_val (object) < 0 ?
	    -fixnum_val (object) : fixnum_val (object));
  else if (immediate_p (object))
    return (zzz_object_t) object;
  else if (cons_p (object))
    {
      return ((zzz_object_t) object);
    }
  else				/* Tagged cell... */
    {
      if (object == zzz_true_value)
	return 257;
      else if (object == zzz_false_value)
	return 258;
      else if (object == zzz_eof_object)
	return 259;
      else if (object == zzz_undefined)
	return 260;
      else if (object == zzz_unspecified)
	return 260;
      else if (tagged_type (object) == zzz_tagged_type_char)
	return char_val (object);
      else if (tagged_type (object) == zzz_tagged_type_symbol)
	return ((zzz_object_t) object);
      else if (tagged_type (object) == zzz_tagged_type_string)
	{
	  zzz_object_t val = 0;
	  unsigned x;
	  for (x = 0; x < string_len (object); x++)
	    {
	      val = (val << 1) ^ string_val(object)[x];
	    }
	  return val;
	}
      else if (tagged_type (object) == zzz_tagged_type_float)
	return (zzz_object_t) float_val (object);
      else if (tagged_type (object) == zzz_tagged_type_long)
	return (zzz_object_t) long_val (object);
      else
	return (zzz_object_t) object;
    }
}

zzz_object_t
zzz_hash_function (zzz_scm_t object)
{
  if (null_p (object))
    return 0;
  else if (fixnum_p (object))
    return (fixnum_val (object) < 0 ?
	    -fixnum_val (object) : fixnum_val (object));
  else if (immediate_p (object))
    return (zzz_object_t) object;
  else if (cons_p (object))
    {
      return (zzz_hash_function (car (object)) << 1) ^
	(zzz_hash_function (cdr (object)) >> 1);
    }
  else				/* Tagged cell... */
    {
      if (object == zzz_true_value)
	return 257;
      else if (object == zzz_false_value)
	return 258;
      else if (object == zzz_eof_object)
	return 259;
      else if (object == zzz_undefined)
	return 260;
      else if (object == zzz_unspecified)
	return 260;
      else if (tagged_type (object) == zzz_tagged_type_char)
	return char_val (object);
      else if (tagged_type (object) == zzz_tagged_type_symbol)
	return (zzz_object_t) object;
      else if (tagged_type (object) == zzz_tagged_type_string)
	{
	  zzz_object_t val = 0;
	  unsigned x;
	  for (x = 0; x < string_len (object); x++)
	    {
	      val = (val << 1) ^ string_val(object)[x];
	    }
	  return val;
	}
      else if (tagged_type (object) == zzz_tagged_type_float)
	return (zzz_object_t) float_val (object);
      else if (tagged_type (object) == zzz_tagged_type_long)
	return (zzz_object_t) long_val (object);
      else if (tagged_type (object) == zzz_tagged_type_vector)
	{
	  zzz_object_t val = 0;
	  unsigned long x;
	  for (x = 0; x < vector_len (object); x++)
	    {
	      val = (val << 1) ^ zzz_hash_function (vector_val (object)[x]);
	    }
	  return val;
	}
      else
	return (zzz_object_t) object;
    }
}

/*:doc
  hashq
  (hashq obj n) => integer
  Determine a hash value for @var{obj} that is suitable for lookups in
  a hash table of size @var{n}, where @code{eq?} is used as the
  equality predicate.  The function returns an integer in the range 0
  to @var{n} - 1.  Note that this function may use internal
  addresses.  Thus two calls to the same function where the keys are
  equal according to the sameness predicate used are not guaranteed to
  deliver the same value if the key object @var{obj} gets garbage
  collected in between.  
  doc:*/
#define FUNC_NAME "hashq"
static result_t
hashq_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t len, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (2, integer_p (len), zzz_integer_type_name);
  *result = zzz_make_integer (zzz_hashq_function (obj) % integer_val (len));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashv
  (hashv obj n) => integer
  Determine a hash value for @var{obj} that is suitable for lookups in
  a hash table of size @var{n}, where @code{eqv?} is used as the
  equality predicate.  The function returns an integer in the range 0
  to @var{n} - 1.  Note that this function may use internal
  addresses.  Thus two calls to the same function where the keys are
  equal according to the sameness predicate used are not guaranteed to
  deliver the same value if the key object @var{obj} gets garbage
  collected in between.  
  doc:*/
#define FUNC_NAME "hashv"
static result_t
hashv_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t len, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (2, integer_p (len), zzz_integer_type_name);
  *result = zzz_make_integer (zzz_hashv_function (obj) % integer_val (len));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash
  (hash obj n) => integer
  Determine a hash value for @var{obj} that is suitable for lookups in
  a hash table of size @var{n}, where @code{equal?} is used as the
  equality predicate.  The function returns an integer in the range 0
  to @var{n} - 1.  Note that this function may use internal
  addresses.  Thus two calls to the same function where the keys are
  equal according to the sameness predicate used are not guaranteed to
  deliver the same value if the key object @var{obj} gets garbage
  collected in between.  
  doc:*/
#define FUNC_NAME "hash"
static result_t
hash_func (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t len, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (2, integer_p (len), zzz_integer_type_name);
  *result = zzz_make_integer (zzz_hash_function (obj) % integer_val (len));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static result_t
hashq_get (char * funcname, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t * result)
{
  zzz_scm_t tmp;
  zzz_object_t k;

  k = zzz_hashq_function (key) % vector_len (tab);
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (funcname, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_eq (car (car (tmp)), key))
	{
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      tmp = cdr (tmp);
    }
  /* Key was not found, so return NULL.  */
  *result = NULL;
  return RESULT_SUCCESS;
}

/*:doc
  hashq-get-handle
  (hashq-get-handle tab key) => pair | #f
  This procedure is similar to its @code{-ref} cousins, but returns
  @dfn{handles} from the hash table rather than the value associated
  with @var{key}.  By convention, a handle in a hash table is the pair
  which associates a key with a value.  Where @code{hashq-ref table
  key} returns only a @code{value}, @code{hashq-get-handle table key}
  returns the pair @code{(key . value)}.
  doc:*/
#define FUNC_NAME "hashq-get-handle"
static result_t
hashq_get_handle_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if ((err = hashq_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (!*result)
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashq-ref
  (hashq-ref tab key [default]) => value
  Look up @var{key} in the hash table @var{tab}, and return the
  value (if any) associated with it.  If @var{key} is not found,
  return @var{default} (or @code{#f} if no @var{default} argument is
  supplied).  @code{hashq-ref} uses @code{eq?} for equality testing.
  doc:*/
#define FUNC_NAME "hashq-ref"
static result_t
hashq_ref_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def,
		zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if (zzz_eq (def, zzz_undefined))
    def = zzz_false_value;
  if ((err = hashq_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    *result = cdr (*result);
  else
    *result = def;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashq-set!
  (hashq-set! tab key value) => value
  Find the entry in @var{tab} associated with @var{key}, and store
  @var{value} there. @code{hashq-set!} uses @code{eq?} for equality
  testing. This procedure returns the @var{value}.
  doc:*/
#define FUNC_NAME "hashq-set!"
static result_t
hashq_set_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t obj,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hashq_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hashq_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, obj),
				     zzz_vector_get (tab, k)));
    }
  *result = obj;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashq-create-handle!
  (hashq-create-handle! tab key value) => pair
  Look up @var{key} in @var{table} and return its handle.  If
  @var{key} is not already present, a new handle is created which
  associates @var{key} with @var{init}.  Return the handle looked up
  or newly created.
  doc:*/
#define FUNC_NAME "hashq-create-handle!"
static result_t
hashq_create_handle_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
			    zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hashq_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hashq_function (key) % vector_len (tab);
      *result = zzz_cons (key, obj);
      zzz_vector_put (tab, k, zzz_cons (*result, zzz_vector_get (tab, k)));
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashq-remove!
  (hashq-remove! tab key) => pair | #f
  Remove @var{key} (and any value associated with it) from @var{tab}.
  @code{hashq-remove!} uses @code{eq?} for equality testing. The
  procedure returns the handle (that is, the key--value pair) that was
  removed or @code{#f} if the key was not found.
  doc:*/
#define FUNC_NAME "hashq-remove!"
static result_t
hashq_remove_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;
  zzz_scm_t * prev;
  zzz_object_t k;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  k = zzz_hashq_function (key) % vector_len (tab);
  prev = vector_val (tab) + k;
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (s_func_name, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_eq (car (car (tmp)), key))
	{
	  *prev = cdr (tmp);
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      prev = cdr_addr (tmp);
      tmp = cdr (tmp);
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static result_t
hashv_get (char * funcname, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t * result)
{
  zzz_scm_t tmp;
  zzz_object_t k;

  k = zzz_hashv_function (key) % vector_len (tab);
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (funcname, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_eqv (car (car (tmp)), key))
	{
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      tmp = cdr (tmp);
    }
  *result = NULL;
  return RESULT_SUCCESS;
}

/*:doc
  hashv-get-handle
  (hashv-get-handle tab key) => pair | #f
  This procedure is similar to its @code{-ref} cousins, but returns
  @dfn{handles} from the hash table rather than the value associated
  with @var{key}.  By convention, a handle in a hash table is the pair
  which associates a key with a value.  Where @code{hashv-ref table
  key} returns only a @code{value}, @code{hashv-get-handle table key}
  returns the pair @code{(key . value)}.
  doc:*/
#define FUNC_NAME "hashv-get-handle"
static result_t
hashv_get_handle_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if ((err = hashv_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (!*result)
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashv-ref
  (hashv-ref tab key [default]) => value
  Look up @var{key} in the hash table @var{tab}, and return the
  value (if any) associated with it.  If @var{key} is not found,
  return @var{default} (or @code{#f} if no @var{default} argument is
  supplied).  @code{hashv-ref} uses @code{eqv?} for equality testing.
  doc:*/
#define FUNC_NAME "hashv-ref"
static result_t
hashv_ref_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def,
		zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if (zzz_eq (def, zzz_undefined))
    def = zzz_false_value;
  if ((err = hashv_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    *result = cdr (*result);
  else
    *result = def;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashv-set!
  (hashv-set! tab key value) => value
  Find the entry in @var{tab} associated with @var{key}, and store
  @var{value} there. @code{hashq-set!} uses @code{eqv?} for equality
  testing. This procedure returns the @var{value}.
  doc:*/
#define FUNC_NAME "hashv-set!"
static result_t
hashv_set_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t obj,
		  zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hashv_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hashv_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, obj),
				     zzz_vector_get (tab, k)));
    }
  *result = obj;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashv-create-handle!
  (hashv-create-handle! tab key value) => pair
  Look up @var{key} in @var{table} and return its handle.  If
  @var{key} is not already present, a new handle is created which
  associates @var{key} with @var{init}.  Return the handle looked up
  or newly created.
  doc:*/
#define FUNC_NAME "hashv-create-handle!"
static result_t
hashv_create_handle_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
			    zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hashv_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hashv_function (key) % vector_len (tab);
      *result = zzz_cons (key, obj);
      zzz_vector_put (tab, k, zzz_cons (*result, zzz_vector_get (tab, k)));
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hashv-remove!
  (hashv-remove! tab key) => pair | #f
  Remove @var{key} (and any value associated with it) from @var{tab}.
  @code{hashv-remove!} uses @code{eqv?} for equality testing. The
  procedure returns the handle (that is, the key--value pair) that was
  removed or @code{#f} if the key was not found.
  doc:*/
#define FUNC_NAME "hashv-remove!"
static result_t
hashv_remove_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;
  zzz_scm_t * prev;
  zzz_object_t k;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  k = zzz_hashv_function (key) % vector_len (tab);
  prev = vector_val (tab) + k;
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (s_func_name, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_eqv (car (car (tmp)), key))
	{
	  *prev = cdr (tmp);
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      prev = cdr_addr (tmp);
      tmp = cdr (tmp);
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static result_t
hash_get (char * funcname, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t * result)
{
  zzz_scm_t tmp;
  zzz_object_t k;

  k = zzz_hash_function (key) % vector_len (tab);
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (funcname, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_equal (car (car (tmp)), key))
	{
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      tmp = cdr (tmp);
    }
  *result = NULL;
  return RESULT_SUCCESS;
}

/*:doc
  hash-get-handle
  (hash-get-handle tab key) => pair | #f
  This procedure is similar to its @code{-ref} cousins, but returns
  @dfn{handles} from the hash table rather than the value associated
  with @var{key}.  By convention, a handle in a hash table is the pair
  which associates a key with a value.  Where @code{hash-ref table
  key} returns only a @code{value}, @code{hash-get-handle table key}
  returns the pair @code{(key . value)}.
  doc:*/
#define FUNC_NAME "hash-get-handle"
static result_t
hash_get_handle_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if ((err = hash_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (!*result)
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash-ref
  (hash-ref tab key [default]) => value
  Look up @var{key} in the hash table @var{tab}, and return the
  value (if any) associated with it.  If @var{key} is not found,
  return @var{default} (or @code{#f} if no @var{default} argument is
  supplied).  @code{hash-ref} uses @code{equal?} for equality testing.
  doc:*/
#define FUNC_NAME "hash-ref"
static result_t
hash_ref_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def,
	       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  if (zzz_eq (def, zzz_undefined))
    def = zzz_false_value;
  if ((err = hash_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    *result = cdr (*result);
  else
    *result = def;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash-set!
  (hash-set! tab key value) => value
  Find the entry in @var{tab} associated with @var{key}, and store
  @var{value} there. @code{hashq-set!} uses @code{equal?} for equality
  testing. This procedure returns the @var{value}.
  doc:*/
#define FUNC_NAME "hash-set!"
static result_t
hash_set_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key, zzz_scm_t obj,
		 zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hash_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hash_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, obj),
				     zzz_vector_get (tab, k)));
    }
  *result = obj;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash-create-handle!
  (hash-create-handle! tab key value) => pair
  Look up @var{key} in @var{table} and return its handle.  If
  @var{key} is not already present, a new handle is created which
  associates @var{key} with @var{init}.  Return the handle looked up
  or newly created.
  doc:*/
#define FUNC_NAME "hash-create-handle!"
static result_t
hash_create_handle_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
			   zzz_scm_t obj, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  if ((err = hash_get (s_func_name, tab, key, result)) != RESULT_SUCCESS)
    return err;
  if (*result)
    set_cdr (*result, obj);
  else
    {
      zzz_object_t k = zzz_hash_function (key) % vector_len (tab);
      *result = zzz_cons (key, obj);
      zzz_vector_put (tab, k, zzz_cons (*result, zzz_vector_get (tab, k)));
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash-remove!
  (hash-remove! tab key) => pair | #f
  Remove @var{key} (and any value associated with it) from @var{tab}.
  @code{hash-remove!} uses @code{equal?} for equality testing. The
  procedure returns the handle (that is, the key--value pair) that was
  removed or @code{#f} if the key was not found.
  doc:*/
#define FUNC_NAME "hash-remove!"
static result_t
hash_remove_x_func (zzz_scm_t env, zzz_scm_t tab, zzz_scm_t key,
		    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tmp;
  zzz_scm_t * prev;
  zzz_object_t k;

  CHECK_TYPE (1, hashtable_p (tab), zzz_hash_table_type_name);
  CHECK_TYPE (1, !ro_hashtable_p (tab), zzz_mutable_hash_table_type_name);
  k = zzz_hash_function (key) % vector_len (tab);
  prev = vector_val (tab) + k;
  tmp = zzz_vector_get (tab, k);
  while (cons_p (tmp))
    {
      if (!cons_p (car (tmp)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid hash table in call to `"), -1),
	      zzz_make_string (s_func_name, -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      if (zzz_equal (car (car (tmp)), key))
	{
	  *prev = cdr (tmp);
	  *result = car (tmp);
	  return RESULT_SUCCESS;
	}
      prev = cdr_addr (tmp);
      tmp = cdr (tmp);
    }
  *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  make-hash
  (make-hash [capacity] pair ...) => vector
  Creates a hash table, initialized with values taken from the
  @var{pairs}.  The car of each pair is taken as a hash key and the
  corresponding cdr as the value.  If the first argument is not a pair, it 
  must be an integer and will give the number of buckets to use for the
  hash table.
  doc:*/
#define FUNC_NAME "make-hash"
static result_t
make_hash_func (zzz_scm_t env, zzz_scm_t param, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t tab, pair, tmp;
  zzz_object_t k;
  int capacity = 61;

  if (cons_p (param))
    {
      if (!cons_p (car (param)))
	{
	  CHECK_TYPE (1, integer_p (car (param)), zzz_integer_type_name);
	  capacity = integer_val (car (param));
	  CHECK_RANGE (1, capacity > 0, _("integer greater than zero"));
	  param = cdr (param);
	}
    }
  tab = zzz_make_hashtable (capacity);
  while (cons_p (param))
    {
      pair = car (param);
      param = cdr (param);
      CHECK_TYPE (1, cons_p (pair), _("list of pairs"));
      k = zzz_hash_function (car (pair)) % vector_len (tab);
      tmp = zzz_vector_get (tab, k);
      while (cons_p (tmp) && !zzz_equal (car (car (tmp)), car (pair)))
	tmp = cdr (tmp);
      if (!null_p (tmp))
	{
	  *result = zzz_make_misc_error_exception
	    (zzz_make_list
	     (zzz_make_string (_("duplicate hash keys in `"), -1),
	      zzz_make_string (s_func_name, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  return RESULT_EXCEPTION;
	}
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (car (pair), cdr (pair)),
				     zzz_vector_get (tab, k)));
    }
  *result = tab;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  list->hashtable
  (list->hashtable list) => hashtable
  Return a hashtable constructed from the list of alists @var{list}.
  doc:*/
#define FUNC_NAME "list->hashtable"
static result_t
list_to_hashtable_func (zzz_scm_t env, zzz_scm_t list, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t ht = NULL;
  int len = 0;

  CHECK_TYPE (1, zzz_list_length (list) >= 0, zzz_proper_list_type_name);
  len = zzz_list_length (list);
  ht = zzz_make_hashtable (len);
  len = 0;
  while (cons_p (list))
    {
      zzz_vector_put (ht, len, car (list));
      len++;
      list = cdr (list);
    }
  *result = ht;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  hash-fold
  (hash-fold proc seed table) => object
  Iterate over the elements of the hash table @var{table}.  @var{proc}
  is applied to every hash table element with the arguments
  @code{(proc key value init)}, where on the first call @var{init} is
  the given @var{seed}, and on subsequent calls @var{init} is the
  result of the previous call.
  doc:*/
#define FUNC_NAME "hash-fold"
static result_t
hash_fold (zzz_scm_t env, zzz_scm_t proc, zzz_scm_t seed, zzz_scm_t table,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  result_t err;
  unsigned i;
  zzz_scm_t temp;

  CHECK_TYPE (1, procedure_p (proc), zzz_procedure_type_name);
  CHECK_TYPE (3, hashtable_p (table), zzz_hash_table_type_name);
  for (i = 0; i < vector_len (table); i++)
    {
      temp = zzz_vector_get (table, i);
      while (cons_p (temp))
	{
	  CHECK_TYPE (3, cons_p (car (temp)), zzz_hash_table_type_name);
	  if ((err = zzz_apply (env, proc,
				zzz_make_n_list
				(3, car (car (temp)), cdr (car (temp)), seed),
				result)) != RESULT_SUCCESS)
	    return err;
	  seed = *result;
	  temp = cdr (temp);
	}
    }
  *result = seed;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

zzz_scm_t
zzz_hashq_ref (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hashq_get ("zzz_hashq_ref", tab, key, &result)) != RESULT_SUCCESS)
    return def;
  if (result)
    return cdr (result);
  else
    return def;
}

zzz_scm_t
zzz_hashv_ref (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hashv_get ("zzz_hashv_ref", tab, key, &result)) != RESULT_SUCCESS)
    return def;
  if (result)
    return cdr (result);
  else
    return def;
}

zzz_scm_t
zzz_hash_ref (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t def)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hash_get ("zzz_hash_ref", tab, key, &result)) != RESULT_SUCCESS)
    return def;
  if (result)
    return cdr (result);
  else
    return def;
}

zzz_scm_t
zzz_hashq_set (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t value)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hashq_get ("zzz_hashq_set", tab, key, &result)) != RESULT_SUCCESS)
    return NULL;
  if (result)
    set_cdr (result, value);
  else
    {
      zzz_object_t k = zzz_hashq_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, value),
				     zzz_vector_get (tab, k)));
    }
  return value;
}

zzz_scm_t
zzz_hashv_set (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t value)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hashv_get ("zzz_hashv_set", tab, key, &result)) != RESULT_SUCCESS)
    return NULL;
  if (result)
    set_cdr (result, value);
  else
    {
      zzz_object_t k = zzz_hashv_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, value),
				     zzz_vector_get (tab, k)));
    }
  return value;
}

zzz_scm_t
zzz_hash_set (zzz_scm_t tab, zzz_scm_t key, zzz_scm_t value)
{
  zzz_scm_t result;
  result_t err;

  if ((err = hash_get ("zzz_hash_set", tab, key, &result)) != RESULT_SUCCESS)
    return NULL;
  if (result)
    set_cdr (result, value);
  else
    {
      zzz_object_t k = zzz_hash_function (key) % vector_len (tab);
      zzz_vector_put (tab, k, zzz_cons (zzz_cons (key, value),
				     zzz_vector_get (tab, k)));
    }
  return value;
}

result_t
zzz_init_hash (void)
{
  zzz_define_function ("hashq", (zzz_prim_t) hashq_func, argv_2_0_0);
  zzz_define_function ("hashv", (zzz_prim_t) hashv_func, argv_2_0_0);
  zzz_define_function ("hash", (zzz_prim_t) hash_func, argv_2_0_0);
  zzz_define_function ("hashq-get-handle",
		       (zzz_prim_t) hashq_get_handle_func, argv_2_0_0);
  zzz_define_function ("hashq-ref", (zzz_prim_t) hashq_ref_func, argv_2_1_0);
  zzz_define_function ("hashq-set!",
		       (zzz_prim_t) hashq_set_x_func, argv_3_0_0);
  zzz_define_function ("hashq-create-handle!",
		       (zzz_prim_t) hashq_create_handle_x_func, argv_3_0_0);
  zzz_define_function ("hashq-remove!",
		       (zzz_prim_t) hashq_remove_x_func, argv_2_0_0);
  zzz_define_function ("hashv-get-handle",
		       (zzz_prim_t) hashv_get_handle_func, argv_2_0_0);
  zzz_define_function ("hashv-ref", (zzz_prim_t) hashv_ref_func, argv_2_1_0);
  zzz_define_function ("hashv-set!", (zzz_prim_t) hashv_set_x_func,
		       argv_3_0_0);
  zzz_define_function ("hashv-create-handle!",
		       (zzz_prim_t) hashv_create_handle_x_func,
		       argv_3_0_0);
  zzz_define_function ("hashv-remove!",
		       (zzz_prim_t) hashv_remove_x_func, argv_2_0_0);
  zzz_define_function ("hash-get-handle",
		       (zzz_prim_t) hash_get_handle_func, argv_2_0_0);
  zzz_define_function ("hash-ref", (zzz_prim_t) hash_ref_func, argv_2_1_0);
  zzz_define_function ("hash-set!", (zzz_prim_t) hash_set_x_func, argv_3_0_0);
  zzz_define_function ("hash-create-handle!",
		       (zzz_prim_t) hash_create_handle_x_func,
		       argv_3_0_0);
  zzz_define_function ("hash-remove!", (zzz_prim_t) hash_remove_x_func,
		       argv_2_0_0);
  zzz_define_function ("make-hash", (zzz_prim_t) make_hash_func, argv_0_0_1);
  /* FIXME: Document me!  */
  zzz_define_function ("list->hashtable", (zzz_prim_t) list_to_hashtable_func,
		       argv_1_0_0);
  zzz_define_function ("hash-fold", (zzz_prim_t) hash_fold, argv_3_0_0);

  return RESULT_SUCCESS;
}
