code:
/* classes: h_files */

#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H

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

#ifndef SCM_T_WCHAR_DEFINED
typedef scm_t_int32 scm_t_wchar;
#define SCM_T_WCHAR_DEFINED
#endif /* SCM_T_WCHAR_DEFINED */

#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_INTERNAL SCM scm_i_gcd (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_lcm (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_logand (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_logior (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_logxor (SCM x, SCM y, SCM rest);

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_INTERNAL SCM scm_i_string_to_number (SCM str, 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_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_expt (SCM z1, SCM z2);
SCM_API SCM scm_sin (SCM z);
SCM_API SCM scm_cos (SCM z);
SCM_API SCM scm_tan (SCM z);
SCM_API SCM scm_sinh (SCM z);
SCM_API SCM scm_cosh (SCM z);
SCM_API SCM scm_tanh (SCM z);
SCM_API SCM scm_asin (SCM z);
SCM_API SCM scm_acos (SCM z);
SCM_API SCM scm_atan (SCM x, SCM y);
SCM_API SCM scm_sys_asinh (SCM z);
SCM_API SCM scm_sys_acosh (SCM z);
SCM_API SCM scm_sys_atanh (SCM z);
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);

SCM_INTERNAL SCM scm_i_min (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_max (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_sum (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_difference (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_product (SCM x, SCM y, SCM rest);
SCM_INTERNAL SCM scm_i_divide (SCM x, SCM y, SCM rest);

/* bignum internal functions */
SCM_INTERNAL SCM scm_i_mkbig (void);
SCM_API /* FIXME: not internal */ SCM scm_i_normbig (SCM x);
SCM_INTERNAL int scm_i_bigcmp (SCM a, SCM b);
SCM_INTERNAL SCM scm_i_dbl2big (double d);
SCM_INTERNAL SCM scm_i_dbl2num (double d);
SCM_API /* FIXME: not internal */ double scm_i_big2dbl (SCM b);
SCM_API /* FIXME: not internal */ SCM scm_i_long2big (long n);
SCM_API /* FIXME: not internal */ SCM scm_i_ulong2big (unsigned long n);
SCM_API /* FIXME: not internal */ 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_INTERNAL double scm_i_fraction2double (SCM z);
SCM_INTERNAL SCM scm_i_fraction_equalp (SCM x, SCM y);
SCM_INTERNAL int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate);

/* general internal functions */
SCM_INTERNAL void scm_i_print_double (double val, SCM port);
SCM_INTERNAL 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_wchar  scm_to_wchar    (SCM x);
SCM_API SCM          scm_from_wchar  (scm_t_wchar 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_INTERNAL void scm_init_numbers (void);

#endif  /* SCM_NUMBERS_H */

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

license: mit


code:
/* Copyright (C) 2001, 2009, 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 3 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
 */

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

#include <string.h>
#include <fcntl.h>
#include <unistd.h>
#include <sys/mman.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <assert.h>
#include <alignof.h>

#include "_scm.h"
#include "programs.h"
#include "objcodes.h"

/* SCM_OBJCODE_COOKIE is defined in _scm.h */
/* The length of the header must be a multiple of 8 bytes.  */
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);

/*
 * Objcode type
 */

static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
{
  int ret;
  char *addr;
  struct stat st;
  SCM sret = SCM_BOOL_F;
  struct scm_objcode *data;

  ret = fstat (fd, &st);
  if (ret < 0)
    SCM_SYSERROR;

  if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
    scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
		    scm_list_1 (SCM_I_MAKINUM (st.st_size)));

  addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
  if (addr == MAP_FAILED)
    {
      (void) close (fd);
      SCM_SYSERROR;
    }

  if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
    {
      SCM args = scm_list_1 (scm_from_locale_stringn
                             (addr, strlen (SCM_OBJCODE_COOKIE)));
      (void) close (fd);
      (void) munmap (addr, st.st_size);
      scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
    }

  data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));

  if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
    {
      (void) close (fd);
      (void) munmap (addr, st.st_size);
      scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
		      scm_list_2 (scm_from_size_t (st.st_size),
				  scm_from_uint32 (sizeof (*data) + data->len
						   + data->metalen)));
    }

  sret = scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_MMAP<<8),
                          (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
                          SCM_UNPACK (SCM_BOOL_F),
                          (scm_t_bits)fd);

  /* FIXME: we leak ourselves and the file descriptor. but then again so does
     dlopen(). */
  return scm_permanent_object (sret);
}
#undef FUNC_NAME

SCM
scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
#define FUNC_NAME "make-objcode-slice"
{
  const struct scm_objcode *data, *parent_data;
  const scm_t_uint8 *parent_base;

  SCM_VALIDATE_OBJCODE (1, parent);
  parent_data = SCM_OBJCODE_DATA (parent);
  parent_base = SCM_C_OBJCODE_BASE (parent_data);

  if (ptr < parent_base
      || ptr >= (parent_base + parent_data->len + parent_data->metalen
                 - sizeof (struct scm_objcode)))
    scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
		    scm_list_4 (scm_from_ulong ((unsigned long) ptr),
				scm_from_ulong ((unsigned long) parent_base),
				scm_from_uint32 (parent_data->len),
				scm_from_uint32 (parent_data->metalen)));

  /* Make sure bytecode for the objcode-meta is suitable aligned.  Failing to
     do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC).  */
  assert ((((scm_t_bits) ptr) &
	   (alignof_type (struct scm_objcode) - 1UL)) == 0);

  data = (struct scm_objcode*) ptr;
  assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
	  <= parent_base + parent_data->len + parent_data->metalen);

  return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_SLICE<<8),
                          (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME

/*
 * Scheme interface
 */

SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_objcode_p
{
  return scm_from_bool (SCM_OBJCODE_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
	    (SCM objcode),
	    "")
#define FUNC_NAME s_scm_objcode_meta
{
  SCM_VALIDATE_OBJCODE (1, objcode);

  if (SCM_OBJCODE_META_LEN (objcode) == 0)
    return SCM_BOOL_F;
  else
    return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
                                               + SCM_OBJCODE_LEN (objcode)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
	    (SCM bytecode),
	    "")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
  size_t size;
  const scm_t_uint8 *c_bytecode;
  struct scm_objcode *data;

  if (!scm_is_bytevector (bytecode))
    scm_wrong_type_arg (FUNC_NAME, 1, bytecode);

  size = SCM_BYTEVECTOR_LENGTH (bytecode);
  c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);

  SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
  data = (struct scm_objcode*)c_bytecode;

  if (data->len + data->metalen != (size - sizeof (*data)))
    scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
		    scm_list_2 (scm_from_size_t (size),
				scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));

  /* foolishly, we assume that as long as bytecode is around, that c_bytecode
     will be of the same length; perhaps a bad assumption? */
  return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_BYTEVECTOR<<8),
                          (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
	    (SCM file),
	    "")
#define FUNC_NAME s_scm_load_objcode
{
  int fd;
  char *c_file;

  SCM_VALIDATE_STRING (1, file);

  c_file = scm_to_locale_string (file);
  fd = open (c_file, O_RDONLY);
  free (c_file);
  if (fd < 0) SCM_SYSERROR;

  return make_objcode_by_mmap (fd);
}
#undef FUNC_NAME

SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
	    (SCM objcode),
	    "")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
  scm_t_int8 *s8vector;
  scm_t_uint32 len;

  SCM_VALIDATE_OBJCODE (1, objcode);

  len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);

  s8vector = scm_malloc (len);
  memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);

  return scm_c_take_bytevector (s8vector, len);
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
	    (SCM objcode, SCM port),
	    "")
#define FUNC_NAME s_scm_write_objcode
{
  SCM_VALIDATE_OBJCODE (1, objcode);
  SCM_VALIDATE_OUTPUT_PORT (2, port);

  scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
  scm_c_write (port, SCM_OBJCODE_DATA (objcode),
               sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<objcode ", port);
  scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
  scm_puts (">", port);
}

void
scm_bootstrap_objcodes (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_objcodes",
                            (scm_t_extension_init_func)scm_init_objcodes, NULL);
}

/* Before, we used __BYTE_ORDER, but that is not defined on all
   systems. So punt and use automake, PDP endianness be damned. */
#ifdef WORDS_BIGENDIAN
#define SCM_BYTE_ORDER 4321
#else
#define SCM_BYTE_ORDER 1234
#endif

void
scm_init_objcodes (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/objcodes.x"
#endif

  scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
  scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
}

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


code:
/* Copyright (C) 2001, 2009, 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 3 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
 */

#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_

#include <libguile.h>

/* Objcode data should be directly mappable to this C structure.  */
struct scm_objcode
{
  scm_t_uint32 len;             /* the maximum index of base[] */
  scm_t_uint32 metalen;         /* well, i lie. this many bytes at the end of
                                   base[] for metadata */
  /* In C99, we'd have:
     scm_t_uint8 base[];  */
};

/* Return a pointer to the base of objcode OBJ.  */
#define SCM_C_OBJCODE_BASE(obj)				\
  ((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))

#define SCM_F_OBJCODE_IS_MMAP       (1<<0)
#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE      (1<<2)
#define SCM_F_OBJCODE_IS_STATIC     (1<<3)

#define SCM_OBJCODE_P(x)	(SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_objcode)
#define SCM_OBJCODE_DATA(x)	((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)

#define SCM_OBJCODE_LEN(x)	(SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x)	(SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
#define SCM_OBJCODE_BASE(x)	(SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))

#define SCM_OBJCODE_FLAGS(x)	(SCM_CELL_WORD_0 (x) >> 8)
#define SCM_OBJCODE_IS_MMAP(x)	(SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_BYTEVECTOR)
#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)

SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_load_objcode (SCM file);
SCM_API SCM scm_objcode_p (SCM obj);
SCM_API SCM scm_objcode_meta (SCM objcode);
SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);

SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
                                       scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_objcodes (void);
SCM_INTERNAL void scm_init_objcodes (void);

#endif /* _SCM_OBJCODES_H_ */

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


code:
/*	Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008, 2009 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 3 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}
 */

static SCM object_whash;

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 (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 (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 (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 ()
{
  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, 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 3 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_INTERNAL 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, 2009, 2010 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 3 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/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 i;
  SCM ls = SCM_EOL;
  for (i = 0; options[i].name; ++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[])
{
  SCM ans = SCM_EOL;
  unsigned int i;

  for (i = 0; options[i].name; ++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;
}

static int
options_length (scm_t_option options[])
{
  unsigned int i = 0;
  for (; options[i].name != NULL; ++i)
    ;

  return i;
}

/* 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.
 *
 * If DRY_RUN is set, don't change anything. This is useful for trying out an option
 * before entering a critical section.
 */
static void
change_option_setting (SCM args, scm_t_option options[], const char *s,
		       int dry_run)
{
  unsigned int i;
  SCM locally_protected_args = args;
  SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
  scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);

  for (i = 0; options[i].name; ++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; options[i].name && !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);
    }

  if (dry_run)
    return;

  for (i = 0; options[i].name; ++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[], const char *s)
{
  return scm_options_try (args, options, s, 0);
}

SCM
scm_options_try (SCM args, scm_t_option options[], const char *s,
		 int dry_run)
{
  if (SCM_UNBNDP (args))
    return get_option_setting (options);
  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);
  else
    {
      SCM old_setting;
      SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
      old_setting = get_option_setting (options);
      change_option_setting (args, options, s, dry_run);
      return old_setting;
    }
}

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

  for (i = 0; options[i].name; ++i)
    {
      SCM name = scm_from_locale_symbol (options[i].name);
      options[i].name =	(char *) SCM_UNPACK (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, 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 3 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_try (SCM args, scm_t_option options[], const char *s, int dry_run);
SCM_API SCM scm_options (SCM, scm_t_option [], const char*);
SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []);
SCM_INTERNAL 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, 2009 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 3 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"

#include "verify.h"

/* {Pairs}
 */

/*
 * This compile-time test verifies the properties needed for the
 * efficient test macro scm_is_null_or_nil defined in pairs.h,
 * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro.
 *
 * See the comments preceeding the definitions of SCM_BOOL_F and
 * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
 */
verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION		\
		 (SCM_ELISP_NIL, SCM_EOL));

#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_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.  */

/* The compiler should unroll this. */
#define CHASE_PAIRS(tree, FUNC_NAME, pattern)                           \
  scm_t_uint32 pattern_var = pattern;                                   \
  do                                                                    \
    {                                                                   \
      if (!scm_is_pair (tree))                                          \
	scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair");            \
      tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree);       \
      pattern_var >>= 2;                                                \
    }                                                                   \
  while (pattern_var);                                                  \
  return tree

SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
}
SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
}
SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
}
SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
}
SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
}
SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
}
SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
}
SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
}
SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
}
SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
}
SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
}
SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
}
SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
}
SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
}
SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
}
SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
}
SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
}
SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
}
SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
}
SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
}
SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
}
SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
}
SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
}
SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
}
SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
}
SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
}
SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
}
SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
}
SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
}
SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
{
  CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
}

void
scm_init_pairs ()
{
#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, 2009, 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 3 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

/*
 * Use scm_is_null_and_not_nil if it's important (for correctness)
 * that #nil must NOT be considered null.
 */
#define scm_is_null_and_not_nil(x)     (scm_is_eq ((x), SCM_EOL))

/*
 * Use scm_is_null_assume_not_nil if
#nil will never be tested,
 * for increased efficiency.
 */
#define scm_is_null_assume_not_nil(x)  (scm_is_eq ((x), SCM_EOL))

/*
 * See the comments preceeding the definitions of SCM_BOOL_F and
 * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
 * how the following macro works.
 */
#define scm_is_null_or_nil(x)  \
  (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))

/* Older spellings for these null, nil, and pair predicates. */
#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
#define SCM_NULLP(x) (scm_is_null (x))
#define SCM_NNULLP(x) (!scm_is_null (x))
#define SCM_CONSP(x)            (scm_is_pair (x))
#define SCM_NCONSP(x)           (!SCM_CONSP (x))

/* #nil is null. */
#define scm_is_null(x)		(scm_is_null_or_nil(x))

#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);

SCM_API SCM scm_cddr (SCM x);
SCM_API SCM scm_cdar (SCM x);
SCM_API SCM scm_cadr (SCM x);
SCM_API SCM scm_caar (SCM x);
SCM_API SCM scm_cdddr (SCM x);
SCM_API SCM scm_cddar (SCM x);
SCM_API SCM scm_cdadr (SCM x);
SCM_API SCM scm_cdaar (SCM x);
SCM_API SCM scm_caddr (SCM x);
SCM_API SCM scm_cadar (SCM x);
SCM_API SCM scm_caadr (SCM x);
SCM_API SCM scm_caaar (SCM x);
SCM_API SCM scm_cddddr (SCM x);
SCM_API SCM scm_cdddar (SCM x);
SCM_API SCM scm_cddadr (SCM x);
SCM_API SCM scm_cddaar (SCM x);
SCM_API SCM scm_cdaddr (SCM x);
SCM_API SCM scm_cdadar (SCM x);
SCM_API SCM scm_cdaadr (SCM x);
SCM_API SCM scm_cdaaar (SCM x);
SCM_API SCM scm_cadddr (SCM x);
SCM_API SCM scm_caddar (SCM x);
SCM_API SCM scm_cadadr (SCM x);
SCM_API SCM scm_cadaar (SCM x);
SCM_API SCM scm_caaddr (SCM x);
SCM_API SCM scm_caadar (SCM x);
SCM_API SCM scm_caaadr (SCM x);
SCM_API SCM scm_caaaar (SCM x);

SCM_INTERNAL void scm_init_pairs (void);

#endif  /* SCM_PAIRS_H */

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