code:
/* classes: h_files */

#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H

/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 * This file is based upon stklos.h from the STk distribution by
 * Erick Gallesio <eg@unice.fr>.
 */

#include "libguile/__scm.h"

#include "libguile/validate.h"

/*
 * scm_class_class
 */

#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw"

#define scm_si_layout		  0 /* the struct layout */
#define scm_si_vtable		  1
#define scm_si_print		  2 /* the struct print closure */
#define scm_si_proc		  3
#define scm_si_setter		  4

#define scm_si_goops_fields	  5

/* Defined in libguile/objects.h:
#define scm_si_redefined	  5    The class to which class was redefined.
#define scm_si_hashsets	 	  6
*/
#define scm_si_name 		 14 /* a symbol */
#define scm_si_direct_supers 	 15 /* (class ...) */
#define scm_si_direct_slots	 16 /* ((name . options) ...) */
#define scm_si_direct_subclasses 17 /* (class ...) */
#define scm_si_direct_methods	 18 /* (methods ...) */
#define scm_si_cpl		 19 /* (class ...) */
#define scm_si_slotdef_class	 20
#define scm_si_slots		 21 /* ((name . options) ...) */
#define scm_si_name_access	 22
#define scm_si_keyword_access	 23
#define scm_si_nfields		 24 /* an integer */
#define scm_si_environment	 25 /* The environment in which class is built  */
#define SCM_N_CLASS_SLOTS	 26

typedef struct scm_t_method {
  SCM generic_function;
  SCM specializers;
  SCM procedure;
} scm_t_method;

#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj))

#define SCM_CLASSF_SIMPLE_METHOD    (0x004 << 20)
#define SCM_CLASSF_ACCESSOR_METHOD  (0x008 << 20)

/* Defined in libguile/objects.c */
/* #define SCM_CLASSF_PURE_GENERIC  (0x010 << 20) */

#define SCM_CLASSF_FOREIGN	    (0x020 << 20)
#define SCM_CLASSF_METACLASS        (0x040 << 20)

/* Defined in libguile/objects.c */
/* #define SCM_CLASSF_GOOPS_VALID   (0x080 << 20) */
/* #define SCM_CLASSF_GOOPS         (0x100 << 20) */
#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)

#define SCM_CLASSF_INHERIT	 (~(SCM_CLASSF_PURE_GENERIC \
				    | SCM_CLASSF_SIMPLE_METHOD \
				    | SCM_CLASSF_ACCESSOR_METHOD \
				    | SCM_STRUCTF_LIGHT) \
				  & SCM_CLASSF_MASK)

#define SCM_INST(x)	       SCM_STRUCT_DATA (x)

/* Also defined in libguile/objects.c */
#define SCM_CLASS_OF(x)        SCM_STRUCT_VTABLE (x)
#define SCM_ACCESSORS_OF(x)    (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))

#define SCM_CLASSP(x) \
  (SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
#define SCM_VALIDATE_CLASS(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, CLASSP, "class")

#define SCM_INSTANCEP(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_GOOPS))
#define SCM_VALIDATE_INSTANCE(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, INSTANCEP, "instance")

#define SCM_PUREGENERICP(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, PUREGENERICP, "pure generic function")

#define SCM_ACCESSORP(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")

#define SCM_SLOT(x, i)         (SCM_PACK (SCM_INST (x) [i]))
#define SCM_SET_SLOT(x, i, v)  (SCM_INST (x) [i] = SCM_UNPACK (v))
#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
#define SCM_SET_HASHSET(c, i, h)  (SCM_INST (c) [scm_si_hashsets + (i)] = (h))

#define SCM_SUBCLASSP(c1, c2)  (scm_is_true (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl))))
#define SCM_IS_A_P(x, c) \
  (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c))

#define SCM_GENERICP(x) \
  (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic))
#define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, GENERICP, "generic function")

#define SCM_METHODP(x) \
  (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_method))
#define SCM_VALIDATE_METHOD(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, METHODP, "method")

#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)

#define SCM_INITIAL_MCACHE_SIZE	  1

#define scm_si_getters_n_setters scm_si_name_access

#define scm_si_constructor	 SCM_N_CLASS_SLOTS
#define scm_si_destructor	 SCM_N_CLASS_SLOTS + 1

#define scm_si_methods		 0  /* offset of methods slot in a <generic> */
#define scm_si_n_specialized	 1
#define scm_si_used_by		 2
#define scm_si_cache_mutex	 3

#define scm_si_generic_function	 0  /* offset of gf    slot in a <method> */
#define scm_si_specializers	 1  /* offset of spec. slot in a <method> */

#define scm_si_procedure 	 2  /* offset of proc. slot in a <method> */
#define scm_si_code_table	 3  /* offset of code. slot in a <method> */

/* C interface */
SCM_API SCM scm_class_boolean;
SCM_API SCM scm_class_char;
SCM_API SCM scm_class_pair;
SCM_API SCM scm_class_procedure;
SCM_API SCM scm_class_string;
SCM_API SCM scm_class_symbol;
SCM_API SCM scm_class_procedure_with_setter;
SCM_API SCM scm_class_primitive_generic;
SCM_API SCM scm_class_vector, scm_class_null;
SCM_API SCM scm_class_real;
SCM_API SCM scm_class_complex;
SCM_API SCM scm_class_integer;
SCM_API SCM scm_class_fraction;
SCM_API SCM scm_class_unknown;
SCM_API SCM *scm_port_class;
SCM_API SCM *scm_smob_class;
SCM_API SCM scm_class_top;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
SCM_API SCM scm_class_applicable;
SCM_API SCM scm_class_entity;
SCM_API SCM scm_class_entity_with_setter;
SCM_API SCM scm_class_generic;
SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
SCM_API SCM scm_class_extended_generic;
SCM_API SCM scm_class_extended_generic_with_setter;
SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
SCM_API SCM scm_class_procedure_class;
SCM_API SCM scm_class_operator_class;
SCM_API SCM scm_class_operator_with_setter_class;
SCM_API SCM scm_class_entity_class;
SCM_API SCM scm_class_number;
SCM_API SCM scm_class_list;
SCM_API SCM scm_class_keyword;
SCM_API SCM scm_class_port;
SCM_API SCM scm_class_input_output_port;
SCM_API SCM scm_class_input_port;
SCM_API SCM scm_class_output_port;
SCM_API SCM scm_class_foreign_class;
SCM_API SCM scm_class_foreign_object;
SCM_API SCM scm_class_foreign_slot;
SCM_API SCM scm_class_self;
SCM_API SCM scm_class_protected;
SCM_API SCM scm_class_opaque;
SCM_API SCM scm_class_read_only;
SCM_API SCM scm_class_protected_opaque;
SCM_API SCM scm_class_protected_read_only;
SCM_API SCM scm_class_scm;
SCM_API SCM scm_class_int;
SCM_API SCM scm_class_float;
SCM_API SCM scm_class_double;
SCM_API const char *scm_s_slot_set_x;

SCM_API SCM scm_no_applicable_method;

SCM_API SCM scm_module_goops;

SCM_API SCM scm_goops_version (void);
SCM_API SCM scm_oldfmt (SCM);
SCM_API char *scm_c_oldfmt0 (char *);
SCM_API char *scm_c_oldfmt (char *, int n);
SCM_API void scm_load_goops (void);
SCM_API SCM scm_make_foreign_object (SCM cls, SCM initargs);
SCM_API SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
			    void * (*constructor) (SCM initargs),
			    size_t (*destructor) (void *));
SCM_API void scm_add_slot (SCM c, char *slot, SCM slot_class,
			   SCM (*getter) (SCM obj),
			   SCM (*setter) (SCM obj, SCM x),
			   char *accessor_name);
SCM_API SCM scm_wrap_object (SCM c, void *);
SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *);
SCM_API SCM scm_ensure_accessor (SCM name);
SCM_API void scm_add_method (SCM gf, SCM m);
SCM_API SCM scm_class_of (SCM obj);

/* Low level functions exported */
SCM_API SCM scm_make_next_method (SCM methods, SCM args, SCM gf);
SCM_API SCM scm_basic_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);
SCM_API SCM scm_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);

/* Primitives exported */
SCM_API SCM scm_sys_allocate_instance (SCM c, SCM initargs);
SCM_API SCM scm_sys_set_object_setter_x (SCM obj, SCM setter);
SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);

SCM_API SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int scm_find_method);
SCM_API SCM scm_sys_compute_applicable_methods (SCM gf, SCM args);
#ifdef GUILE_DEBUG
SCM_API SCM scm_pure_generic_p (SCM obj);
#endif

SCM_API SCM scm_sys_compute_slots (SCM c);
SCM_API SCM scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr);
SCM_API SCM scm_get_keyword (SCM key, SCM l, SCM default_value);
SCM_API SCM scm_sys_initialize_object (SCM obj, SCM initargs);
SCM_API SCM scm_sys_prep_layout_x (SCM c);
SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
SCM_API SCM scm_instance_p (SCM obj);
SCM_API SCM scm_class_name (SCM obj);
SCM_API SCM scm_class_direct_supers (SCM obj);
SCM_API SCM scm_class_direct_slots (SCM obj);
SCM_API SCM scm_class_direct_subclasses (SCM obj);
SCM_API SCM scm_class_direct_methods (SCM obj);
SCM_API SCM scm_class_precedence_list (SCM obj);
SCM_API SCM scm_class_slots (SCM obj);
SCM_API SCM scm_class_environment (SCM obj);
SCM_API SCM scm_generic_function_name (SCM obj);
SCM_API SCM scm_generic_function_methods (SCM obj);
SCM_API SCM scm_method_generic_function (SCM obj);
SCM_API SCM scm_method_specializers (SCM obj);
SCM_API SCM scm_method_procedure (SCM obj);
SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
SCM_API SCM scm_sys_tag_body (SCM body);
SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);
SCM_API SCM scm_slot_set_using_class_x (SCM cls, SCM obj, SCM slot_name, SCM value);
SCM_API SCM scm_slot_bound_using_class_p (SCM cls, SCM obj, SCM slot_name);
SCM_API SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_name);
SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name);
SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
SCM_API SCM scm_sys_invalidate_class (SCM cls);
SCM_API SCM scm_make_method_cache (SCM gf);
SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
SCM_API SCM scm_generic_capability_p (SCM proc);
SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
SCM_API SCM scm_primitive_generic_generic (SCM subr);
SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
SCM_API SCM stklos_version (void);
SCM_API SCM scm_make (SCM args);
SCM_API SCM scm_find_method (SCM args);
SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);

SCM_API SCM scm_init_goops_builtins (void);
SCM_API void scm_init_goops (void);

#if (SCM_ENABLE_DEPRECATED == 1)

#define SCM_INST_TYPE(x)       SCM_OBJ_CLASS_FLAGS (x)
#define SCM_SIMPLEMETHODP(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD))
#define SCM_FASTMETHODP(x) \
  (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \
                       & (SCM_CLASSF_ACCESSOR_METHOD \
			  | SCM_CLASSF_SIMPLE_METHOD)))

#endif

#endif  /* SCM_GOOPS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: unknown


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/procprop.h"
#include "libguile/root.h"

#include "libguile/gsubr.h"
#include "libguile/deprecation.h"

/*
 * gsubr.c
 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
 * and rest arguments.
 */

/* #define GSUBR_TEST */

SCM_GLOBAL_SYMBOL (scm_sym_name, "name");

SCM scm_f_gsubr_apply;

static SCM
create_gsubr (int define, const char *name,
	      int req, int opt, int rst, SCM (*fcn)())
{
  SCM subr;

  switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
    {
    case SCM_GSUBR_MAKTYPE(0, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 1, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 1, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(3, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 0, 1):
      subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 1):
      subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
    create_subr:
      if (define)
	scm_define (SCM_SUBR_ENTRY(subr).name, subr);
      return subr;
    default:
      {
	SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
	SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
	SCM sym = SCM_SUBR_ENTRY(subr).name;
	if (SCM_GSUBR_MAX < req + opt + rst)
	  {
            fprintf (stderr,
                     "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
                     req + opt + rst, name);
	    exit (1);
	  }
	SCM_SET_GSUBR_PROC (cclo, subr);
	SCM_SET_GSUBR_TYPE (cclo,
			    scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
	if (SCM_REC_PROCNAMES_P)
	  scm_set_procedure_property_x (cclo, scm_sym_name, sym);
	if (define)
	  scm_define (sym, cclo);
      return cclo;
      }
    }
}

SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (0, name, req, opt, rst, fcn);
}

SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (1, name, req, opt, rst, fcn);
}

static SCM
create_gsubr_with_generic (int define,
			   const char *name,
			   int req,
			   int opt,
			   int rst,
			   SCM (*fcn)(),
			   SCM *gf)
{
  SCM subr;

  switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
    {
    case SCM_GSUBR_MAKTYPE(0, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 1, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 1, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(3, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 0, 1):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 1):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
    create_subr:
      if (define)
	scm_define (SCM_SUBR_ENTRY(subr).name, subr);
      return subr;
    default:
      ;
    }
  scm_misc_error ("scm_c_make_gsubr_with_generic",
		  "can't make primitive-generic with this arity",
		  SCM_EOL);
  return SCM_BOOL_F; /* never reached */
}

SCM
scm_c_make_gsubr_with_generic (const char *name,
			       int req,
			       int opt,
			       int rst,
			       SCM (*fcn)(),
			       SCM *gf)
{
  return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
}

SCM
scm_c_define_gsubr_with_generic (const char *name,
				 int req,
				 int opt,
				 int rst,
				 SCM (*fcn)(),
				 SCM *gf)
{
  return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
}

SCM
scm_gsubr_apply (SCM args)
#define FUNC_NAME "scm_gsubr_apply"
{
  SCM self = SCM_CAR (args);
  SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self));
  SCM v[SCM_GSUBR_MAX];
  int typ = scm_to_int (SCM_GSUBR_TYPE (self));
  long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
#if 0
  if (n > SCM_GSUBR_MAX)
    scm_misc_error (FUNC_NAME,
		    "Function ~S has illegal arity ~S.",
		    scm_list_2 (self, scm_from_int (n)));
#endif
  args = SCM_CDR (args);
  for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
    if (scm_is_null (args))
      scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
    v[i] = SCM_CAR(args);
    args = SCM_CDR(args);
  }
  for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
    if (SCM_NIMP (args)) {
      v[i] = SCM_CAR (args);
      args = SCM_CDR(args);
    }
    else
      v[i] = SCM_UNDEFINED;
  }
  if (SCM_GSUBR_REST(typ))
    v[i] = args;
  else if (!scm_is_null (args))
    scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
  switch (n) {
  case 2: return (*fcn)(v[0], v[1]);
  case 3: return (*fcn)(v[0], v[1], v[2]);
  case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
  case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
  case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
  case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
  case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
  case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
  case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
  }
  return SCM_BOOL_F; /* Never reached. */
}
#undef FUNC_NAME

#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
   a scm_list of rest args
   */
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
  scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
  scm_display(req1, scm_cur_outp);
  scm_puts ("\n req2: ", scm_cur_outp);
  scm_display(req2, scm_cur_outp);
  scm_puts ("\n opt: ", scm_cur_outp);
  scm_display(opt, scm_cur_outp);
  scm_puts ("\n rest: ", scm_cur_outp);
  scm_display(rst, scm_cur_outp);
  scm_newline(scm_cur_outp);
  return SCM_UNSPECIFIED;
}
#endif

void
scm_init_gsubr()
{
  scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr,
				       scm_gsubr_apply);
#ifdef GSUBR_TEST
  scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif

#include "libguile/gsubr.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H

/* Copyright (C) 1995,1996,1998,2000,2001, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
#define SCM_GSUBR_REST(x) ((long)(x)>>8)

#define SCM_GSUBR_MAX 10
#define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1))
#define SCM_SET_GSUBR_TYPE(cclo, type) (SCM_CCLO_SET ((cclo), 1, (type)))
#define SCM_GSUBR_PROC(cclo) (SCM_CCLO_REF ((cclo), 2))
#define SCM_SET_GSUBR_PROC(cclo, proc) (SCM_CCLO_SET ((cclo), 2, (proc)))

SCM_API SCM scm_f_gsubr_apply;

SCM_API SCM scm_c_make_gsubr (const char *name,
			      int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
					   int req, int opt, int rst,
					   SCM (*fcn) (), SCM *gf);
SCM_API SCM scm_c_define_gsubr (const char *name,
				int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
					     int req, int opt, int rst,
					     SCM (*fcn) (), SCM *gf);

SCM_API SCM scm_gsubr_apply (SCM args);
SCM_API void scm_init_gsubr (void);

#endif  /* SCM_GSUBR_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* This is an implementation of guardians as described in
 * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
 * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
 * Programming Language Design and Implementation, June 1993
 * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
 *
 * Original design:          Mikael Djurfeldt
 * Original implementation:  Michael Livshin
 * Hacked on since by:       everybody
 *
 * By this point, the semantics are actually quite different from
 * those described in the abovementioned paper.  The semantic changes
 * are there to improve safety and intuitiveness.  The interface is
 * still (mostly) the one described by the paper, however.
 *
 * Boiled down again:        Marius Vollmer
 *
 * Now they should again behave like those described in the paper.
 * Scheme guardians should be simple and friendly, not like the greedy
 * monsters we had...
 */

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

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/smob.h"
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/hashtab.h"
#include "libguile/weaks.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"

#include "libguile/guardians.h"

/* The live and zombies FIFOs are implemented as tconcs as described
   in Dybvig's paper.  This decouples addition and removal of elements
   so that no synchronization between these needs to take place.
*/

typedef struct t_tconc
{
  SCM head;
  SCM tail;
} t_tconc;

#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail))

#define TCONC_IN(tc, obj, pair) \
do { \
  SCM_SETCAR ((tc).tail, obj); \
  SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \
  SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \
  SCM_SETCDR ((tc).tail, pair); \
  (tc).tail = pair; \
} while (0)

#define TCONC_OUT(tc, res) \
do { \
  (res) = SCM_CAR ((tc).head); \
  (tc).head = SCM_CDR ((tc).head); \
} while (0)

static scm_t_bits tc16_guardian;

typedef struct t_guardian
{
  t_tconc live;
  t_tconc zombies;
  struct t_guardian *next;
} t_guardian;

#define GUARDIAN_P(x)    SCM_SMOB_PREDICATE(tc16_guardian, x)
#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))

static t_guardian *guardians;

void
scm_i_init_guardians_for_gc ()
{
  guardians = NULL;
}

/* mark a guardian by adding it to the live guardian list.  */
static SCM
guardian_mark (SCM ptr)
{
  t_guardian *g = GUARDIAN_DATA (ptr);
  g->next = guardians;
  guardians = g;

  return SCM_BOOL_F;
}

/* Identify inaccessible objects and move them from the live list to
   the zombie list.  An object is inaccessible when it is unmarked at
   this point.  Therefore, the inaccessible objects are not marked yet
   since that would prevent them from being recognized as
   inaccessible.

   The pairs that form the life list itself are marked, tho.
*/
void
scm_i_identify_inaccessible_guardeds ()
{
  t_guardian *g;

  for (g = guardians; g; g = g->next)
    {
      SCM pair, next_pair;
      SCM *prev_ptr;

      for (pair = g->live.head, prev_ptr = &g->live.head;
	   !scm_is_eq (pair, g->live.tail);
	   pair = next_pair)
	{
	  SCM obj = SCM_CAR (pair);
	  next_pair = SCM_CDR (pair);
	  if (!SCM_GC_MARK_P (obj))
	    {
	      /* Unmarked, move to 'inaccessible' list.
	       */
	      *prev_ptr = next_pair;
	      TCONC_IN (g->zombies, obj, pair);
	    }
	  else
	    {
	      SCM_SET_GC_MARK (pair);
	      prev_ptr = SCM_CDRLOC (pair);
	    }
	}
      SCM_SET_GC_MARK (pair);
    }
}

int
scm_i_mark_inaccessible_guardeds ()
{
  t_guardian *g;
  int again = 0;

  /* We never need to see the guardians again that are processed here,
     so we clear the list.  Calling scm_gc_mark below might find new
     guardians, however (and other things), and we inform the GC about
     this by returning non-zero.  See scm_mark_all in gc-mark.c
  */

  g = guardians;
  guardians = NULL;

  for (; g; g = g->next)
    {
      SCM pair;

      for (pair = g->zombies.head;
	   !scm_is_eq (pair, g->zombies.tail);
	   pair = SCM_CDR (pair))
	{
	  if (!SCM_GC_MARK_P (pair))
	    {
	      scm_gc_mark (SCM_CAR (pair));
	      SCM_SET_GC_MARK (pair);
	      again = 1;
	    }
	}
      SCM_SET_GC_MARK (pair);
    }
  return again;
}

static size_t
guardian_free (SCM ptr)
{
  scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian");
  return 0;
}

static int
guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  t_guardian *g = GUARDIAN_DATA (guardian);

  scm_puts ("#<guardian ", port);
  scm_uintprint ((scm_t_bits) g, 16, port);

  scm_puts (" (reachable: ", port);
  scm_display (scm_length (SCM_CDR (g->live.head)), port);
  scm_puts (" unreachable: ", port);
  scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
  scm_puts (")", port);

  scm_puts (">", port);

  return 1;
}

static void
scm_i_guard (SCM guardian, SCM obj)
{
  t_guardian *g = GUARDIAN_DATA (guardian);

  if (!SCM_IMP (obj))
    {
      SCM z;
      z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
      TCONC_IN (g->live, obj, z);
    }
}

static SCM
scm_i_get_one_zombie (SCM guardian)
{
  t_guardian *g = GUARDIAN_DATA (guardian);
  SCM res = SCM_BOOL_F;

  if (!TCONC_EMPTYP (g->zombies))
    TCONC_OUT (g->zombies, res);

  return res;
}

/* This is the Scheme entry point for each guardian: If OBJ is an
 * object, it's added to the guardian's live list.  If OBJ is unbound,
 * the next available unreachable object (or #f if none) is returned.
 *
 * If the second optional argument THROW_P is true (the default), then
 * an error is raised if GUARDIAN is greedy and OBJ is already greedily
 * guarded.  If THROW_P is false, #f is returned instead of raising the
 * error, and #t is returned if everything is fine.
 */
static SCM
guardian_apply (SCM guardian, SCM obj, SCM throw_p)
{
#if ENABLE_DEPRECATED
  if (!SCM_UNBNDP (throw_p))
    scm_c_issue_deprecation_warning
      ("Using the 'throw?' argument of a guardian is deprecated "
       "and ineffective.");
#endif

  if (!SCM_UNBNDP (obj))
    {
      scm_i_guard (guardian, obj);
      return SCM_UNSPECIFIED;
    }
  else
    return scm_i_get_one_zombie (guardian);
}

SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
	    (),
"Create a new guardian.  A guardian protects a set of objects from\n"
"garbage collection, allowing a program to apply cleanup or other\n"
"actions.\n"
"\n"
"@code{make-guardian} returns a procedure representing the guardian.\n"
"Calling the guardian procedure with an argument adds the argument to\n"
"the guardian's set of protected objects.  Calling the guardian\n"
"procedure without an argument returns one of the protected objects\n"
"which are ready for garbage collection, or @code{#f} if no such object\n"
"is available.  Objects which are returned in this way are removed from\n"
"the guardian.\n"
"\n"
"You can put a single object into a guardian more than once and you can\n"
"put a single object into more than one guardian.  The object will then\n"
"be returned multiple times by the guardian procedures.\n"
"\n"
"An object is eligible to be returned from a guardian when it is no\n"
"longer referenced from outside any guardian.\n"
"\n"
"There is no guarantee about the order in which objects are returned\n"
"from a guardian.  If you want to impose an order on finalization\n"
"actions, for example, you can do that by keeping objects alive in some\n"
"global data structure until they are no longer needed for finalizing\n"
"other objects.\n"
"\n"
"Being an element in a weak vector, a key in a hash table with weak\n"
"keys, or a value in a hash table with weak value does not prevent an\n"
"object from being returned by a guardian.  But as long as an object\n"
"can be returned from a guardian it will not be removed from such a\n"
"weak vector or hash table.  In other words, a weak link does not\n"
"prevent an object from being considered collectable, but being inside\n"
"a guardian prevents a weak link from being broken.\n"
"\n"
"A key in a weak key hash table can be though of as having a strong\n"
"reference to its associated value as long as the key is accessible.\n"
"Consequently, when the key only accessible from within a guardian, the\n"
"reference from the key to the value is also considered to be coming\n"
"from within a guardian.  Thus, if there is no other reference to the\n"
	    "value, it is eligible to be returned from a guardian.\n")
#define FUNC_NAME s_scm_make_guardian
{
  t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
  SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
  SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
  SCM z;

  /* A tconc starts out with one tail pair. */
  g->live.head = g->live.tail = z1;
  g->zombies.head = g->zombies.tail = z2;

  g->next = NULL;

  SCM_NEWSMOB (z, tc16_guardian, g);

  return z;
}
#undef FUNC_NAME

void
scm_init_guardians ()
{
  tc16_guardian = scm_make_smob_type ("guardian", 0);
  scm_set_smob_mark (tc16_guardian, guardian_mark);
  scm_set_smob_free (tc16_guardian, guardian_free);
  scm_set_smob_print (tc16_guardian, guardian_print);
#if ENABLE_DEPRECATED
  scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
#else
  scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
#endif

#include "libguile/guardians.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_GUARDIANS_H
#define SCM_GUARDIANS_H

/* Copyright (C) 1998,2000,2001, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_make_guardian (void);

SCM_API void scm_i_init_guardians_for_gc (void);
SCM_API void scm_i_identify_inaccessible_guardeds (void);
SCM_API int scm_i_mark_inaccessible_guardeds (void);

SCM_API void scm_init_guardians (void);

#endif  /* SCM_GUARDIANS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
#!/bin/sh
# Extract the initialization actions for builtin things.
#
#  Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program 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 program 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 software; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA

fullfilename=$1

# strip path to source directory
filename=`basename $fullfilename`

no_ext=`echo $filename | sed 's/\.[^.]*$//g'`
dot_doc=${no_ext}.doc

bindir=`dirname $0`

${bindir}/guile-snarf-docs "$@" > $dot_doc

${bindir}/guile-snarf "$@"

# guile-doc-snarf ends here


code:
#!/usr/bin/awk -f
#
#  Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program 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 program 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 software; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 11-Jan-2000

BEGIN {
  filename = ARGV[1];
  in_a_func = 0;
}

/^SCM_DEFINE/ {
  func_name = $0;
  sub(/^[^\(\n]*\([ \t]*/,"", func_name);
  sub(/[ \t]*,.*/,"", func_name);
#  print func_name;  # GJB:FIXME:: flag to do this to list primitives?
  in_a_func = 1;
}

/^\{/ && in_a_func {
  if (!match(last_line,/^#define[ \t]+FUNC_NAME[ \t]+/)) {
    printf filename ":" NR ":***" > "/dev/stderr";
    print "Missing or erroneous `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
  } else {
    sub(/^#define[ \t]+FUNC_NAME[ \t]+s_/, "", last_line);
    sub(/[ \t]*$/,"",last_line);
    if (last_line != func_name) {
      printf filename ":" NR ":***" > "/dev/stderr";
      print "Mismatching FUNC_NAME.  Should be: `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
    }
  }
}

1 == next_line_better_be_undef {
  if (!match($0,/^#undef FUNC_NAME[ \t]*$/)) {
    printf filename ":" NR ":***" > "/dev/stderr";
    print "Missing or erroneous #undef for " func_name ": "
          "Got `" $0 "' instead." > "/dev/stderr";
  }
  in_a_func = "";
  func_name = "";
  next_line_better_be_undef = 0;
}

/^\}/ && in_a_func {
  next_line_better_be_undef = 1;
}

{ last_line = $0; }


code:
#!/bin/sh
# Extract the doc stuff for builtin things.
#
#  Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program 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 program 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 software; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA

bindir=`dirname $0`

## Let the user override the preprocessor autoconf found.
test -n "${CPP+set}" || CPP="@CPP@"

${CPP} -DSCM_MAGIC_SNARF_DOCS "$@"


code:
#  Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program 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 program 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 software; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 12-Dec-1999

BEGIN { FS="|";
        dot_doc_file = ARGV[1]; ARGV[1] = "-";
        std_err = "/dev/stderr";
        # be sure to put something in the files to help make out
        print "";
        printf "" > dot_doc_file;
}

/^[ \t]*SCM_SNARF_INIT_START/ { copy = $0;
               gsub(/[ \t]*SCM_SNARF_INIT_START/, "", copy);
               gsub(/SCM_SNARF_DOC_START.*$/, "", copy);
               print copy; }

/SCM_SNARF_DOC_START/,/SCM_SNARF_DOCSTRING_START/ { copy = $0;
                 if (match(copy,/SCM_SNARF_DOC_STARTR/)) { registering = 1; }
                 else {registering = 0; }
                 gsub(/.*SCM_SNARF_DOC_START./,"", copy);
                 gsub(/SCM_SNARF_DOCSTRING_START.*/,"",copy);
                 gsub(/[ \t]+/," ", copy);
		 sub(/^[ \t]*/,"(", copy);
                 gsub(/\"/,"",copy);
		 sub(/\([ \t]*void[ \t]*\)/,"()", copy);
		 sub(/ \(/," ",copy);
		 numargs = gsub(/SCM /,"", copy);
		 numcommas = gsub(/,/,"", copy);
		 numactuals = $2 + $3 + $4;
		 location = $5;
		 gsub(/\"/,"",location);
		 sub(/^[ \t]*/,"",location);
		 sub(/[ \t]*$/,"",location);
		 sub(/: /,":",location);
		 sub(/^\.\//,"",location);
		 # Now whittle copy down to just the $1 field
		 #   (but do not use $1, since it hasn't been
                 #    altered by the above regexps)
		 gsub(/[ \t]*\|.*$/,"",copy);
		 sub(/ \)/,")",copy);
		 # Now `copy' contains the nice scheme proc "prototype", e.g.
		 # (set-car! pair value)
                 # Since this is destined to become Texinfo source,
                 # quote any `@'s that occur in the prototype.
                 gsub(/\@/,"@@",copy);
		 # print copy > "/dev/stderr";  # for debugging
		 sub(/^\(/,"",copy);
		 sub(/\)[ \t]*$/,"",copy);
		 proc_and_args = copy;
		 curr_function_proto = copy;
		 proc_name = copy;
		 sub(/ .*$/,"",proc_name);
		 sub(/[^ \n]* /,"",proc_and_args);
		 split(proc_and_args,args," ");
		 # now args is an array of the arguments
		 # args[1] is the formal name of the first argument, etc.
		 if (numargs != numactuals && !registering)
		   { print location ":*** `" curr_function_proto "' is improperly registered as having " numactuals " arguments" > std_err; }
		 # Build a nicer function prototype than curr_function_proto
		 # that shows optional and rest arguments.
		 nicer_function_proto = proc_name;
		 if (!registering) {
    		   optional_args_tail = "";
		   for (i = 1; i <= $2; i++) {
		     nicer_function_proto = nicer_function_proto " " args[i];
		   }
		   for (; i <= $2 + $3; i++) {
		     nicer_function_proto = nicer_function_proto " [" args[i];
		     optional_args_tail = optional_args_tail "]";
		   }
		   nicer_function_proto = nicer_function_proto optional_args_tail;
		   if ($4 != 0) {
		     nicer_function_proto = nicer_function_proto " . " args[i];
		   }
                 }
		 # Now produce Texinfo format output.
		 print "\n" proc_name > dot_doc_file;
		 print "@c snarfed from " location > dot_doc_file;
		 print "@deffn primitive " nicer_function_proto > dot_doc_file;
}

/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0;

                 # Trim everything up to and including
                 # SCM_SNARF_DOCSTRING_START marker.
                 gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy);

		 # Trim leading whitespace and opening quote.
		 sub(/^[ \t]*\"?/,"", copy);

		 # Trim closing quote and trailing whitespace, or
                 # closing quote and whitespace followed by the
                 # SCM_SNARF_DOCSTRING_END marker.
                 sub(/[ \t]*\"?[ \t]*$/,"", copy);
		 sub(/[ \t]*\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy);

		 # Replace escaped characters.
		 gsub(/\\n/,"\n",copy);
                 gsub(/\\\"/,"\"",copy);
                 gsub(/\\\\/,"\\",copy);

		 # Some docstrings end each line with "\n", while
                 # others don't.  Therefore we always strip off one "\n"
                 # if present at the end of the line.  Docstrings must
		 # therefore always use "\n\n" to indicate a blank line.
                 if (copy != "")
		   {
		     sub(/[ \t]*\n$/, "", copy);
		     print copy > dot_doc_file;
		   }
                }

/SCM_SNARF_DOCSTRING_END[ \t]*/ { print "@end deffn" >> dot_doc_file; }

/\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0;
         sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy);
         if (copy ~ /\"/) { next }
         gsub(/[ \t]*,[ \t]*/,":",copy);
         sub(/[ \t]*\).*/,"",copy);
         split(copy,argpos,":");
         argname = argpos[1];
         pos = argpos[2];
         if (pos ~ /[A-Za-z]/) { next }
         if (pos ~ /^[ \t]*$/) { next }
         if (argname ~ / /) { next }
         line = argpos[3];
#         print pos " " args[pos] " vs. " argname > "/dev/stderr";
         if (args[pos] != argname) { print filename ":" line ":*** Argument name/number mismatch in `" curr_function_proto "' -- " argname " is not formal #" pos > "/dev/stderr"; }
      }


code:
#!/bin/sh
# Extract the initialization actions from source files.
#
#  Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
#
# This program 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 program 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 software; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
# Boston, MA 02110-1301 USA

# Commentary:

# Usage: guile-snarf [-o OUTFILE] [CPP-ARGS ...]

# Initialization actions are extracted to OUTFILE or to standard
# output when no OUTFILE has been specified or when OUTFILE is "-".
# The C preprocessor is called with CPP-ARGS (which usually include a
# input file) and the output is filtered for the actions.
#
# If there are errors during processing, OUTFILE is deleted and the
# program exits with non-zero status.
#
# During snarfing, the pre-processor macro SCM_MAGIC_SNARFER is
# defined.  You can use this to avoid including snarfer output files
# that don't yet exist by writing code like this:
#
#   #ifndef SCM_MAGIC_SNARFER
#   #include "foo.x"
#   #endif
#
# If the environment variable CPP is set, use its value instead of the
# C pre-processor determined at Guile configure-time: "@CPP@".

# Code:

## funcs

modern_snarf ()                         # writes stdout
{
    ## Apparently, AIX's preprocessor is unhappy if you try to #include an
    ## empty file.
    echo "/* cpp arguments: $@ */" ;
    ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
    grep "^ *\^ *\^" ${temp} | sed -e "s/^ *\^ *\^//" -e "s/\^\ *:\ *\^.*/;/"
}

## main

# process command line
if [ x"$1" = x--help ] ; then
    @AWK@ '/^#.Commentary:/,/^#.Code:/' $0 | grep -v Code: \
        | sed -e 1,2d -e 's/^. *//g'
    exit 0
fi
if [ x"$1" = x-o ]
    then outfile="$2" ; shift ; shift ;
    else  outfile="-" ;
fi

# set vars and handler -- handle CPP override
cpp_ok_p=false

if [ x"$TMPDIR" = x ]; then TMPDIR="/tmp" ; else : ; fi
tempdir="$TMPDIR/guile-snarf.$$"
(umask 077 && mkdir $tempdir) || exit 1
temp="$tempdir/tmp"

if [ x"$CPP" = x ] ; then cpp="@CPP@" ; else cpp="$CPP" ; fi

trap "rm -rf $tempdir" 0 1 2 15

if [ ! "$outfile" = "-" ] ; then
    modern_snarf "$@" > $outfile
else
    modern_snarf "$@"
fi

# zonk outfile if errors occurred
if $cpp_ok_p ; then
    exit 0
else
    [ ! "$outfile" = "-" ] && rm -f $outfile
    exit 1
fi

# guile-snarf ends here


code:
/* Copyright (C) 1996,1997,2000,2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

/* This is the 'main' function for the `guile' executable.  It is not
   included in libguile.a.

   Eventually, we hope this file will be automatically generated,
   based on the list of installed, statically linked libraries on the
   system.  For now, please don't put interesting code in here.  */

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

#ifdef __MINGW32__
# define SCM_IMPORT 1
#endif
#include <libguile.h>

#ifdef HAVE_CONFIG_H
#include <libguile/scmconfig.h>
#endif
#include <ltdl.h>

#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#endif

static void
inner_main (void *closure SCM_UNUSED, int argc, char **argv)
{
#ifdef __MINGW32__
  /* This is necessary to startup the Winsock API under Win32. */
  WSADATA WSAData;
  WSAStartup (0x0202, &WSAData);
#endif /* __MINGW32__ */

  /* module initializations would go here */
  scm_shell (argc, argv);

#ifdef __MINGW32__
  WSACleanup ();
#endif /* __MINGW32__ */
}

int
main (int argc, char **argv)
{
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0; /* never reached */
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/*	Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/symbols.h"
#include "libguile/vectors.h"

#include "libguile/validate.h"
#include "libguile/hash.h"

#ifndef floor
extern double floor();
#endif

unsigned long
scm_string_hash (const unsigned char *str, size_t len)
{
  /* from suggestion at: */
  /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */

  unsigned long h = 0;
  while (len-- > 0)
    h = *str++ + h*37;
  return h;
}

/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
/* Dirk:FIXME:: scm_hasher could be made static. */

unsigned long
scm_hasher(SCM obj, unsigned long n, size_t d)
{
  switch (SCM_ITAG3 (obj)) {
  case scm_tc3_int_1:
  case scm_tc3_int_2:
    return SCM_I_INUM(obj) % n;   /* SCM_INUMP(obj) */
  case scm_tc3_imm24:
    if (SCM_CHARP(obj))
      return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
    switch (SCM_UNPACK (obj)) {
#ifndef SICP
    case SCM_UNPACK(SCM_EOL):
      d = 256;
      break;
#endif
    case SCM_UNPACK(SCM_BOOL_T):
      d = 257;
      break;
    case SCM_UNPACK(SCM_BOOL_F):
      d = 258;
      break;
    case SCM_UNPACK(SCM_EOF_VAL):
      d = 259;
      break;
    default:
      d = 263;		/* perhaps should be error */
    }
    return d % n;
  default:
    return 263 % n;	/* perhaps should be error */
  case scm_tc3_cons:
    switch SCM_TYP7(obj) {
    default:
      return 263 % n;
    case scm_tc7_smob:
      return 263 % n;
    case scm_tc7_number:
      switch SCM_TYP16 (obj) {
      case scm_tc16_big:
        return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
      case scm_tc16_real:
	{
	  double r = SCM_REAL_VALUE (obj);
	  if (floor (r) == r)
	    {
	      obj = scm_inexact_to_exact (obj);
	      return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
	    }
	}
        /* Fall through */
      case scm_tc16_complex:
      case scm_tc16_fraction:
	obj = scm_number_to_string (obj, scm_from_int (10));
        /* Fall through */
      }
      /* Fall through */
    case scm_tc7_string:
      {
	unsigned long hash =
	  scm_string_hash ((const unsigned char *) scm_i_string_chars (obj),
			   scm_i_string_length (obj)) % n;
	scm_remember_upto_here_1 (obj);
	return hash;
      }
    case scm_tc7_symbol:
      return scm_i_symbol_hash (obj) % n;
    case scm_tc7_wvect:
    case scm_tc7_vector:
      {
	size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
	if (len > 5)
	  {
	    size_t i = d/2;
	    unsigned long h = 1;
	    while (i--)
	      {
		SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
		h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
	      }
	    return h;
	  }
	else
	  {
	    size_t i = len;
	    unsigned long h = (n)-1;
	    while (i--)
	      {
		SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
		h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
	      }
	    return h;
	  }
      }
    case scm_tcs_cons_imcar:
    case scm_tcs_cons_nimcar:
      if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
                     + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
      else return 1;
    case scm_tc7_port:
      return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
    case scm_tcs_closures:
    case scm_tcs_subrs:
      return 262 % n;
    }
  }
}

unsigned long
scm_ihashq (SCM obj, unsigned long n)
{
  return (SCM_UNPACK (obj) >> 1) % n;
}

SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
	    "used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.  Note that\n"
	    "@code{hashq} may use internal addresses.  Thus two calls to\n"
	    "hashq where the keys are @code{eq?} are not guaranteed to\n"
	    "deliver the same value if the key object gets garbage collected\n"
	    "in between.  This can happen, for example with symbols:\n"
	    "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
	    "different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashq
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihashq (key, sz));
}
#undef FUNC_NAME

unsigned long
scm_ihashv (SCM obj, unsigned long n)
{
  if (SCM_CHARP(obj))
    return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */

  if (SCM_NUMP(obj))
    return (unsigned long) scm_hasher(obj, n, 10);
  else
    return SCM_UNPACK (obj) % n;
}

SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
	    "used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.  Note that\n"
	    "@code{(hashv key)} may use internal addresses.  Thus two calls\n"
	    "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
	    "deliver the same value if the key object gets garbage collected\n"
	    "in between.  This can happen, for example with symbols:\n"
	    "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
	    "different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashv
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihashv (key, sz));
}
#undef FUNC_NAME

unsigned long
scm_ihash (SCM obj, unsigned long n)
{
  return (unsigned long) scm_hasher (obj, n, 10);
}

SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
	    "is used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.")
#define FUNC_NAME s_scm_hash
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihash (key, sz));
}
#undef FUNC_NAME

void
scm_init_hash ()
{
#include "libguile/hash.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_HASH_H
#define SCM_HASH_H

/* Copyright (C) 1995,1996,2000, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API unsigned long scm_string_hash (const unsigned char *str, size_t len);
SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);
SCM_API SCM scm_hashv (SCM obj, SCM n);
SCM_API unsigned long scm_ihash (SCM obj, unsigned long n);
SCM_API SCM scm_hash (SCM obj, SCM n);
SCM_API void scm_init_hash (void);

#endif  /* SCM_HASH_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

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

#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/hash.h"
#include "libguile/eval.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/ports.h"

#include "libguile/validate.h"
#include "libguile/hashtab.h"

/* NOTES
 *
 * 1. The current hash table implementation uses weak alist vectors
 *    (implementation in weaks.c) internally, but we do the scanning
 *    ourselves (in scan_weak_hashtables) because we need to update the
 *    hash table structure when items are dropped during GC.
 *
 * 2. All hash table operations still work on alist vectors.
 *
 */

/* Hash tables are either vectors of association lists or smobs
 * containing such vectors.  Currently, the vector version represents
 * constant size tables while those wrapped in a smob represents
 * resizing tables.
 *
 * Growing or shrinking, with following rehashing, is triggered when
 * the load factor
 *
 *   L = N / S    (N: number of items in table, S: bucket vector length)
 *
 * passes an upper limit of 0.9 or a lower limit of 0.25.
 *
 * The implementation stores the upper and lower number of items which
 * trigger a resize in the hashtable object.
 *
 * Possible hash table sizes (primes) are stored in the array
 * hashtable_size.
 */

scm_t_bits scm_tc16_hashtable;

static unsigned long hashtable_size[] = {
  31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
  224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
#if 0
  /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
  28762081, 57524111, 115048217, 230096423, 460192829
  /* larger values can't be represented as INUMs */
#endif
};

#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))

static char *s_hashtable = "hashtable";

SCM weak_hashtables = SCM_EOL;

static SCM
make_hash_table (int flags, unsigned long k, const char *func_name)
{
  SCM table, vector;
  scm_t_hashtable *t;
  int i = 0, n = k ? k : 31;
  while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
    ++i;
  n = hashtable_size[i];
  if (flags)
    vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
  else
    vector = scm_c_make_vector (n, SCM_EOL);
  t = scm_gc_malloc (sizeof (*t), s_hashtable);
  t->min_size_index = t->size_index = i;
  t->n_items = 0;
  t->lower = 0;
  t->upper = 9 * n / 10;
  t->flags = flags;
  t->hash_fn = NULL;
  if (flags)
    {
      SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
      weak_hashtables = table;
    }
  else
    SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
  return table;
}

void
scm_i_rehash (SCM table,
	      unsigned long (*hash_fn)(),
	      void *closure,
	      const char* func_name)
{
  SCM buckets, new_buckets;
  int i;
  unsigned long old_size;
  unsigned long new_size;

  if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
    {
      /* rehashing is not triggered when i <= min_size */
      i = SCM_HASHTABLE (table)->size_index;
      do
	--i;
      while (i > SCM_HASHTABLE (table)->min_size_index
	     && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
    }
  else
    {
      i = SCM_HASHTABLE (table)->size_index + 1;
      if (i >= HASHTABLE_SIZE_N)
	/* don't rehash */
	return;

      /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
	 is not needed since CLOSURE can not be guaranteed to be valid
	 after this function returns.
      */
      if (closure == NULL)
	SCM_HASHTABLE (table)->hash_fn = hash_fn;
    }
  SCM_HASHTABLE (table)->size_index = i;

  new_size = hashtable_size[i];
  if (i <= SCM_HASHTABLE (table)->min_size_index)
    SCM_HASHTABLE (table)->lower = 0;
  else
    SCM_HASHTABLE (table)->lower = new_size / 4;
  SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
  buckets = SCM_HASHTABLE_VECTOR (table);

  if (SCM_HASHTABLE_WEAK_P (table))
    new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table),
					      scm_from_ulong (new_size),
					      SCM_EOL);
  else
    new_buckets = scm_c_make_vector (new_size, SCM_EOL);

  /* When this is a weak hashtable, running the GC might change it.
     We need to cope with this while rehashing its elements.  We do
     this by first installing the new, empty bucket vector.  Then we
     remove the elements from the old bucket vector and insert them
     into the new one.
  */

  SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
  SCM_SET_HASHTABLE_N_ITEMS (table, 0);

  old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  for (i = 0; i < old_size; ++i)
    {
      SCM ls, cell, handle;

      ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
      SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);

      while (scm_is_pair (ls))
	{
	  unsigned long h;
	  cell = ls;
	  handle = SCM_CAR (cell);
	  ls = SCM_CDR (ls);
	  h = hash_fn (SCM_CAR (handle), new_size, closure);
	  if (h >= new_size)
	    scm_out_of_range (func_name, scm_from_ulong (h));
	  SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
	  SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
	  SCM_HASHTABLE_INCREMENT (table);
	}
    }
}

static int
hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<", port);
  if (SCM_HASHTABLE_WEAK_KEY_P (exp))
    scm_puts ("weak-key-", port);
  else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
    scm_puts ("weak-value-", port);
  else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
    scm_puts ("doubly-weak-", port);
  scm_puts ("hash-table ", port);
  scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
  scm_putc ('/', port);
  scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
		 10, port);
  scm_puts (">", port);
  return 1;
}

#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))

/* keep track of hash tables that need to shrink after scan */
static SCM to_rehash = SCM_EOL;

/* scan hash tables and update hash tables item count */
void
scm_i_scan_weak_hashtables ()
{
  SCM *next = &weak_hashtables;
  SCM h = *next;
  while (!scm_is_null (h))
    {
      if (!SCM_GC_MARK_P (h))
	*next = h = SCM_HASHTABLE_NEXT (h);
      else
	{
	  SCM vec = SCM_HASHTABLE_VECTOR (h);
	  size_t delta = SCM_I_WVECT_DELTA (vec);
	  SCM_I_SET_WVECT_DELTA (vec, 0);
	  SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta);

	  if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
	    {
	      SCM tmp = SCM_HASHTABLE_NEXT (h);
	      /* temporarily move table from weak_hashtables to to_rehash */
	      SCM_SET_HASHTABLE_NEXT (h, to_rehash);
	      to_rehash = h;
	      *next = h = tmp;
	    }
	  else
	    {
	      next = SCM_HASHTABLE_NEXTLOC (h);
	      h = SCM_HASHTABLE_NEXT (h);
	    }
	}
    }
}

static void *
rehash_after_gc (void *dummy1 SCM_UNUSED,
		 void *dummy2 SCM_UNUSED,
		 void *dummy3 SCM_UNUSED)
{
  if (!scm_is_null (to_rehash))
    {
      SCM first = to_rehash, last, h;
      /* important to clear to_rehash here so that we don't get stuck
	 in an infinite loop if scm_i_rehash causes GC */
      to_rehash = SCM_EOL;
      h = first;
      do
	{
	  /* Rehash only when we have a hash_fn.
	   */
	  if (SCM_HASHTABLE (h)->hash_fn)
	    scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
			  "rehash_after_gc");
	  last = h;
	  h = SCM_HASHTABLE_NEXT (h);
	} while (!scm_is_null (h));
      /* move tables back to weak_hashtables */
      SCM_SET_HASHTABLE_NEXT (last, weak_hashtables);
      weak_hashtables = first;
    }
  return 0;
}

static size_t
hashtable_free (SCM obj)
{
  scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
  return 0;
}

SCM
scm_c_make_hash_table (unsigned long k)
{
  return make_hash_table (0, k, "scm_c_make_hash_table");
}

SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
	    (SCM n),
	    "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
  if (SCM_UNBNDP (n))
    return make_hash_table (0, 0, FUNC_NAME);
  else
    return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
	    (SCM n),
	    "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
	    "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
	    "Return a weak hash table with @var{size} buckets.\n"
	    "\n"
	    "You can modify weak hash tables in exactly the same way you\n"
	    "would modify regular hash tables. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_key_hash_table
{
  if (SCM_UNBNDP (n))
    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
  else
    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
			    scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
            (SCM n),
	    "Return a hash table with weak values with @var{size} buckets.\n"
	    "(@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_value_hash_table
{
  if (SCM_UNBNDP (n))
    return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
  else
    {
      return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
			      scm_to_ulong (n), FUNC_NAME);
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
            (SCM n),
	    "Return a hash table with weak keys and values with @var{size}\n"
	    "buckets.  (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_doubly_weak_hash_table
{
  if (SCM_UNBNDP (n))
    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
			    0,
			    FUNC_NAME);
  else
    {
      return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
			      scm_to_ulong (n),
			      FUNC_NAME);
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is an abstract hash table object.")
#define FUNC_NAME s_scm_hash_table_p
{
  return scm_from_bool (SCM_HASHTABLE_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
           (SCM obj),
	    "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
	    "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
	    "Return @code{#t} if @var{obj} is the specified weak hash\n"
	    "table. Note that a doubly weak hash table is neither a weak key\n"
	    "nor a weak value hash table.")
#define FUNC_NAME s_scm_weak_key_hash_table_p
{
  return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a weak value hash table.")
#define FUNC_NAME s_scm_weak_value_hash_table_p
{
  return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a doubly weak hash table.")
#define FUNC_NAME s_scm_doubly_weak_hash_table_p
{
  return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
}
#undef FUNC_NAME

SCM
scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
{
  unsigned long k;
  SCM h;

  if (SCM_HASHTABLE_P (table))
    table = SCM_HASHTABLE_VECTOR (table);
  else
    SCM_VALIDATE_VECTOR (1, table);
  if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
    return SCM_BOOL_F;
  k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure);
  if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
    scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
  h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure);
  return h;
}
#undef FUNC_NAME

SCM
scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
                             SCM (*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
  unsigned long k;
  SCM buckets, it;

  if (SCM_HASHTABLE_P (table))
    buckets = SCM_HASHTABLE_VECTOR (table);
  else
    {
      SCM_ASSERT (scm_is_simple_vector (table),
		  table, SCM_ARG1, "hash_fn_create_handle_x");
      buckets = table;
    }
  if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
    SCM_MISC_ERROR ("void hashtable", SCM_EOL);

  k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
    scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
  it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
  if (scm_is_pair (it))
    return it;
  else if (scm_is_true (it))
    scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
  else
    {
      /* When this is a weak hashtable, running the GC can change it.
	 Thus, we must allocate the new cells first and can only then
	 access BUCKETS.  Also, we need to fetch the bucket vector
	 again since the hashtable might have been rehashed.  This
	 necessitates a new hash value as well.
      */
      SCM new_bucket = scm_acons (obj, init, SCM_EOL);
      if (!scm_is_eq (table, buckets)
	  && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
	{
	  buckets = SCM_HASHTABLE_VECTOR (table);
	  k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
	  if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
	    scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
	}
      SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
      SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
      if (!scm_is_eq (table, buckets))
	{
	  /* Update element count and maybe rehash the table.  The
	     table might have too few entries here since weak hash
	     tables used with the hashx_* functions can not be
	     rehashed after GC.
	  */
	  SCM_HASHTABLE_INCREMENT (table);
	  if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
	      || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
	    scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
	}
      return SCM_CAR (new_bucket);
    }
}
#undef FUNC_NAME

SCM
scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
                 SCM (*assoc_fn)(), void * closure)
{
  SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
  if (scm_is_pair (it))
    return SCM_CDR (it);
  else
    return dflt;
}

SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
                   SCM (*assoc_fn)(), void * closure)
{
  SCM it;

  it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
  SCM_SETCDR (it, val);
  return val;
}

SCM
scm_hash_fn_remove_x (SCM table, SCM obj,
		      unsigned long (*hash_fn)(),
		      SCM (*assoc_fn)(),
                      void *closure)
{
  unsigned long k;
  SCM buckets, h;

  if (SCM_HASHTABLE_P (table))
    buckets = SCM_HASHTABLE_VECTOR (table);
  else
    {
      SCM_ASSERT (scm_is_simple_vector (table), table,
		  SCM_ARG1, "hash_fn_remove_x");
      buckets = table;
    }
  if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
    return SCM_EOL;

  k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
    scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
  h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
  if (scm_is_true (h))
    {
      SCM_SIMPLE_VECTOR_SET
	(buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
      if (!scm_is_eq (table, buckets))
	{
	  SCM_HASHTABLE_DECREMENT (table);
	  if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
	    scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x");
	}
    }
  return h;
}

SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
	    (SCM table),
	    "Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
  if (SCM_HASHTABLE_P (table))
    {
      scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
      SCM_SET_HASHTABLE_N_ITEMS (table, 0);
    }
  else
    scm_vector_fill_x (table, SCM_EOL);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
            (SCM table, SCM key),
	    "This procedure returns the @code{(key . value)} pair from the\n"
	    "hash table @var{table}.  If @var{table} does not hold an\n"
	    "associated value for @var{key}, @code{#f} is returned.\n"
	    "Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
  return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
            (SCM table, SCM key, SCM init),
	    "This function looks up @var{key} in @var{table} and returns its handle.\n"
	    "If @var{key} is not already present, a new handle is created which\n"
	    "associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
  return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
            (SCM table, SCM key, SCM dflt),
	    "Look up @var{key} in the hash table @var{table}, and return the\n"
	    "value (if any) associated with it.  If @var{key} is not found,\n"
	    "return @var{default} (or @code{#f} if no @var{default} argument\n"
	    "is supplied).  Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_ref
{
  if (SCM_UNBNDP (dflt))
    dflt = SCM_BOOL_F;
  return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
            (SCM table, SCM key, SCM val),
	    "Find the entry in @var{table} associated with @var{key}, and\n"
	    "store @var{value} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
  return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
            (SCM table, SCM key),
	    "Remove @var{key} (and any value associated with it) from\n"
	    "@var{table}.  Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
  return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
            (SCM table, SCM key),
	    "This procedure returns the @code{(key . value)} pair from the\n"
	    "hash table @var{table}.  If @var{table} does not hold an\n"
	    "associated value for @var{key}, @code{#f} is returned.\n"
	    "Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
  return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
            (SCM table, SCM key, SCM init),
	    "This function looks up @var{key} in @var{table} and returns its handle.\n"
	    "If @var{key} is not already present, a new handle is created which\n"
	    "associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
  return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
				      scm_sloppy_assv, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
            (SCM table, SCM key, SCM dflt),
	    "Look up @var{key} in the hash table @var{table}, and return the\n"
	    "value (if any) associated with it.  If @var{key} is not found,\n"
	    "return @var{default} (or @code{#f} if no @var{default} argument\n"
	    "is supplied).  Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_ref
{
  if (SCM_UNBNDP (dflt))
    dflt = SCM_BOOL_F;
  return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
            (SCM table, SCM key, SCM val),
	    "Find the entry in @var{table} associated with @var{key}, and\n"
	    "store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
  return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
            (SCM table, SCM key),
	    "Remove @var{key} (and any value associated with it) from\n"
	    "@var{table}.  Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
  return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
            (SCM table, SCM key),
	    "This procedure returns the @code{(key . value)} pair from the\n"
	    "hash table @var{table}.  If @var{table} does not hold an\n"
	    "associated value for @var{key}, @code{#f} is returned.\n"
	    "Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
  return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
            (SCM table, SCM key, SCM init),
	    "This function looks up @var{key} in @var{table} and returns its handle.\n"
	    "If @var{key} is not already present, a new handle is created which\n"
	    "associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
  return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
            (SCM table, SCM key, SCM dflt),
	    "Look up @var{key} in the hash table @var{table}, and return the\n"
	    "value (if any) associated with it.  If @var{key} is not found,\n"
	    "return @var{default} (or @code{#f} if no @var{default} argument\n"
	    "is supplied).  Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_ref
{
  if (SCM_UNBNDP (dflt))
    dflt = SCM_BOOL_F;
  return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
            (SCM table, SCM key, SCM val),
	    "Find the entry in @var{table} associated with @var{key}, and\n"
	    "store @var{value} there. Uses @code{equal?} for equality\n"
	    "testing.")
#define FUNC_NAME s_scm_hash_set_x
{
  return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
            (SCM table, SCM key),
	    "Remove @var{key} (and any value associated with it) from\n"
	    "@var{table}.  Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
  return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME

typedef struct scm_t_ihashx_closure
{
  SCM hash;
  SCM assoc;
} scm_t_ihashx_closure;

static unsigned long
scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
{
  SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
  return scm_to_ulong (answer);
}

static SCM
scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
{
  return scm_call_2 (closure->assoc, obj, alist);
}

SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
            (SCM hash, SCM assoc, SCM table, SCM key),
	    "This behaves the same way as the corresponding\n"
	    "@code{-get-handle} function, but uses @var{hash} as a hash\n"
	    "function and @var{assoc} to compare keys.  @code{hash} must be\n"
	    "a function that takes two arguments, a key to be hashed and a\n"
	    "table size.  @code{assoc} must be an associator function, like\n"
	    "@code{assoc}, @code{assq} or @code{assv}.")
#define FUNC_NAME s_scm_hashx_get_handle
{
  scm_t_ihashx_closure closure;
  closure.hash = hash;
  closure.assoc = assoc;
  return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
				 (void *) &closure);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
            (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
	    "This behaves the same way as the corresponding\n"
	    "@code{-create-handle} function, but uses @var{hash} as a hash\n"
	    "function and @var{assoc} to compare keys.  @code{hash} must be\n"
	    "a function that takes two arguments, a key to be hashed and a\n"
	    "table size.  @code{assoc} must be an associator function, like\n"
	    "@code{assoc}, @code{assq} or @code{assv}.")
#define FUNC_NAME s_scm_hashx_create_handle_x
{
  scm_t_ihashx_closure closure;
  closure.hash = hash;
  closure.assoc = assoc;
  return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
				      scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
            (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
	    "This behaves the same way as the corresponding @code{ref}\n"
	    "function, but uses @var{hash} as a hash function and\n"
	    "@var{assoc} to compare keys.  @code{hash} must be a function\n"
	    "that takes two arguments, a key to be hashed and a table size.\n"
	    "@code{assoc} must be an associator function, like @code{assoc},\n"
	    "@code{assq} or @code{assv}.\n"
	    "\n"
	    "By way of illustration, @code{hashq-ref table key} is\n"
	    "equivalent to @code{hashx-ref hashq assq table key}.")
#define FUNC_NAME s_scm_hashx_ref
{
  scm_t_ihashx_closure closure;
  if (SCM_UNBNDP (dflt))
    dflt = SCM_BOOL_F;
  closure.hash = hash;
  closure.assoc = assoc;
  return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
			  (void *)&closure);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
            (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
	    "This behaves the same way as the corresponding @code{set!}\n"
	    "function, but uses @var{hash} as a hash function and\n"
	    "@var{assoc} to compare keys.  @code{hash} must be a function\n"
	    "that takes two arguments, a key to be hashed and a table size.\n"
	    "@code{assoc} must be an associator function, like @code{assoc},\n"
	    "@code{assq} or @code{assv}.\n"
	    "\n"
	    " By way of illustration, @code{hashq-set! table key} is\n"
	    "equivalent to @code{hashx-set!  hashq assq table key}.")
#define FUNC_NAME s_scm_hashx_set_x
{
  scm_t_ihashx_closure closure;
  closure.hash = hash;
  closure.assoc = assoc;
  return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
			    (void *)&closure);
}
#undef FUNC_NAME

SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
	    (SCM hash, SCM assoc, SCM table, SCM obj),
	    "This behaves the same way as the corresponding @code{remove!}\n"
	    "function, but uses @var{hash} as a hash function and\n"
	    "@var{assoc} to compare keys.  @code{hash} must be a function\n"
	    "that takes two arguments, a key to be hashed and a table size.\n"
	    "@code{assoc} must be an associator function, like @code{assoc},\n"
	    "@code{assq} or @code{assv}.\n"
	    "\n"
	    " By way of illustration, @code{hashq-remove! table key} is\n"
	    "equivalent to @code{hashx-remove!  hashq assq #f table key}.")
#define FUNC_NAME s_scm_hashx_remove_x
{
  scm_t_ihashx_closure closure;
  closure.hash = hash;
  closure.assoc = assoc;
  return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
                               (void *) &closure);
}
#undef FUNC_NAME

/* Hash table iterators */

SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
            (SCM proc, SCM init, SCM table),
	    "An iterator over hash-table elements.\n"
            "Accumulates and returns a result by applying PROC successively.\n"
            "The arguments to PROC are \"(key value prior-result)\" where key\n"
            "and value are successive pairs from the hash table TABLE, and\n"
            "prior-result is either INIT (for the first application of PROC)\n"
            "or the return value of the previous application of PROC.\n"
            "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
            "table into an a-list of key-value pairs.")
#define FUNC_NAME s_scm_hash_fold
{
  SCM_VALIDATE_PROC (1, proc);
  if (!SCM_HASHTABLE_P (table))
    SCM_VALIDATE_VECTOR (3, table);
  return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
}
#undef FUNC_NAME

static SCM
for_each_proc (void *proc, SCM handle)
{
  return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
}

SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
            (SCM proc, SCM table),
	    "An iterator over hash-table elements.\n"
            "Applies PROC successively on all hash table items.\n"
            "The arguments to PROC are \"(key value)\" where key\n"
            "and value are successive pairs from the hash table TABLE.")
#define FUNC_NAME s_scm_hash_for_each
{
  SCM_VALIDATE_PROC (1, proc);
  if (!SCM_HASHTABLE_P (table))
    SCM_VALIDATE_VECTOR (2, table);

  scm_internal_hash_for_each_handle (for_each_proc,
				     (void *) SCM_UNPACK (proc),
				     table);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
            (SCM proc, SCM table),
	    "An iterator over hash-table elements.\n"
            "Applies PROC successively on all hash table handles.")
#define FUNC_NAME s_scm_hash_for_each_handle
{
  scm_t_trampoline_1 call = scm_trampoline_1 (proc);
  SCM_ASSERT (call, proc, 1, FUNC_NAME);
  if (!SCM_HASHTABLE_P (table))
    SCM_VALIDATE_VECTOR (2, table);

  scm_internal_hash_for_each_handle (call,
				     (void *) SCM_UNPACK (proc),
				     table);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
map_proc (void *proc, SCM key, SCM data, SCM value)
{
  return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
}

SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
            (SCM proc, SCM table),
	    "An iterator over hash-table elements.\n"
            "Accumulates and returns as a list the results of applying PROC successively.\n"
            "The arguments to PROC are \"(key value)\" where key\n"
            "and value are successive pairs from the hash table TABLE.")
#define FUNC_NAME s_scm_hash_map_to_list
{
  SCM_VALIDATE_PROC (1, proc);
  if (!SCM_HASHTABLE_P (table))
    SCM_VALIDATE_VECTOR (2, table);
  return scm_internal_hash_fold (map_proc,
				 (void *) SCM_UNPACK (proc),
				 SCM_EOL,
				 table);
}
#undef FUNC_NAME

SCM
scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
{
  long i, n;
  SCM buckets, result = init;

  if (SCM_HASHTABLE_P (table))
    buckets = SCM_HASHTABLE_VECTOR (table);
  else
    buckets = table;

  n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  for (i = 0; i < n; ++i)
    {
      SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
      while (!scm_is_null (ls))
	{
	  if (!scm_is_pair (ls))
	    scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
	  handle = SCM_CAR (ls);
	  if (!scm_is_pair (handle))
	    scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
	  result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
	  ls = SCM_CDR (ls);
	}
    }

  return result;
}

/* The following redundant code is here in order to be able to support
   hash-for-each-handle.  An alternative would have been to replace
   this code and scm_internal_hash_fold above with a single
   scm_internal_hash_fold_handles, but we don't want to promote such
   an API. */

void
scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
{
  long i, n;
  SCM buckets;

  if (SCM_HASHTABLE_P (table))
    buckets = SCM_HASHTABLE_VECTOR (table);
  else
    buckets = table;

  n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  for (i = 0; i < n; ++i)
    {
      SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
      while (!scm_is_null (ls))
	{
	  if (!scm_is_pair (ls))
	    scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
	  handle = SCM_CAR (ls);
	  if (!scm_is_pair (handle))
	    scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
	  fn (closure, handle);
	  ls = SCM_CDR (ls);
	}
    }
}

void
scm_hashtab_prehistory ()
{
  scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
  scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
  scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
  scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
  scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
}

void
scm_init_hashtab ()
{
#include "libguile/hashtab.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H

/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

#include "libguile/__scm.h"

#include "weaks.h"

#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE

SCM_API scm_t_bits scm_tc16_hashtable;

#define SCM_HASHTABLE_P(x)	   SCM_SMOB_PREDICATE (scm_tc16_hashtable, x)
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
  SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
#define SCM_HASHTABLE_VECTOR(h)  SCM_SMOB_OBJECT (h)
#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_SMOB_OBJECT ((x), (v))
#define SCM_HASHTABLE(x)	   ((scm_t_hashtable *) SCM_SMOB_DATA_2 (x))
#define SCM_HASHTABLE_NEXT(x)	   SCM_SMOB_OBJECT_3 (x)
#define SCM_HASHTABLE_NEXTLOC(x)   SCM_SMOB_OBJECT_3_LOC (x)
#define SCM_SET_HASHTABLE_NEXT(x, n) SCM_SET_SMOB_OBJECT_3 ((x), (n))
#define SCM_HASHTABLE_FLAGS(x)	   (SCM_HASHTABLE (x)->flags)
#define SCM_HASHTABLE_WEAK_KEY_P(x) \
  (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR)
#define SCM_HASHTABLE_WEAK_VALUE_P(x) \
  (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CDR)
#define SCM_HASHTABLE_DOUBLY_WEAK_P(x)				\
  ((SCM_HASHTABLE_FLAGS (x)					\
    & (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR))	\
   == (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR))
#define SCM_HASHTABLE_WEAK_P(x)	   SCM_HASHTABLE_FLAGS (x)
#define SCM_HASHTABLE_N_ITEMS(x)   (SCM_HASHTABLE (x)->n_items)
#define SCM_SET_HASHTABLE_N_ITEMS(x, n)   (SCM_HASHTABLE (x)->n_items = n)
#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
#define SCM_HASHTABLE_DECREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)--)
#define SCM_HASHTABLE_UPPER(x)     (SCM_HASHTABLE (x)->upper)
#define SCM_HASHTABLE_LOWER(x)     (SCM_HASHTABLE (x)->lower)

#define SCM_HASHTABLE_N_BUCKETS(h) \
 SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (h))
#define SCM_HASHTABLE_BUCKET(h, i) \
  SCM_SIMPLE_VECTOR_REF (SCM_HASHTABLE_VECTOR (h), i)
#define SCM_SET_HASHTABLE_BUCKET(h, i, x) \
  SCM_SIMPLE_VECTOR_SET (SCM_HASHTABLE_VECTOR (h), i, x)

typedef struct scm_t_hashtable {
  int flags;			/* properties of table */
  unsigned long n_items;	/* number of items in table */
  unsigned long lower;		/* when to shrink */
  unsigned long upper;		/* when to grow */
  int size_index;		/* index into hashtable_size */
  int min_size_index;		/* minimum size_index */
  unsigned long (*hash_fn) ();  /* for rehashing after a GC. */
} scm_t_hashtable;

#if 0
typedef unsigned int scm_t_hash_fn (SCM obj, unsigned int d, void *closure);
typedef SCM scm_t_assoc_fn (SCM key, SCM alist, void *closure);
typedef SCM scm_t_delete_fn (SCM elt, SCM list);
#endif

SCM_API SCM scm_vector_to_hash_table (SCM vector);
SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
SCM_API SCM scm_make_weak_key_hash_table (SCM k);
SCM_API SCM scm_make_weak_value_hash_table (SCM k);
SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);

SCM_API SCM scm_hash_table_p (SCM h);
SCM_API SCM scm_weak_key_hash_table_p (SCM h);
SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);

SCM_API void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char*func_name);
SCM_API void scm_i_scan_weak_hashtables (void);

SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table);
SCM_API void scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table);
SCM_API SCM scm_hash_clear_x (SCM table);

SCM_API SCM scm_hashq_get_handle (SCM table, SCM obj);
SCM_API SCM scm_hashq_create_handle_x (SCM table, SCM obj, SCM init);
SCM_API SCM scm_hashq_ref (SCM table, SCM obj, SCM dflt);
SCM_API SCM scm_hashq_set_x (SCM table, SCM obj, SCM val);
SCM_API SCM scm_hashq_remove_x (SCM table, SCM obj);
SCM_API SCM scm_hashv_get_handle (SCM table, SCM obj);
SCM_API SCM scm_hashv_create_handle_x (SCM table, SCM obj, SCM init);
SCM_API SCM scm_hashv_ref (SCM table, SCM obj, SCM dflt);
SCM_API SCM scm_hashv_set_x (SCM table, SCM obj, SCM val);
SCM_API SCM scm_hashv_remove_x (SCM table, SCM obj);
SCM_API SCM scm_hash_get_handle (SCM table, SCM obj);
SCM_API SCM scm_hash_create_handle_x (SCM table, SCM obj, SCM init);
SCM_API SCM scm_hash_ref (SCM table, SCM obj, SCM dflt);
SCM_API SCM scm_hash_set_x (SCM table, SCM obj, SCM val);
SCM_API SCM scm_hash_remove_x (SCM table, SCM obj);
SCM_API SCM scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj);
SCM_API SCM scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init);
SCM_API SCM scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt);
SCM_API SCM scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val);
SCM_API SCM scm_hashx_remove_x (SCM hash, SCM assoc, SCM table, SCM obj);
SCM_API SCM scm_hash_fold (SCM proc, SCM init, SCM hash);
SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
SCM_API void scm_hashtab_prehistory (void);
SCM_API void scm_init_hashtab (void);

#endif  /* SCM_HASHTAB_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/