code:
/* classes: h_files */

#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H

/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 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
 */

#include <gmp.h>

#include "libguile/__scm.h"
#include "libguile/print.h"

#if SCM_HAVE_FLOATINGPOINT_H
# include <floatingpoint.h>
#endif

#if SCM_HAVE_IEEEFP_H
# include <ieeefp.h>
#endif

#if SCM_HAVE_NAN_H
# if defined (SCO)
#   define _IEEE 1
# endif
# include <nan.h>
# if defined (SCO)
#   undef _IEEE
# endif
#endif /* SCM_HAVE_NAN_H */

/* Immediate Numbers, also known as fixnums
 *
 * Inums are exact integer data that fits within an SCM word.  */

/* SCM_T_SIGNED_MAX is                 (- (expt 2 n) 1),
 * SCM_MOST_POSITIVE_FIXNUM should be  (- (expt 2 (- n 2)) 1)
 * which is the same as                (/ (- (expt 2 n) 4) 4)
 */

#define SCM_I_FIXNUM_BIT         (SCM_LONG_BIT - 2)
#define SCM_MOST_POSITIVE_FIXNUM ((SCM_T_SIGNED_BITS_MAX-3)/4)
#define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1)

/* SCM_SRS is signed right shift */
#if (-1 == (((-1) << 2) + 2) >> 2)
# define SCM_SRS(x, y) ((x) >> (y))
#else
# define SCM_SRS(x, y) ((x) < 0 ? ~((~(x)) >> (y)) : ((x) >> (y)))
#endif /* (-1 == (((-1) << 2) + 2) >> 2) */

#define SCM_I_INUMP(x)	(2 & SCM_UNPACK (x))
#define SCM_I_NINUMP(x) (!SCM_I_INUMP (x))
#define SCM_I_MAKINUM(x) \
  (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int))
#define SCM_I_INUM(x)   (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2))

/* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */
#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
#define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n))

/* A name for 0. */
#define SCM_INUM0 (SCM_I_MAKINUM (0))

/* SCM_MAXEXP is the maximum double precision exponent
 * SCM_FLTMAX is less than or scm_equal the largest single precision float
 */

#if SCM_HAVE_STDC_HEADERS
# ifndef GO32
#  include <float.h>
#  ifdef __MINGW32__
#   define copysign _copysign
#   define finite _finite
#  endif /* __MINGW32__ */
# endif /* ndef GO32 */
#endif /* def STDC_HEADERS */

#ifdef DBL_MAX_10_EXP
# define SCM_MAXEXP DBL_MAX_10_EXP
#else
# define SCM_MAXEXP 308		/* IEEE doubles */
#endif /* def DBL_MAX_10_EXP */

#ifdef FLT_MAX
# define SCM_FLTMAX FLT_MAX
#else
# define SCM_FLTMAX 1e+23
#endif /* def FLT_MAX */

/* SCM_INTBUFLEN is the maximum number of characters neccessary for
 * the printed or scm_string representation of an scm_t_intmax in
 * radix 2.  The buffer passed to scm_iint2str and scm_iuint2str must
 * be of this size, for example.
 */
#define SCM_INTBUFLEN (5 + SCM_CHAR_BIT*sizeof(scm_t_intmax))

/* Numbers
 */

/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only
 * differ in one bit: This way, checking if an object is an inexact number can
 * be done quickly (using the TYP16S macro).  */

/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP
 * and SCM_NUMP)  */
#define scm_tc16_big		(scm_tc7_number + 1 * 256L)
#define scm_tc16_real           (scm_tc7_number + 2 * 256L)
#define scm_tc16_complex        (scm_tc7_number + 3 * 256L)
#define scm_tc16_fraction       (scm_tc7_number + 4 * 256L)

#define SCM_INEXACTP(x) \
  (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real)
#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex)

#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
#define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x))
#define SCM_COMPLEX_REAL(x) (SCM_COMPLEX_MEM (x)->real)
#define SCM_COMPLEX_IMAG(x) (SCM_COMPLEX_MEM (x)->imag)

/* Each bignum is just an mpz_t stored in a double cell starting at word 1. */
#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
#define SCM_BIGP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_big)

#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
#define SCM_NUMP(x) (!SCM_IMP(x) \
  && (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \
      || ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number)))
/* 0xfcff (#b1100) for 0 free, 1 big, 2 real, 3 complex, then 0xfbff (#b1011) for 4 fraction */

#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))

typedef struct scm_t_double
{
  SCM type;
  SCM pad;
  double real;
} scm_t_double;

typedef struct scm_t_complex
{
  double real;
  double imag;
} scm_t_complex;

SCM_API SCM scm_exact_p (SCM x);
SCM_API SCM scm_odd_p (SCM n);
SCM_API SCM scm_even_p (SCM n);
SCM_API SCM scm_inf_p (SCM n);
SCM_API SCM scm_nan_p (SCM n);
SCM_API SCM scm_inf (void);
SCM_API SCM scm_nan (void);
SCM_API SCM scm_abs (SCM x);
SCM_API SCM scm_quotient (SCM x, SCM y);
SCM_API SCM scm_remainder (SCM x, SCM y);
SCM_API SCM scm_modulo (SCM x, SCM y);
SCM_API SCM scm_gcd (SCM x, SCM y);
SCM_API SCM scm_lcm (SCM n1, SCM n2);
SCM_API SCM scm_logand (SCM n1, SCM n2);
SCM_API SCM scm_logior (SCM n1, SCM n2);
SCM_API SCM scm_logxor (SCM n1, SCM n2);
SCM_API SCM scm_logtest (SCM n1, SCM n2);
SCM_API SCM scm_logbit_p (SCM n1, SCM n2);
SCM_API SCM scm_lognot (SCM n);
SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m);
SCM_API SCM scm_integer_expt (SCM z1, SCM z2);
SCM_API SCM scm_ash (SCM n, SCM cnt);
SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end);
SCM_API SCM scm_logcount (SCM n);
SCM_API SCM scm_integer_length (SCM n);

SCM_API size_t scm_iint2str (scm_t_intmax num, int rad, char *p);
SCM_API size_t scm_iuint2str (scm_t_uintmax num, int rad, char *p);
SCM_API SCM scm_number_to_string (SCM x, SCM radix);
SCM_API int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate);
SCM_API int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate);
SCM_API int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate);
SCM_API SCM scm_c_locale_stringn_to_number (const char *mem, size_t len,
					    unsigned int radix);
SCM_API SCM scm_string_to_number (SCM str, SCM radix);
SCM_API SCM scm_bigequal (SCM x, SCM y);
SCM_API SCM scm_real_equalp (SCM x, SCM y);
SCM_API SCM scm_complex_equalp (SCM x, SCM y);
SCM_API SCM scm_number_p (SCM x);
SCM_API SCM scm_complex_p (SCM x);
SCM_API SCM scm_real_p (SCM x);
SCM_API SCM scm_rational_p (SCM z);
SCM_API SCM scm_integer_p (SCM x);
SCM_API SCM scm_inexact_p (SCM x);
SCM_API SCM scm_num_eq_p (SCM x, SCM y);
SCM_API SCM scm_less_p (SCM x, SCM y);
SCM_API SCM scm_gr_p (SCM x, SCM y);
SCM_API SCM scm_leq_p (SCM x, SCM y);
SCM_API SCM scm_geq_p (SCM x, SCM y);
SCM_API SCM scm_zero_p (SCM z);
SCM_API SCM scm_positive_p (SCM x);
SCM_API SCM scm_negative_p (SCM x);
SCM_API SCM scm_max (SCM x, SCM y);
SCM_API SCM scm_min (SCM x, SCM y);
SCM_API SCM scm_sum (SCM x, SCM y);
SCM_API SCM scm_oneplus (SCM x);
SCM_API SCM scm_difference (SCM x, SCM y);
SCM_API SCM scm_oneminus (SCM x);
SCM_API SCM scm_product (SCM x, SCM y);
SCM_API SCM scm_divide (SCM x, SCM y);
SCM_API SCM scm_floor (SCM x);
SCM_API SCM scm_ceiling (SCM x);
SCM_API double scm_asinh (double x);
SCM_API double scm_acosh (double x);
SCM_API double scm_atanh (double x);
SCM_API double scm_c_truncate (double x);
SCM_API double scm_c_round (double x);
SCM_API SCM scm_truncate_number (SCM x);
SCM_API SCM scm_round_number (SCM x);
SCM_API SCM scm_sys_expt (SCM z1, SCM z2);
SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
SCM_API SCM scm_make_rectangular (SCM z1, SCM z2);
SCM_API SCM scm_make_polar (SCM z1, SCM z2);
SCM_API SCM scm_real_part (SCM z);
SCM_API SCM scm_imag_part (SCM z);
SCM_API SCM scm_magnitude (SCM z);
SCM_API SCM scm_angle (SCM z);
SCM_API SCM scm_exact_to_inexact (SCM z);
SCM_API SCM scm_inexact_to_exact (SCM z);
SCM_API SCM scm_trunc (SCM x);
SCM_API SCM scm_log (SCM z);
SCM_API SCM scm_log10 (SCM z);
SCM_API SCM scm_exp (SCM z);
SCM_API SCM scm_sqrt (SCM z);

/* bignum internal functions */
SCM_API SCM scm_i_mkbig (void);
SCM_API SCM scm_i_normbig (SCM x);
SCM_API int scm_i_bigcmp (SCM a, SCM b);
SCM_API SCM scm_i_dbl2big (double d);
SCM_API SCM scm_i_dbl2num (double d);
SCM_API double scm_i_big2dbl (SCM b);
SCM_API SCM scm_i_long2big (long n);
SCM_API SCM scm_i_ulong2big (unsigned long n);
SCM_API SCM scm_i_clonebig (SCM src_big, int same_sign_p);

/* ratio functions */
SCM_API SCM scm_rationalize (SCM x, SCM err);
SCM_API SCM scm_numerator (SCM z);
SCM_API SCM scm_denominator (SCM z);

/* fraction internal functions */
SCM_API double scm_i_fraction2double (SCM z);
SCM_API SCM scm_i_fraction_equalp (SCM x, SCM y);
SCM_API int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate);

/* general internal functions */
SCM_API void scm_i_print_double (double val, SCM port);
SCM_API void scm_i_print_complex (double real, double imag, SCM port);

/* conversion functions for integers */

SCM_API int scm_is_integer (SCM val);
SCM_API int scm_is_signed_integer (SCM val,
				   scm_t_intmax min, scm_t_intmax max);
SCM_API int scm_is_unsigned_integer (SCM val,
				     scm_t_uintmax min, scm_t_uintmax max);

SCM_API SCM scm_from_signed_integer (scm_t_intmax val);
SCM_API SCM scm_from_unsigned_integer (scm_t_uintmax val);

SCM_API scm_t_intmax scm_to_signed_integer (SCM val,
					    scm_t_intmax min,
					    scm_t_intmax max);
SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val,
					       scm_t_uintmax min,
					       scm_t_uintmax max);

SCM_API scm_t_int8   scm_to_int8     (SCM x);
SCM_API SCM          scm_from_int8   (scm_t_int8 x);

SCM_API scm_t_uint8  scm_to_uint8    (SCM x);
SCM_API SCM          scm_from_uint8  (scm_t_uint8 x);

SCM_API scm_t_int16  scm_to_int16    (SCM x);
SCM_API SCM          scm_from_int16  (scm_t_int16 x);

SCM_API scm_t_uint16 scm_to_uint16   (SCM x);
SCM_API SCM          scm_from_uint16 (scm_t_uint16 x);

SCM_API scm_t_int32  scm_to_int32    (SCM x);
SCM_API SCM          scm_from_int32  (scm_t_int32 x);

SCM_API scm_t_uint32 scm_to_uint32   (SCM x);
SCM_API SCM          scm_from_uint32 (scm_t_uint32 x);

SCM_API scm_t_int64  scm_to_int64    (SCM x);
SCM_API SCM          scm_from_int64  (scm_t_int64 x);

SCM_API scm_t_uint64 scm_to_uint64   (SCM x);
SCM_API SCM          scm_from_uint64 (scm_t_uint64 x);

SCM_API void scm_to_mpz (SCM x, mpz_t rop);
SCM_API SCM  scm_from_mpz (mpz_t rop);

/* The conversion functions for other types are aliased to the
   appropriate ones from above.  We pick the right one based on the
   size of the type.

   Not each and every possibility is covered by the code below, and
   while it is trivial to complete the tests, it might be better to
   just test for the 'sane' possibilities.  When one of the tests
   below fails, chances are good that some silent assumption somewhere
   else will also fail.
*/

#if SCM_SIZEOF_CHAR == 1
#define scm_to_schar   scm_to_int8
#define scm_from_schar scm_from_int8
#define scm_to_uchar   scm_to_uint8
#define scm_from_uchar scm_from_uint8
#if CHAR_MIN == 0
#define scm_to_char    scm_to_uint8
#define scm_from_char  scm_from_uint8
#else
#define scm_to_char    scm_to_int8
#define scm_from_char  scm_from_int8
#endif
#else
#error sizeof(char) is not 1.
#endif

#if SCM_SIZEOF_SHORT == 1
#define scm_to_short    scm_to_int8
#define scm_from_short  scm_from_int8
#define scm_to_ushort   scm_to_uint8
#define scm_from_ushort scm_from_uint8
#else
#if SCM_SIZEOF_SHORT == 2
#define scm_to_short    scm_to_int16
#define scm_from_short  scm_from_int16
#define scm_to_ushort   scm_to_uint16
#define scm_from_ushort scm_from_uint16
#else
#if SCM_SIZEOF_SHORT == 4
#define scm_to_short    scm_to_int32
#define scm_from_short  scm_from_int32
#define scm_to_ushort   scm_to_uint32
#define scm_from_ushort scm_from_uint32
#else
#error sizeof(short) is not 1, 2, or 4.
#endif
#endif
#endif

#if SCM_SIZEOF_INT == 4
#define scm_to_int    scm_to_int32
#define scm_from_int  scm_from_int32
#define scm_to_uint   scm_to_uint32
#define scm_from_uint scm_from_uint32
#else
#if SCM_SIZEOF_INT == 8
#define scm_to_int    scm_to_int64
#define scm_from_int  scm_from_int64
#define scm_to_uint   scm_to_uint64
#define scm_from_uint scm_from_uint64
#else
#error sizeof(int) is not 4 or 8.
#endif
#endif

#if SCM_SIZEOF_LONG == 4
#define scm_to_long    scm_to_int32
#define scm_from_long  scm_from_int32
#define scm_to_ulong   scm_to_uint32
#define scm_from_ulong scm_from_uint32
#else
#if SCM_SIZEOF_LONG == 8
#define scm_to_long    scm_to_int64
#define scm_from_long  scm_from_int64
#define scm_to_ulong   scm_to_uint64
#define scm_from_ulong scm_from_uint64
#else
#error sizeof(long) is not 4 or 8.
#endif
#endif

#if SCM_SIZEOF_INTMAX == 4
#define scm_to_intmax    scm_to_int32
#define scm_from_intmax  scm_from_int32
#define scm_to_uintmax   scm_to_uint32
#define scm_from_uintmax scm_from_uint32
#else
#if SCM_SIZEOF_INTMAX == 8
#define scm_to_intmax    scm_to_int64
#define scm_from_intmax  scm_from_int64
#define scm_to_uintmax   scm_to_uint64
#define scm_from_uintmax scm_from_uint64
#else
#error sizeof(scm_t_intmax) is not 4 or 8.
#endif
#endif

#if SCM_SIZEOF_LONG_LONG == 0
#else
#if SCM_SIZEOF_LONG_LONG == 8
#define scm_to_long_long    scm_to_int64
#define scm_from_long_long  scm_from_int64
#define scm_to_ulong_long   scm_to_uint64
#define scm_from_ulong_long scm_from_uint64
#else
#error sizeof(long long) is not 8.
#endif
#endif

#if SCM_SIZEOF_SIZE_T == 4
#define scm_to_ssize_t    scm_to_int32
#define scm_from_ssize_t  scm_from_int32
#define scm_to_size_t     scm_to_uint32
#define scm_from_size_t   scm_from_uint32
#else
#if SCM_SIZEOF_SIZE_T == 8
#define scm_to_ssize_t    scm_to_int64
#define scm_from_ssize_t  scm_from_int64
#define scm_to_size_t     scm_to_uint64
#define scm_from_size_t   scm_from_uint64
#else
#error sizeof(size_t) is not 4 or 8.
#endif
#endif

/* conversion functions for double */

SCM_API int scm_is_real (SCM val);
SCM_API int scm_is_rational (SCM val);
SCM_API double scm_to_double (SCM val);
SCM_API SCM scm_from_double (double val);

/* conversion functions for complex */

SCM_API int scm_is_complex (SCM val);
SCM_API SCM scm_c_make_rectangular (double re, double im);
SCM_API SCM scm_c_make_polar (double mag, double ang);
SCM_API double scm_c_real_part (SCM z);
SCM_API double scm_c_imag_part (SCM z);
SCM_API double scm_c_magnitude (SCM z);
SCM_API double scm_c_angle (SCM z);

SCM_API int scm_is_number (SCM val);

SCM_API void scm_init_numbers (void);

#endif  /* SCM_NUMBERS_H */

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

license: unknown


code:
/* Copyright (C) 1995,1996,1999,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
 */

/* This file and objects.h contains those minimal pieces of the Guile
 * Object Oriented Programming System which need to be included in
 * libguile.  See the comments in objects.h.
 */

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

#include "libguile/_scm.h"

#include "libguile/struct.h"
#include "libguile/procprop.h"
#include "libguile/chars.h"
#include "libguile/keywords.h"
#include "libguile/smob.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"

#include "libguile/validate.h"
#include "libguile/objects.h"
#include "libguile/goops.h"

SCM scm_metaclass_standard;
SCM scm_metaclass_operator;

/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
 * formats:
 *
 * Format #1:
 * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
 *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 *   GF)
 *
 * Format #2:
 * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
 *   #((TYPE1 ... ENV FORMALS FORM ...) ...)
 *   GF)
 *
 * ARGS is either a list of expressions, in which case they
 * are interpreted as the arguments of an application, or
 * a non-pair, which is interpreted as a single expression
 * yielding all arguments.
 *
 * SCM_IM_DISPATCH expressions in generic functions always
 * have ARGS = the symbol `args' or the iloc #@0-0.
 *
 * Need FORMALS in order to support varying arity.  This
 * also avoids the need for renaming of bindings.
 *
 * We should probably not complicate this mechanism by
 * introducing "optimizations" for getters and setters or
 * primitive methods.  Getters and setter will normally be
 * compiled into @slot-[ref|set!] or a procedure call.
 * They rely on the dispatch performed before executing
 * the code which contains them.
 *
 * We might want to use a more efficient representation of
 * this form in the future, perhaps after we have introduced
 * low-level support for syntax-case macros.
 */

SCM
scm_mcache_lookup_cmethod (SCM cache, SCM args)
{
  unsigned long i, mask, n, end;
  SCM ls, methods, z = SCM_CDDR (cache);
  n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
  methods = SCM_CADR (z);

  if (scm_is_simple_vector (methods))
    {
      /* cache format #1: prepare for linear search */
      mask = -1;
      i = 0;
      end = SCM_SIMPLE_VECTOR_LENGTH (methods);
    }
  else
    {
      /* cache format #2: compute a hash value */
      unsigned long hashset = scm_to_ulong (methods);
      long j = n;
      z = SCM_CDDR (z);
      mask = scm_to_ulong (SCM_CAR (z));
      methods = SCM_CADR (z);
      i = 0;
      ls = args;
      if (!scm_is_null (ls))
	do
	  {
	    i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
		 [scm_si_hashsets + hashset];
	    ls = SCM_CDR (ls);
	  }
	while (j-- && !scm_is_null (ls));
      i &= mask;
      end = i;
    }

  /* Search for match  */
  do
    {
      long j = n;
      z = SCM_SIMPLE_VECTOR_REF (methods, i);
      ls = args; /* list of arguments */
      if (!scm_is_null (ls))
	do
	  {
	    /* More arguments than specifiers => CLASS != ENV */
	    if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
	      goto next_method;
	    ls = SCM_CDR (ls);
	    z = SCM_CDR (z);
	  }
	while (j-- && !scm_is_null (ls));
      /* Fewer arguments than specifiers => CAR != ENV */
      if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
	return z;
    next_method:
      i = (i + 1) & mask;
    } while (i != end);
  return SCM_BOOL_F;
}

SCM
scm_mcache_compute_cmethod (SCM cache, SCM args)
{
  SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
  if (scm_is_false (cmethod))
    /* No match - memoize */
    return scm_memoize_method (cache, args);
  return cmethod;
}

SCM
scm_apply_generic (SCM gf, SCM args)
{
  SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
  return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
			SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
					args,
					SCM_CMETHOD_ENV (cmethod)));
}

SCM
scm_call_generic_0 (SCM gf)
{
  return scm_apply_generic (gf, SCM_EOL);
}

SCM
scm_call_generic_1 (SCM gf, SCM a1)
{
  return scm_apply_generic (gf, scm_list_1 (a1));
}

SCM
scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
{
  return scm_apply_generic (gf, scm_list_2 (a1, a2));
}

SCM
scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
{
  return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
}

SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is an entity.")
#define FUNC_NAME s_scm_entity_p
{
  return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is an operator.")
#define FUNC_NAME s_scm_operator_p
{
  return scm_from_bool(SCM_STRUCTP (obj)
                  && SCM_I_OPERATORP (obj)
                  && !SCM_I_ENTITYP (obj));
}
#undef FUNC_NAME

/* XXX - What code requires the object procedure to be only of certain
         types? */

SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
	    (SCM proc),
	    "Return @code{#t} iff @var{proc} is a procedure that can be used "
	    "with @code{set-object-procedure}.  It is always valid to use "
            "a closure constructed by @code{lambda}.")
#define FUNC_NAME s_scm_valid_object_procedure_p
{
  if (SCM_IMP (proc))
    return SCM_BOOL_F;
  switch (SCM_TYP7 (proc))
    {
    default:
      return SCM_BOOL_F;
    case scm_tcs_closures:
    case scm_tc7_subr_1:
    case scm_tc7_subr_2:
    case scm_tc7_subr_3:
    case scm_tc7_lsubr_2:
      return SCM_BOOL_T;
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
            (SCM obj, SCM proc),
	    "Set the object procedure of @var{obj} to @var{proc}.\n"
	    "@var{obj} must be either an entity or an operator.")
#define FUNC_NAME s_scm_set_object_procedure_x
{
  SCM_ASSERT (SCM_STRUCTP (obj)
	      && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
		  || (SCM_I_ENTITYP (obj)
		      && !(SCM_OBJ_CLASS_FLAGS (obj)
			   & SCM_CLASSF_PURE_GENERIC))),
	      obj,
	      SCM_ARG1,
              FUNC_NAME);
  SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
  if (SCM_I_ENTITYP (obj))
    SCM_SET_ENTITY_PROCEDURE (obj, proc);
  else
    SCM_OPERATOR_CLASS (obj)->procedure = proc;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
            (SCM obj),
	    "Return the object procedure of @var{obj}. @var{obj} must be\n"
	    "an entity or an operator.")
#define FUNC_NAME s_scm_object_procedure
{
  SCM_ASSERT (SCM_STRUCTP (obj)
	      && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
		  || SCM_I_ENTITYP (obj)),
	      obj, SCM_ARG1, FUNC_NAME);
  return (SCM_I_ENTITYP (obj)
	  ? SCM_ENTITY_PROCEDURE (obj)
	  : SCM_OPERATOR_CLASS (obj)->procedure);
}
#undef FUNC_NAME
#endif /* GUILE_DEBUG */

/* The following procedures are not a part of Goops but a minimal
 * object system built upon structs.  They are here for those who
 * want to implement their own object system.
 */

SCM
scm_i_make_class_object (SCM meta,
			 SCM layout_string,
			 unsigned long flags)
{
  SCM c;
  SCM layout = scm_make_struct_layout (layout_string);
  c = scm_make_struct (meta,
		       SCM_INUM0,
		       scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
  SCM_SET_CLASS_FLAGS (c, flags);
  return c;
}

SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
            (SCM metaclass, SCM layout),
	    "Create a new class object of class @var{metaclass}, with the\n"
	    "slot layout specified by @var{layout}.")
#define FUNC_NAME s_scm_make_class_object
{
  unsigned long flags = 0;
  SCM_VALIDATE_STRUCT (1, metaclass);
  SCM_VALIDATE_STRING (2, layout);
  if (scm_is_eq (metaclass, scm_metaclass_operator))
    flags = SCM_CLASSF_OPERATOR;
  return scm_i_make_class_object (metaclass, layout, flags);
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
            (SCM class, SCM layout),
	    "Create a subclass object of @var{class}, with the slot layout\n"
	    "specified by @var{layout}.")
#define FUNC_NAME s_scm_make_subclass_object
{
  SCM pl;
  SCM_VALIDATE_STRUCT (1, class);
  SCM_VALIDATE_STRING (2, layout);
  pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
  pl = scm_symbol_to_string (pl);
  return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
				  scm_string_append (scm_list_2 (pl, layout)),
				  SCM_CLASS_FLAGS (class));
}
#undef FUNC_NAME

void
scm_init_objects ()
{
  SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
  SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
				   scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));

  SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
  SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
				   scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));

  SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
  SCM el = scm_make_struct_layout (es);
  SCM et = scm_make_struct (mt, SCM_INUM0,
			    scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));

  scm_c_define ("<class>", mt);
  scm_metaclass_standard = mt;
  scm_c_define ("<operator-class>", ot);
  scm_metaclass_operator = ot;
  SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
  SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
  scm_c_define ("<entity>", et);

#include "libguile/objects.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_OBJECTS_H
#define SCM_OBJECTS_H

/* Copyright (C) 1996,1999,2000,2001, 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 file and objects.c contains those minimal pieces of the Guile
 * Object Oriented Programming System which need to be included in
 * libguile.
 *
 * {Objects and structs}
 *
 * Objects are currently based upon structs.  Although the struct
 * implementation will change thoroughly in the future, objects will
 * still be based upon structs.
 */

#include "libguile/__scm.h"
#include "libguile/struct.h"

/* {Class flags}
 *
 * These are used for efficient identification of instances of a
 * certain class or its subclasses when traversal of the inheritance
 * graph would be too costly.
 */
#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class) [scm_struct_i_flags])
#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_DATA (obj) [scm_struct_i_flags])
#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
#define SCM_CLASSF_MASK SCM_STRUCTF_MASK

#define SCM_CLASSF_ENTITY	SCM_STRUCTF_ENTITY
/* Operator classes need to be identified in the evaluator.
   (Entities also have SCM_CLASSF_OPERATOR set in their vtable.) */
#define SCM_CLASSF_OPERATOR	(1L << 29)

#define SCM_I_OPERATORP(obj)\
	((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
#define SCM_OPERATOR_CLASS(obj)\
((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
#define SCM_OBJ_OPERATOR_CLASS(obj)\
((struct scm_metaclass_operator *) SCM_STRUCT_VTABLE_DATA (obj))
#define SCM_OPERATOR_PROCEDURE(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->procedure)
#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter)

#define SCM_I_ENTITYP(obj)\
	((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
#define SCM_ENTITY_PROCEDURE(obj) \
        (SCM_PACK (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure]))
#define SCM_SET_ENTITY_PROCEDURE(obj, v) \
        (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v))
#define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]))
#define SCM_SET_ENTITY_SETTER(obj, v) \
        (SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v))

#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
#define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \
  (SCM_STRUCT_DATA (c)[scm_struct_i_size] \
   = (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s)

/* {Operator classes}
 *
 * Instances of operator classes can work as operators, i. e., they
 * can be applied to arguments just as if they were ordinary
 * procedures.
 *
 * For instances of operator classes, the procedures to be applied are
 * stored in four dedicated slots in the associated class object.
 * Which one is selected depends on the number of arguments in the
 * application.
 *
 * If zero arguments are passed, the first will be selected.
 * If one argument is passed, the second will be selected.
 * If two arguments are passed, the third will be selected.
 * If three or more arguments are passed, the fourth will be selected.
 *
 * This is complicated and may seem gratuitous but has to do with the
 * architecture of the evaluator.  Using only one procedure would
 * result in a great deal less efficient application, loss of
 * tail-recursion and would be difficult to reconcile with the
 * debugging evaluator.
 *
 * Also, using this "forked" application in low-level code has the
 * advantage of speeding up some code.  An example is method dispatch
 * for generic operators applied to few arguments.  On the user level,
 * the "forked" application will be hidden by mechanisms in the GOOPS
 * package.
 *
 * Operator classes have the metaclass <operator-metaclass>.
 *
 * An example of an operator class is the class <tk-command>.
 */
#define SCM_METACLASS_STANDARD_LAYOUT ""
struct scm_metaclass_standard {
  SCM layout;
  SCM vcell;
  SCM vtable;
  SCM print;
};

#define SCM_METACLASS_OPERATOR_LAYOUT "popo"
struct scm_metaclass_operator {
  SCM layout;
  SCM vcell;
  SCM vtable;
  SCM print;
  SCM procedure;
  SCM setter;
};

/* {Entity classes}
 *
 * For instances of entity classes (entities), the procedures to be
 * applied are stored in the instance itself rather than in the class
 * object as is the case for instances of operator classes (see above).
 *
 * An example of an entity class is the class of generic methods.
 */
#define SCM_ENTITY_LAYOUT ""

/* {Interface to Goops}
 *
 * The evaluator contains a multi-method dispatch mechanism.
 * This interface is used by that mechanism and during creation of
 * smob and struct classes.
 */

/* Internal representation of Goops objects. */
#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
#define SCM_CLASSF_GOOPS_VALID  (0x080 << 20)
#define SCM_CLASSF_GOOPS        (0x100 << 20)
#define scm_si_redefined         5
#define scm_si_hashsets          6
#define SCM_CLASS_OF(x)         SCM_STRUCT_VTABLE (x)
#define SCM_OBJ_CLASS_REDEF(x)  (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined]))

typedef struct scm_effective_slot_definition {
  SCM name;
  long location;
  SCM init_value;
  SCM (*get) (SCM obj, SCM slotdef);
  SCM (*set) (SCM obj, SCM slotdef, SCM value);
} scm_effective_slot_definition;

#define SCM_ESLOTDEF(x) ((scm_effective_slot_definition *) SCM_CDR (x))

#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
#define SCM_CMETHOD_ENV(cmethod)  SCM_CAR (cmethod)

/* Port classes */
#define SCM_IN_PCLASS_INDEX    0x000
#define SCM_OUT_PCLASS_INDEX   0x100
#define SCM_INOUT_PCLASS_INDEX 0x200

/* Plugin proxy classes for basic types. */
SCM_API SCM scm_metaclass_standard;
SCM_API SCM scm_metaclass_operator;

/* Goops functions. */
SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
SCM_API void scm_i_inherit_applicable (SCM c);
SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
SCM_API void scm_change_object_class (SCM, SCM, SCM);
SCM_API SCM scm_memoize_method (SCM x, SCM args);

SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args);
/* The following are declared in __scm.h
SCM_API SCM scm_call_generic_0 (SCM gf);
SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
SCM_API SCM scm_entity_p (SCM obj);
SCM_API SCM scm_operator_p (SCM obj);
SCM_API SCM scm_valid_object_procedure_p (SCM proc);
SCM_API SCM scm_set_object_procedure_x (SCM obj, SCM proc);
#ifdef GUILE_DEBUG
SCM_API SCM scm_object_procedure (SCM obj);
#endif
SCM_API SCM scm_make_class_object (SCM metaclass, SCM layout);
SCM_API SCM scm_make_subclass_object (SCM c, SCM layout);

SCM_API SCM scm_i_make_class_object (SCM metaclass, SCM layout_string,
				     unsigned long flags);
SCM_API void scm_init_objects (void);

#endif  /* SCM_OBJECTS_H */

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


code:
/*	Copyright (C) 1995,1996, 2000, 2001, 2003, 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/async.h"
#include "libguile/hashtab.h"
#include "libguile/alist.h"
#include "libguile/root.h"
#include "libguile/weaks.h"

#include "libguile/objprop.h"

/* {Object Properties}
 */

SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0,
           (SCM obj),
	    "Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_object_properties
{
  return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
	    (SCM obj, SCM alist),
	    "Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
  SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, alist);
  SCM_SETCDR (handle, alist);
  return alist;
}
#undef FUNC_NAME

SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0,
           (SCM obj, SCM key),
	    "Return the property of @var{obj} with name @var{key}.")
#define FUNC_NAME s_scm_object_property
{
  SCM assoc;
  assoc = scm_assq (key, scm_object_properties (obj));
  return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
	    (SCM obj, SCM key, SCM value),
	    "In @var{obj}'s property list, set the property named @var{key}\n"
	    "to @var{value}.")
#define FUNC_NAME s_scm_set_object_property_x
{
  SCM h;
  SCM assoc;
  h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
  SCM_CRITICAL_SECTION_START;
  assoc = scm_assq (key, SCM_CDR (h));
  if (SCM_NIMP (assoc))
    SCM_SETCDR (assoc, value);
  else
    {
      assoc = scm_acons (key, value, SCM_CDR (h));
      SCM_SETCDR (h, assoc);
    }
  SCM_CRITICAL_SECTION_END;
  return value;
}
#undef FUNC_NAME

void
scm_init_objprop ()
{
  scm_object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/objprop.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_OBJPROP_H
#define SCM_OBJPROP_H

/* Copyright (C) 1995,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_object_properties (SCM obj);
SCM_API SCM scm_set_object_properties_x (SCM obj, SCM plist);
SCM_API SCM scm_object_property (SCM obj, SCM key);
SCM_API SCM scm_set_object_property_x (SCM obj, SCM key, SCM val);
SCM_API void scm_init_objprop (void);

#endif  /* SCM_OBJPROP_H */

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


code:
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation
 *
 * 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/mallocs.h"
#include "libguile/strings.h"
#include "libguile/lang.h"

#include "libguile/options.h"

/* {Run-time options}
 *
 * This is the basic interface for low-level configuration of the
 * Guile library.  It is used for configuring the reader, evaluator,
 * printer and debugger.
 *
 * Motivation:
 *
 * 1. Altering option settings can have side effects.
 * 2. Option values can be stored in native format.
 *    (Important for efficiency in, e. g., the evaluator.)
 * 3. Doesn't use up name space.
 * 4. Options can be naturally grouped => ease of use.
 */

/* scm_options is the core of all options interface procedures.
 *
 * Some definitions:
 *
 * Run time options in Guile are arranged in groups.  Each group
 * affects a certain aspect of the behaviour of the library.
 *
 * An "options interface procedure" manages one group of options.  It
 * can be used to check or set options, or to get documentation for
 * all options of a group.  The options interface procedure is not
 * intended to be called directly by the user.  The user should
 * instead call
 *
 *   (<group>-options)
 *   (<group>-options 'help)
 *   (<group>-options 'full)
 *
 * to display current option settings (The second version also
 * displays documentation.  The third version also displays
 * information about programmer's options.), and
 *
 *   (<group>-enable  '<option-symbol>)
 *   (<group>-disable '<option-symbol>)
 *   (<group>-set! <option-symbol> <value>)
 *   (<group>-options <option setting>)
 *
 * to alter the state of an option  (The last version sets all
 * options according to <option setting>.) where <group> is the name
 * of the option group.
 *
 * An "option setting" represents the state of all low-level options
 * managed by one options interface procedure.  It is a list of
 * single symbols and symbols followed by a value.
 *
 * For boolean options, the presence of the symbol of that option in
 * the option setting indicates a true value.  If the symbol isn't a
 * member of the option setting this represents a false value.
 *
 * Other options are represented by a symbol followed by the value.
 *
 * If scm_options is called without arguments, the current option
 * setting is returned.  If the argument is an option setting, options
 * are altered and the old setting is returned.  If the argument isn't
 * a list, a list of sublists is returned, where each sublist contains
 * option name, value and documentation string.
 */

SCM_SYMBOL (scm_yes_sym, "yes");
SCM_SYMBOL (scm_no_sym, "no");

static SCM protected_objects = SCM_EOL;

/* Return a list of the current option setting.  The format of an
 * option setting is described in the above documentation.  */
static SCM
get_option_setting (const scm_t_option options[], unsigned int n)
{
  unsigned int i;
  SCM ls = SCM_EOL;
  for (i = 0; i != n; ++i)
    {
      switch (options[i].type)
	{
	case SCM_OPTION_BOOLEAN:
	  if (options[i].val)
	    ls = scm_cons (SCM_PACK (options[i].name), ls);
	  break;
	case SCM_OPTION_INTEGER:
	  ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
	  ls = scm_cons (SCM_PACK (options[i].name), ls);
	  break;
	case SCM_OPTION_SCM:
	  ls = scm_cons (SCM_PACK (options[i].val), ls);
	  ls = scm_cons (SCM_PACK (options[i].name), ls);
	}
    }
  return ls;
}

/* Return a list of sublists, where each sublist contains option name, value
 * and documentation string.  */
static SCM
get_documented_option_setting (const scm_t_option options[], unsigned int n)
{
  SCM ans = SCM_EOL;
  unsigned int i;

  for (i = 0; i != n; ++i)
    {
      SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
      switch (options[i].type)
	{
	case SCM_OPTION_BOOLEAN:
	  ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls);
	  break;
	case SCM_OPTION_INTEGER:
	  ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
	  break;
	case SCM_OPTION_SCM:
	  ls = scm_cons (SCM_PACK (options[i].val), ls);
	}
      ls = scm_cons (SCM_PACK (options[i].name), ls);
      ans = scm_cons (ls, ans);
    }
  return ans;
}

/* Alters options according to the given option setting 'args'.  The value of
 * args is known to be a list, but it is not known whether the list is a well
 * formed option setting, i. e. if for every non-boolean option a value is
 * given.  For this reason, the function applies all changes to a copy of the
 * original setting in memory.  Only if 'args' was successfully processed,
 * the new setting will overwrite the old one.  */
static void
change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
{
  unsigned int i;
  SCM locally_protected_args = args;
  SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
  scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);

  for (i = 0; i != n; ++i)
    {
      if (options[i].type == SCM_OPTION_BOOLEAN)
	flags[i] = 0;
      else
	flags[i] = options[i].val;
    }

  while (!SCM_NULL_OR_NIL_P (args))
    {
      SCM name = SCM_CAR (args);
      int found = 0;

      for (i = 0; i != n && !found; ++i)
	{
	  if (scm_is_eq (name, SCM_PACK (options[i].name)))
	    {
	      switch (options[i].type)
		{
		case SCM_OPTION_BOOLEAN:
		  flags[i] = 1;
		  break;
		case SCM_OPTION_INTEGER:
		  args = SCM_CDR (args);
		  flags[i] = scm_to_size_t (scm_car (args));
		  break;
		case SCM_OPTION_SCM:
		  args = SCM_CDR (args);
		  flags[i] = SCM_UNPACK (scm_car (args));
		  break;
		}
	      found = 1;
	    }
	}

      if (!found)
	scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));

      args = SCM_CDR (args);
    }

  for (i = 0; i != n; ++i)
    {
      if (options[i].type == SCM_OPTION_SCM)
	{
	  SCM old = SCM_PACK (options[i].val);
	  SCM new = SCM_PACK (flags[i]);
	  if (!SCM_IMP (old))
	    protected_objects = scm_delq1_x (old, protected_objects);
	  if (!SCM_IMP (new))
	    protected_objects = scm_cons (new, protected_objects);
	}
      options[i].val = flags[i];
    }

  scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
}

SCM
scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
{
  if (SCM_UNBNDP (args))
    return get_option_setting (options, n);
  else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
    /* Dirk:FIXME:: This criterion should be improved.  IMO it is better to
     * demand that args is #t if documentation should be shown than to say
     * that every argument except a list will print out documentation.  */
    return get_documented_option_setting (options, n);
  else
    {
      SCM old_setting;
      SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
      old_setting = get_option_setting (options, n);
      change_option_setting (args, options, n, s);
      return old_setting;
    }
}

void
scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
{
  unsigned int i;

  for (i = 0; i != n; ++i)
    {
      SCM name = scm_from_locale_symbol (options[i].name);
      options[i].name =	(char *) SCM_UNPACK (name);
      scm_permanent_object (name);
    }
  func (SCM_UNDEFINED);
}

void
scm_init_options ()
{
  scm_gc_register_root (&protected_objects);

#include "libguile/options.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_OPTIONS_H
#define SCM_OPTIONS_H

/* Copyright (C) 1995,1996,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"

typedef struct scm_t_option
{
  unsigned int type;
  const char *name;
  scm_t_bits val;
  char *doc;
} scm_t_option;

#define SCM_OPTION_BOOLEAN 0
#define SCM_OPTION_INTEGER 1
#define SCM_OPTION_SCM     2

SCM_API SCM scm_options (SCM, scm_t_option [], unsigned int, const char*);
SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n);
SCM_API void scm_init_options (void);

#endif  /* SCM_OPTIONS_H */

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


code:
/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 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/validate.h"

#include "libguile/pairs.h"

/* {Pairs}
 */

#if (SCM_DEBUG_PAIR_ACCESSES == 1)

#include "libguile/ports.h"
#include "libguile/strings.h"

void scm_error_pair_access (SCM non_pair)
{
  static unsigned int running = 0;
  SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");

  if (!running)
    {
      running = 1;
      scm_simple_format (scm_current_error_port (),
			 message, scm_list_1 (non_pair));
      abort ();
    }
}

#endif

SCM_DEFINE (scm_cons, "cons", 2, 0, 0,
	    (SCM x, SCM y),
	    "Return a newly allocated pair whose car is @var{x} and whose\n"
	    "cdr is @var{y}.  The pair is guaranteed to be different (in the\n"
	    "sense of @code{eq?}) from every previously existing object.")
#define FUNC_NAME s_scm_cons
{
  return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
}
#undef FUNC_NAME

SCM
scm_cons2 (SCM w, SCM x, SCM y)
{
  return scm_cons (w, scm_cons (x, y));
}

SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
            (SCM x),
	    "Return @code{#t} if @var{x} is a pair; otherwise return\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_pair_p
{
  return scm_from_bool (scm_is_pair (x));
}
#undef FUNC_NAME

SCM
scm_car (SCM pair)
{
  if (!scm_is_pair (pair))
    scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
  return SCM_CAR (pair);
}

SCM
scm_cdr (SCM pair)
{
  if (!scm_is_pair (pair))
    scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
  return SCM_CDR (pair);
}

SCM
scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern)
{
  do
    {
      if (!scm_is_pair (tree))
	scm_wrong_type_arg_msg (NULL, 0, tree, "pair");
      tree = (pattern & 1) ? SCM_CAR (tree) : SCM_CDR (tree);
      pattern >>= 2;
    }
  while (pattern);
  return tree;
}

SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
            (SCM pair, SCM value),
            "Stores @var{value} in the car field of @var{pair}.  The value returned\n"
            "by @code{set-car!} is unspecified.")
#define FUNC_NAME s_scm_set_car_x
{
  SCM_VALIDATE_CONS (1, pair);
  SCM_SETCAR (pair, value);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
            (SCM pair, SCM value),
            "Stores @var{value} in the cdr field of @var{pair}.  The value returned\n"
            "by @code{set-cdr!} is unspecified.")
#define FUNC_NAME s_scm_set_cdr_x
{
  SCM_VALIDATE_CONS (1, pair);
  SCM_SETCDR (pair, value);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Every cxr-pattern is made up of pairs of bits, starting with the two least
 * significant bits.  If in a pair of bits the least significant of the two
 * bits is 0, this means CDR, otherwise CAR.  The most significant bits of the
 * two bits is only needed to indicate when cxr-ing is ready.  This is the
 * case, when all remaining pairs of bits equal 00.  */

typedef struct {
  const char *name;
  unsigned char pattern;
} t_cxr;

static const t_cxr cxrs[] =
{
  {"cdr",    0x02}, /* 00000010 */
  {"car",    0x03}, /* 00000011 */
  {"cddr",   0x0a}, /* 00001010 */
  {"cdar",   0x0b}, /* 00001011 */
  {"cadr",   0x0e}, /* 00001110 */
  {"caar",   0x0f}, /* 00001111 */
  {"cdddr",  0x2a}, /* 00101010 */
  {"cddar",  0x2b}, /* 00101011 */
  {"cdadr",  0x2e}, /* 00101110 */
  {"cdaar",  0x2f}, /* 00101111 */
  {"caddr",  0x3a}, /* 00111010 */
  {"cadar",  0x3b}, /* 00111011 */
  {"caadr",  0x3e}, /* 00111110 */
  {"caaar",  0x3f}, /* 00111111 */
  {"cddddr", 0xaa}, /* 10101010 */
  {"cdddar", 0xab}, /* 10101011 */
  {"cddadr", 0xae}, /* 10101110 */
  {"cddaar", 0xaf}, /* 10101111 */
  {"cdaddr", 0xba}, /* 10111010 */
  {"cdadar", 0xbb}, /* 10111011 */
  {"cdaadr", 0xbe}, /* 10111110 */
  {"cdaaar", 0xbf}, /* 10111111 */
  {"cadddr", 0xea}, /* 11101010 */
  {"caddar", 0xeb}, /* 11101011 */
  {"cadadr", 0xee}, /* 11101110 */
  {"cadaar", 0xef}, /* 11101111 */
  {"caaddr", 0xfa}, /* 11111010 */
  {"caadar", 0xfb}, /* 11111011 */
  {"caaadr", 0xfe}, /* 11111110 */
  {"caaaar", 0xff}, /* 11111111 */
  {0, 0}
};

void
scm_init_pairs ()
{
  unsigned int subnr = 0;

  for (subnr = 0; cxrs[subnr].name; subnr++)
    {
      SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
      scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
    }

#include "libguile/pairs.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PAIRS_H
#define SCM_PAIRS_H

/* Copyright (C) 1995,1996,2000,2001, 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
 */

#include "libguile/__scm.h"

#if (SCM_DEBUG_PAIR_ACCESSES == 1)
# define SCM_VALIDATE_PAIR(cell, expr) \
    ((!scm_is_pair (cell) ? scm_error_pair_access (cell), 0 : 0), (expr))
#else
# define SCM_VALIDATE_PAIR(cell, expr) (expr)
#endif

#define scm_is_null(x)          (scm_is_eq ((x), SCM_EOL))

#define SCM_CAR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
#define SCM_CDR(x)		(SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))

#define SCM_SETCAR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
#define SCM_SETCDR(x, v)	(SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v))))

#define SCM_CAAR(OBJ)		SCM_CAR (SCM_CAR (OBJ))
#define SCM_CDAR(OBJ)		SCM_CDR (SCM_CAR (OBJ))
#define SCM_CADR(OBJ)		SCM_CAR (SCM_CDR (OBJ))
#define SCM_CDDR(OBJ)		SCM_CDR (SCM_CDR (OBJ))

#define SCM_CAAAR(OBJ)		SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))
#define SCM_CDAAR(OBJ)		SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))
#define SCM_CADAR(OBJ)		SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))
#define SCM_CDDAR(OBJ)		SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))
#define SCM_CAADR(OBJ)		SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))
#define SCM_CDADR(OBJ)		SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))
#define SCM_CADDR(OBJ)		SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))
#define SCM_CDDDR(OBJ)		SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))

#define SCM_CAAAAR(OBJ)		SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
#define SCM_CDAAAR(OBJ)		SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
#define SCM_CADAAR(OBJ)		SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
#define SCM_CDDAAR(OBJ)		SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
#define SCM_CAADAR(OBJ)		SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
#define SCM_CDADAR(OBJ)		SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
#define SCM_CADDAR(OBJ)		SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
#define SCM_CDDDAR(OBJ)		SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
#define SCM_CAAADR(OBJ)		SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
#define SCM_CDAADR(OBJ)		SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
#define SCM_CADADR(OBJ)		SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
#define SCM_CDDADR(OBJ)		SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
#define SCM_CAADDR(OBJ)		SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
#define SCM_CDADDR(OBJ)		SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
#define SCM_CADDDR(OBJ)		SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
#define SCM_CDDDDR(OBJ)		SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))

#if (SCM_DEBUG_PAIR_ACCESSES == 1)
SCM_API void scm_error_pair_access (SCM);
#endif

SCM_API SCM scm_cons (SCM x, SCM y);
SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y);
SCM_API SCM scm_pair_p (SCM x);
SCM_API SCM scm_car (SCM x);
SCM_API SCM scm_cdr (SCM x);
SCM_API SCM scm_set_car_x (SCM pair, SCM value);
SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);

#define SCM_I_D_PAT    0x02 /* 00000010 */
#define SCM_I_A_PAT    0x03 /* 00000011 */
#define SCM_I_DD_PAT   0x0a /* 00001010 */
#define SCM_I_DA_PAT   0x0b /* 00001011 */
#define SCM_I_AD_PAT   0x0e /* 00001110 */
#define SCM_I_AA_PAT   0x0f /* 00001111 */
#define SCM_I_DDD_PAT  0x2a /* 00101010 */
#define SCM_I_DDA_PAT  0x2b /* 00101011 */
#define SCM_I_DAD_PAT  0x2e /* 00101110 */
#define SCM_I_DAA_PAT  0x2f /* 00101111 */
#define SCM_I_ADD_PAT  0x3a /* 00111010 */
#define SCM_I_ADA_PAT  0x3b /* 00111011 */
#define SCM_I_AAD_PAT  0x3e /* 00111110 */
#define SCM_I_AAA_PAT  0x3f /* 00111111 */
#define SCM_I_DDDD_PAT 0xaa /* 10101010 */
#define SCM_I_DDDA_PAT 0xab /* 10101011 */
#define SCM_I_DDAD_PAT 0xae /* 10101110 */
#define SCM_I_DDAA_PAT 0xaf /* 10101111 */
#define SCM_I_DADD_PAT 0xba /* 10111010 */
#define SCM_I_DADA_PAT 0xbb /* 10111011 */
#define SCM_I_DAAD_PAT 0xbe /* 10111110 */
#define SCM_I_DAAA_PAT 0xbf /* 10111111 */
#define SCM_I_ADDD_PAT 0xea /* 11101010 */
#define SCM_I_ADDA_PAT 0xeb /* 11101011 */
#define SCM_I_ADAD_PAT 0xee /* 11101110 */
#define SCM_I_ADAA_PAT 0xef /* 11101111 */
#define SCM_I_AADD_PAT 0xfa /* 11111010 */
#define SCM_I_AADA_PAT 0xfb /* 11111011 */
#define SCM_I_AAAD_PAT 0xfe /* 11111110 */
#define SCM_I_AAAA_PAT 0xff /* 11111111 */

SCM_API SCM scm_i_chase_pairs (SCM x, scm_t_uint32 pattern);

#define scm_cddr(x)   scm_i_chase_pairs ((x), SCM_I_DD_PAT)
#define scm_cdar(x)   scm_i_chase_pairs ((x), SCM_I_DA_PAT)
#define scm_cadr(x)   scm_i_chase_pairs ((x), SCM_I_AD_PAT)
#define scm_caar(x)   scm_i_chase_pairs ((x), SCM_I_AA_PAT)
#define scm_cdddr(x)  scm_i_chase_pairs ((x), SCM_I_DDD_PAT)
#define scm_cddar(x)  scm_i_chase_pairs ((x), SCM_I_DDA_PAT)
#define scm_cdadr(x)  scm_i_chase_pairs ((x), SCM_I_DAD_PAT)
#define scm_cdaar(x)  scm_i_chase_pairs ((x), SCM_I_DAA_PAT)
#define scm_caddr(x)  scm_i_chase_pairs ((x), SCM_I_ADD_PAT)
#define scm_cadar(x)  scm_i_chase_pairs ((x), SCM_I_ADA_PAT)
#define scm_caadr(x)  scm_i_chase_pairs ((x), SCM_I_AAD_PAT)
#define scm_caaar(x)  scm_i_chase_pairs ((x), SCM_I_AAA_PAT)
#define scm_cddddr(x) scm_i_chase_pairs ((x), SCM_I_DDDD_PAT)
#define scm_cdddar(x) scm_i_chase_pairs ((x), SCM_I_DDDA_PAT)
#define scm_cddadr(x) scm_i_chase_pairs ((x), SCM_I_DDAD_PAT)
#define scm_cddaar(x) scm_i_chase_pairs ((x), SCM_I_DDAA_PAT)
#define scm_cdaddr(x) scm_i_chase_pairs ((x), SCM_I_DADD_PAT)
#define scm_cdadar(x) scm_i_chase_pairs ((x), SCM_I_DADA_PAT)
#define scm_cdaadr(x) scm_i_chase_pairs ((x), SCM_I_DAAD_PAT)
#define scm_cdaaar(x) scm_i_chase_pairs ((x), SCM_I_DAAA_PAT)
#define scm_cadddr(x) scm_i_chase_pairs ((x), SCM_I_ADDD_PAT)
#define scm_caddar(x) scm_i_chase_pairs ((x), SCM_I_ADDA_PAT)
#define scm_cadadr(x) scm_i_chase_pairs ((x), SCM_I_ADAD_PAT)
#define scm_cadaar(x) scm_i_chase_pairs ((x), SCM_I_ADAA_PAT)
#define scm_caaddr(x) scm_i_chase_pairs ((x), SCM_I_AADD_PAT)
#define scm_caadar(x) scm_i_chase_pairs ((x), SCM_I_AADA_PAT)
#define scm_caaadr(x) scm_i_chase_pairs ((x), SCM_I_AAAD_PAT)
#define scm_caaaar(x) scm_i_chase_pairs ((x), SCM_I_AAAA_PAT)

SCM_API void scm_init_pairs (void);

#endif  /* SCM_PAIRS_H */

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