[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9-5-129-g7230aaf |
|
Date: |
Wed, 09 Dec 2009 09:51:04 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=7230aaf9610e8654c9395a3207c91663da78a873
The branch, wip-eval-cleanup has been updated
via 7230aaf9610e8654c9395a3207c91663da78a873 (commit)
via 735bcfe579606eddb1700462e56918d48affe36e (commit)
via 75a029aa2553a24e4804722521f1e5db9690fbe3 (commit)
via 0b1733c7d18cd39c11868a7b091de4c72f69ea8d (commit)
via 0e163c06f26f1ec8930183a9e1618eb9f1f0402b (commit)
via 00f8b368ca9690af45ff47bb7309061578cc6016 (commit)
via 9e9e54eb19067f327c1ebc7ee847cac354b35979 (commit)
via bbd41a6a217b53b0382da81c47d7f7110de31273 (commit)
via 96a44c1cab34e2cc3cf5a04a0c026f0863386137 (commit)
via 485d13670be5ae5594cf04d87fb64c239c2c9b80 (commit)
via 72ab4b2e2b9f5aa35378ba82ac99b863f7a63d95 (commit)
via db5ed68588fc0c4086da1715c8aa13e85fa173ee (commit)
via 34dfef5135a8f65b85f5b3c72168ca2900d9dbcc (commit)
via 4afe4ab42ab8a6b0f869cfc2b4d0ff0d8e0a8f48 (commit)
via 4834078b079e8135bb042ac8a2f7f908433cda79 (commit)
via b9ef8e66eec1da83e0587c2d454c04ca5532817d (commit)
via 4dc2165b356d6f360f8d82fc04c916b7240eec19 (commit)
via 0236bc683d288f64089819064030fb8e93bd3781 (commit)
via e779fef7eecb2637f1e8b4952a1bd018b8839346 (commit)
via a253eec010c6ec598cb67ad61f6e2f8991691142 (commit)
via c395cb78134188b1e8c19d4c36045fcd5a411373 (commit)
via 56164dc47f6616b359f0ad23be208f01a77b55fa (commit)
via 66e78727d602b0c59bf4633951eac17d3697bfc0 (commit)
via ea68d342f18c3d2082ce6a4fb39bd38b6af932cc (commit)
via ce65df9f09577e4f566b467ee8647617204b9b40 (commit)
via 8f79d4ed542686df8345b7b9e3e1d3e14cf4b955 (commit)
via e7efe8e793fa51ea898aea4477939c598b3e9fac (commit)
via 838aa0007073dbb9e8c91810299c47054ded52bd (commit)
via 562cd1b8f87dfb099c9cca5dfa4846367e6c9ca3 (commit)
via f39448c5a3804f823e367d97cd5e862b016cb8aa (commit)
via 1be8532fdb7715451b939571f9a147635df9cd65 (commit)
via dd3a26f3da712564a294ad5890de12bcc6cb8849 (commit)
via 45cf24287277c897733e0513bade64cccb1d7608 (commit)
via 9ea31741dad29ae123e468a203b72df6d190f6e1 (commit)
via c99de5aa275b15af207c0dba9717d6b865684fc4 (commit)
via 314b87163eac1358923cb84e7f2c87d06aa03756 (commit)
via f36878ba2d04427e76b85a9e91fce71f56ba7c7f (commit)
via 8a1f4f98e121c4ba90eb992203713cf493d45c71 (commit)
via 31d845b4bc4bf50f32492c17dc43c9ccea779acb (commit)
via bf5a05f2a01fee23f5622d1429dc32f4850f98b5 (commit)
via a941cde9e595ab13f4d1804a2734967a89ead03a (commit)
via d389e9661a682855e8313b37a4f08dd2d7735acc (commit)
via 78d3deb1d48eda3d5542e0bf05e5e3b517fb1754 (commit)
via 8ccd24f7bb523055dc2d75d923ff02c7b121aedc (commit)
via b04ab0c624621acdd985861f1fb9f2c3d4f6275f (commit)
via d84765da44a0a6b28ef19b853832deebf4cfbafc (commit)
via ad79736c68a803a59814fbfc0cb4b092c2b4cddf (commit)
via 6fc4d0124d633d1b3ddc5af82967f23bd17556f8 (commit)
via df338a22646fa6a783d72d67f3e6c4d4aee65c72 (commit)
via df9ca8d8b2f48e7042298a9a788b749b46fc5efc (commit)
via aa3f69519f1af3fcf31cf36be33776db3fedf65a (commit)
via 14aa25e410d49586c8ff9b4a80d2b6046b769905 (commit)
from b2b554efd3fee1bd110cb286a1b185042db0a27f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-data.texi | 145 ------
guile-readline/readline.c | 2 +-
libguile/arbiters.c | 4 +-
libguile/array-handle.c | 3 +-
libguile/array-map.c | 304 +------------
libguile/arrays.c | 7 +-
libguile/arrays.h | 8 +-
libguile/async.c | 7 +-
libguile/backtrace.c | 141 ++----
libguile/bitvectors.c | 3 +-
libguile/bytevectors.c | 7 +-
libguile/chars.c | 274 +++++++++---
libguile/continuations.c | 11 +-
libguile/continuations.h | 9 +-
libguile/debug.c | 84 +----
libguile/debug.h | 68 ---
libguile/deprecated.c | 75 +++-
libguile/deprecated.h | 20 +-
libguile/eq.c | 145 ++++--
libguile/eval.c | 169 ++++----
libguile/eval.h | 3 -
libguile/evalext.c | 7 +-
libguile/feature.c | 4 +-
libguile/filesys.c | 18 +-
libguile/filesys.h | 6 +-
libguile/fluids.c | 67 +--
libguile/fluids.h | 28 +-
libguile/frames.c | 89 ++--
libguile/frames.h | 48 ++-
libguile/gc.c | 50 +--
libguile/gc.h | 6 +-
libguile/gdbint.c | 2 +-
libguile/goops.c | 119 ++----
libguile/goops.h | 4 +-
libguile/gsubr.c | 103 ++---
libguile/guardians.c | 2 +-
libguile/hash.c | 6 +-
libguile/hashtab.c | 30 +-
libguile/hashtab.h | 12 +-
libguile/hooks.c | 11 +-
libguile/init.c | 110 ++---
libguile/instructions.c | 3 +-
libguile/keywords.c | 10 +-
libguile/load.c | 2 +-
libguile/macros.c | 62 ++--
libguile/memoize.c | 6 +-
libguile/modules.c | 27 +-
libguile/numbers.c | 860 +++++++++++++++++++++++++----------
libguile/numbers.h | 31 +-
libguile/objprop.c | 12 +-
libguile/options.c | 3 +-
libguile/pairs.c | 211 ++++++----
libguile/pairs.h | 89 ++---
libguile/ports.c | 21 +-
libguile/ports.h | 1 -
libguile/print.c | 41 +--
libguile/procprop.c | 162 +++-----
libguile/procprop.h | 2 +-
libguile/procs.c | 136 ++----
libguile/procs.h | 103 +----
libguile/properties.c | 14 +-
libguile/root.c | 6 +-
libguile/root.h | 16 -
libguile/scmsigs.c | 6 +-
libguile/smob.c | 8 -
libguile/smob.h | 61 ++-
libguile/snarf.h | 16 +-
libguile/srcprop.c | 18 +-
libguile/srcprop.h | 1 +
libguile/srfi-14.c | 2 +-
libguile/srfi-4.c | 21 +-
libguile/stacks.c | 670 +++++----------------------
libguile/stacks.h | 78 +---
libguile/strings.c | 2 +
libguile/strings.h | 2 +
libguile/strorder.c | 232 ++++++++--
libguile/struct.c | 198 +++++----
libguile/struct.h | 19 +-
libguile/tags.h | 70 +---
libguile/threads.c | 6 +-
libguile/threads.h | 4 -
libguile/throw.c | 28 +-
libguile/validate.h | 4 +-
libguile/values.c | 3 +-
libguile/vectors.c | 2 -
libguile/vm-engine.c | 21 -
libguile/vm-i-system.c | 16 -
libguile/vm.c | 116 +----
libguile/vm.h | 3 +-
module/ice-9/boot-9.scm | 83 ----
module/ice-9/deprecated.scm | 21 +
module/ice-9/documentation.scm | 3 +-
module/ice-9/session.scm | 16 +-
module/oop/goops.scm | 33 +-
module/oop/goops/describe.scm | 7 +-
module/system/repl/describe.scm | 21 +-
module/system/vm/frame.scm | 88 ++---
test-suite/tests/continuations.test | 7 +-
test-suite/tests/numbers.test | 14 +-
test-suite/tests/ramap.test | 12 +-
100 files changed, 2522 insertions(+), 3419 deletions(-)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index cf0d321..3096b35 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -184,7 +184,6 @@ in Scheme, which is particularly clear and accessible: see
* Complex:: Complex number operations.
* Arithmetic:: Arithmetic functions.
* Scientific:: Scientific functions.
-* Primitive Numerics:: Primitive numeric functions.
* Bitwise Operations:: Logical AND, OR, NOT, and so on.
* Random:: Random number generation.
@end menu
@@ -1337,150 +1336,6 @@ Return the hyperbolic arctangent of @var{z}.
@end deffn
address@hidden Primitive Numerics
address@hidden Primitive Numeric Functions
-
-Many of Guile's numeric procedures which accept any kind of numbers as
-arguments, including complex numbers, are implemented as Scheme
-procedures that use the following real number-based primitives. These
-primitives signal an error if they are called with complex arguments.
-
address@hidden begin (texi-doc-string "guile" "$abs")
address@hidden {Scheme Procedure} $abs x
-Return the absolute value of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$sqrt")
address@hidden {Scheme Procedure} $sqrt x
-Return the square root of @var{x}.
address@hidden deffn
-
address@hidden {Scheme Procedure} $expt x y
address@hidden {C Function} scm_sys_expt (x, y)
-Return @var{x} raised to the power of @var{y}. This
-procedure does not accept complex arguments.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$sin")
address@hidden {Scheme Procedure} $sin x
-Return the sine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$cos")
address@hidden {Scheme Procedure} $cos x
-Return the cosine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$tan")
address@hidden {Scheme Procedure} $tan x
-Return the tangent of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$asin")
address@hidden {Scheme Procedure} $asin x
-Return the arcsine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$acos")
address@hidden {Scheme Procedure} $acos x
-Return the arccosine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$atan")
address@hidden {Scheme Procedure} $atan x
-Return the arctangent of @var{x} in the range @address@hidden/2} to
address@hidden/2}.
address@hidden deffn
-
address@hidden {Scheme Procedure} $atan2 x y
address@hidden {C Function} scm_sys_atan2 (x, y)
-Return the arc tangent of the two arguments @var{x} and
address@hidden This is similar to calculating the arc tangent of
address@hidden / @var{y}, except that the signs of both arguments
-are used to determine the quadrant of the result. This
-procedure does not accept complex arguments.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$exp")
address@hidden {Scheme Procedure} $exp x
-Return e to the power of @var{x}, where e is the base of natural
-logarithms (address@hidden).
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$log")
address@hidden {Scheme Procedure} $log x
-Return the natural logarithm of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$sinh")
address@hidden {Scheme Procedure} $sinh x
-Return the hyperbolic sine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$cosh")
address@hidden {Scheme Procedure} $cosh x
-Return the hyperbolic cosine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$tanh")
address@hidden {Scheme Procedure} $tanh x
-Return the hyperbolic tangent of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$asinh")
address@hidden {Scheme Procedure} $asinh x
-Return the hyperbolic arcsine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$acosh")
address@hidden {Scheme Procedure} $acosh x
-Return the hyperbolic arccosine of @var{x}.
address@hidden deffn
-
address@hidden begin (texi-doc-string "guile" "$atanh")
address@hidden {Scheme Procedure} $atanh x
-Return the hyperbolic arctangent of @var{x}.
address@hidden deffn
-
-C functions for the above are provided by the standard mathematics
-library. Naturally these expect and return @code{double} arguments
-(@pxref{Mathematics,,, libc, GNU C Library Reference Manual}).
-
address@hidden {xx} {Scheme Procedure} {C Function}
address@hidden @tab Scheme Procedure @tab C Function
-
address@hidden @tab @code{$abs} @tab @code{fabs}
address@hidden @tab @code{$sqrt} @tab @code{sqrt}
address@hidden @tab @code{$sin} @tab @code{sin}
address@hidden @tab @code{$cos} @tab @code{cos}
address@hidden @tab @code{$tan} @tab @code{tan}
address@hidden @tab @code{$asin} @tab @code{asin}
address@hidden @tab @code{$acos} @tab @code{acos}
address@hidden @tab @code{$atan} @tab @code{atan}
address@hidden @tab @code{$atan2} @tab @code{atan2}
address@hidden @tab @code{$exp} @tab @code{exp}
address@hidden @tab @code{$expt} @tab @code{pow}
address@hidden @tab @code{$log} @tab @code{log}
address@hidden @tab @code{$sinh} @tab @code{sinh}
address@hidden @tab @code{$cosh} @tab @code{cosh}
address@hidden @tab @code{$tanh} @tab @code{tanh}
address@hidden @tab @code{$asinh} @tab @code{asinh}
address@hidden @tab @code{$acosh} @tab @code{acosh}
address@hidden @tab @code{$atanh} @tab @code{atanh}
address@hidden multitable
-
address@hidden, @code{acosh} and @code{atanh} are C99 standard but might
-not be available on older systems. Guile provides the following
-equivalents (on all systems).
-
address@hidden {C Function} double scm_asinh (double x)
address@hidden {C Function} double scm_acosh (double x)
address@hidden {C Function} double scm_atanh (double x)
-Return the hyperbolic arcsine, arccosine or arctangent of @var{x}
-respectively.
address@hidden deftypefn
-
-
@node Bitwise Operations
@subsubsection Bitwise Operations
diff --git a/guile-readline/readline.c b/guile-readline/readline.c
index 5f6719d..2d3617d 100644
--- a/guile-readline/readline.c
+++ b/guile-readline/readline.c
@@ -557,7 +557,7 @@ scm_init_readline ()
rl_basic_word_break_characters = "\t\n\"'`;()";
rl_readline_name = "Guile";
- reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
+ reentry_barrier_mutex = scm_make_mutex ();
scm_init_opts (scm_readline_options,
scm_readline_opts);
#if HAVE_RL_GET_KEYMAP
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index 3567c90..a53b702 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -122,7 +122,7 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
{
scm_t_bits old;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL);
+ FETCH_STORE (old, SCM_SMOB_DATA_0 (arb), SCM_LOCK_VAL);
return scm_from_bool (old == SCM_UNLOCK_VAL);
}
#undef FUNC_NAME
@@ -148,7 +148,7 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
{
scm_t_bits old;
SCM_VALIDATE_SMOB (1, arb, arbiter);
- FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL);
+ FETCH_STORE (old, SCM_SMOB_DATA_0 (arb), SCM_UNLOCK_VAL);
return scm_from_bool (old == SCM_LOCK_VAL);
}
#undef FUNC_NAME
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index cd5a466..ec3127a 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -132,8 +132,7 @@ void
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, TAG) \
- scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \
- = (scm_permanent_object (scm_from_locale_symbol (#tag)))
+ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] =
scm_from_locale_symbol (#tag)
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
DEFINE_ARRAY_TYPE (a, CHAR);
diff --git a/libguile/array-map.c b/libguile/array-map.c
index eaac54a..c673b4d 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -44,39 +44,6 @@
#include "libguile/array-map.h"
-typedef struct
-{
- char *name;
- SCM sproc;
- int (*vproc) ();
-} ra_iproc;
-
-
-/* These tables are a kluge that will not scale well when more
- * vectorized subrs are added. It is tempting to steal some bits from
- * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
- * offset into a table of vectorized subrs.
- */
-
-static ra_iproc ra_rpsubrs[] =
-{
- {"=", SCM_UNDEFINED, scm_ra_eqp},
- {"<", SCM_UNDEFINED, scm_ra_lessp},
- {"<=", SCM_UNDEFINED, scm_ra_leqp},
- {">", SCM_UNDEFINED, scm_ra_grp},
- {">=", SCM_UNDEFINED, scm_ra_greqp},
- {0, 0, 0}
-};
-
-static ra_iproc ra_asubrs[] =
-{
- {"+", SCM_UNDEFINED, scm_ra_sum},
- {"-", SCM_UNDEFINED, scm_ra_difference},
- {"*", SCM_UNDEFINED, scm_ra_product},
- {"/", SCM_UNDEFINED, scm_ra_divide},
- {0, 0, 0}
-};
-
/* The WHAT argument for `scm_gc_malloc ()' et al. */
static const char indices_gc_hint[] = "array-indices";
@@ -678,11 +645,7 @@ ramap (SCM ra0, SCM proc, SCM ras)
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
- else
- ras = scm_vector (ras);
+ ras = scm_vector (SCM_CDR (ras));
for (; i <= n; i++, i1 += inc1)
{
@@ -697,122 +660,6 @@ ramap (SCM ra0, SCM proc, SCM ras)
}
-static int
-ramap_dsubr (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0))
- {
- default:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
- break;
- }
- return 1;
-}
-
-
-
-static int
-ramap_rp (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 =
SCM_I_ARRAY_BASE (ra2);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ra2 = SCM_I_ARRAY_V (ra2);
-
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
- if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
- scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
-
- return 1;
-}
-
-
-
-static int
-ramap_1 (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
- return 1;
-}
-
-
-
-static int
-ramap_2o (SCM ra0, SCM proc, SCM ras)
-{
- SCM ra1 = SCM_CAR (ras);
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- {
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
- }
- else
- {
- SCM ra2 = SCM_CAR (ras);
- unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
- long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
- ra2 = SCM_I_ARRAY_V (ra2);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
- }
- return 1;
-}
-
-
-
-static int
-ramap_a (SCM ra0, SCM proc, SCM ras)
-{
- long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
- unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
- long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_I_ARRAY_V (ra0);
- if (scm_is_null (ras))
- for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
- long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_I_ARRAY_V (ra1);
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
- }
- return 1;
-}
-
-
SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1,
scm_array_map_x);
SCM_SYMBOL (sym_b, "b");
@@ -831,103 +678,8 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
SCM_VALIDATE_PROC (2, proc);
SCM_VALIDATE_REST_ARGUMENT (lra);
- switch (SCM_TYP7 (proc))
- {
- default:
- gencase:
- scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_1:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_2:
- if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
- SCM_WRONG_NUM_ARGS (); /* need 2 sources */
- goto subr_2o;
- case scm_tc7_subr_2o:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- subr_2o:
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_dsubr:
- if (! scm_is_pair (lra))
- SCM_WRONG_NUM_ARGS (); /* need 1 source */
- scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
- {
- ra_iproc *p;
- if (!scm_is_typed_array (ra0, sym_b))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
- {
- scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_asubr:
- if (scm_is_null (lra))
- {
- SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
- ra_iproc *p;
- /* Check to see if order might matter.
- This might be an argument for a separate
- SERIAL-ARRAY-MAP! */
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
- if (!scm_is_eq (ra0, ra1)
- || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (scm_is_eq (v0, ra1)
- || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V
(ra1))))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (scm_is_eq (proc, p->sproc))
- {
- if (!scm_is_eq (ra0, SCM_CAR (lra)))
- scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons
(SCM_CAR (lra), SCM_EOL), FUNC_NAME);
- lra = SCM_CDR (lra);
- while (1)
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
- lra = SCM_CDR (lra);
- if (SCM_NIMP (lra))
- for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
- scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
- }
- return SCM_UNSPECIFIED;
- }
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -950,11 +702,8 @@ rafe (SCM ra0, SCM proc, SCM ras)
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ra1 = SCM_I_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if (scm_is_null(ras))
- ras = scm_nullvect;
- else
- ras = scm_vector (ras);
+ ras = scm_vector (SCM_CDR (ras));
+
for (; i <= n; i++, i0 += inc0, i1 += inc1)
{
args = SCM_EOL;
@@ -1172,23 +921,29 @@ scm_raequal (SCM ra0, SCM ra1)
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
}
-#if 0
-/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
-SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
- (SCM ra0, SCM ra1),
+SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
+ (SCM ra0, SCM ra1, SCM rest),
"Return @code{#t} iff all arguments are arrays with the same\n"
"shape, the same type, and have corresponding elements which are\n"
"either @code{equal?} or @code{array-equal?}. This function\n"
"differs from @code{equal?} in that a one dimensional shared\n"
"array may be @var{array-equal?} but not @var{equal?} to a\n"
"vector or uniform vector.")
-#define FUNC_NAME s_scm_array_equal_p
-{
+#define FUNC_NAME s_scm_i_array_equal_p
+{
+ if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
+ return SCM_BOOL_T;
+
+ while (!scm_is_null (rest))
+ { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
+ return SCM_BOOL_F;
+ ra0 = ra1;
+ ra1 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_array_equal_p (ra0, ra1);
}
#undef FUNC_NAME
-#endif
-
-static char s_array_equal_p[] = "array-equal?";
SCM
@@ -1200,28 +955,9 @@ scm_array_equal_p (SCM ra0, SCM ra1)
}
-static void
-init_raprocs (ra_iproc *subra)
-{
- for (; subra->name; subra++)
- {
- SCM sym = scm_from_locale_symbol (subra->name);
- SCM var =
- scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- subra->sproc = SCM_VARIABLE_REF (var);
- else
- subra->sproc = SCM_BOOL_F;
- }
-}
-
-
void
scm_init_array_map (void)
{
- init_raprocs (ra_rpsubrs);
- init_raprocs (ra_asubrs);
- scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 8dc1d78..741cc56 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -56,9 +56,9 @@
scm_t_bits scm_i_tc16_array;
#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) |
SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) &
~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
@@ -1126,7 +1126,8 @@ array_get_handle (SCM array, scm_t_array_handle *h)
h->base = SCM_I_ARRAY_BASE (array);
}
-SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
+ SCM_SMOB_TYPE_MASK,
array_handle_ref, array_handle_set,
array_get_handle);
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 35e5471..325bb9c 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -65,13 +65,13 @@ typedef struct scm_i_t_array
SCM_API scm_t_bits scm_i_tc16_array;
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
-#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
-#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
+#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_SMOB_FLAGS (x)>>1))
+#define SCM_I_ARRAY_CONTP(x) (SCM_SMOB_FLAGS(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
-#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
+#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_SMOB_DATA_1 (a))
#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
#define SCM_I_ARRAY_DIMS(a) \
diff --git a/libguile/async.c b/libguile/async.c
index 664264f..ddb2a21 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -87,9 +87,9 @@ static scm_t_bits tc16_async;
#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user
async")
-#define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
-#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V)
<< 16)))
-#define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
+#define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X))
+#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
+#define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X)
SCM_DEFINE (scm_async, "async", 1, 0, 0,
@@ -501,7 +501,6 @@ scm_async_tick (void)
void
scm_init_async ()
{
- scm_asyncs = SCM_EOL;
tc16_async = scm_make_smob_type ("async", 0);
#include "libguile/async.x"
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 58fe0cf..9d56ea2 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -43,6 +43,7 @@
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"
+#include "libguile/frames.h"
#include "libguile/validate.h"
#include "libguile/lang.h"
@@ -157,11 +158,7 @@ display_expression (SCM frame, SCM pname, SCM source, SCM
port)
pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
if (scm_is_symbol (pname) || scm_is_string (pname))
{
- if (SCM_FRAMEP (frame)
- && SCM_FRAME_EVAL_ARGS_P (frame))
- scm_puts ("While evaluating arguments to ", port);
- else
- scm_puts ("In procedure ", port);
+ scm_puts ("In procedure ", port);
scm_iprin1 (pname, port, pstate);
}
scm_puts (":\n", port);
@@ -354,14 +351,14 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int
indentation, SCM sport, S
static void
display_application (SCM frame, int indentation, SCM sport, SCM port,
scm_print_state *pstate)
{
- SCM proc = SCM_FRAME_PROC (frame);
+ SCM proc = scm_frame_procedure (frame);
SCM name = (scm_is_true (scm_procedure_p (proc))
? scm_procedure_name (proc)
: SCM_BOOL_F);
display_frame_expr ("[",
scm_cons (scm_is_true (name) ? name : proc,
- SCM_FRAME_ARGS (frame)),
- SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
+ scm_frame_arguments (frame)),
+ "]",
indentation,
sport,
port,
@@ -383,30 +380,27 @@ SCM_DEFINE (scm_display_application,
"display-application", 1, 2, 0,
if (SCM_UNBNDP (indent))
indent = SCM_INUM0;
- if (SCM_FRAME_PROC_P (frame))
- /* Display an application. */
- {
- SCM sport, print_state;
- scm_print_state *pstate;
+ /* Display an application. */
+ {
+ SCM sport, print_state;
+ scm_print_state *pstate;
- /* Create a string port used for adaptation of printing parameters. */
- sport = scm_mkstrport (SCM_INUM0,
- scm_make_string (scm_from_int (240),
- SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
-
- /* Create a print state for printing of frames. */
- print_state = scm_make_print_state ();
- pstate = SCM_PRINT_STATE (print_state);
- pstate->writingp = 1;
- pstate->fancyp = 1;
+ /* Create a string port used for adaptation of printing parameters. */
+ sport = scm_mkstrport (SCM_INUM0,
+ scm_make_string (scm_from_int (240),
+ SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
- display_application (frame, scm_to_int (indent), sport, port, pstate);
- return SCM_BOOL_T;
- }
- else
- return SCM_BOOL_F;
+ display_application (frame, scm_to_int (indent), sport, port, pstate);
+ return SCM_BOOL_T;
+ }
}
#undef FUNC_NAME
@@ -415,7 +409,7 @@ SCM_SYMBOL (sym_base, "base");
static void
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{
- SCM source = SCM_FRAME_SOURCE (frame);
+ SCM source = scm_frame_source (frame);
*file = *line = SCM_BOOL_F;
if (scm_is_pair (source)
&& scm_is_pair (scm_cdr (source))
@@ -439,7 +433,7 @@ display_backtrace_file (frame, last_file, port, pstate)
display_backtrace_get_file_line (frame, &file, &line);
- if (scm_is_eq (file, *last_file))
+ if (scm_is_true (scm_equal_p (file, *last_file)))
return;
*last_file = file;
@@ -506,23 +500,16 @@ display_backtrace_file_and_line (SCM frame, SCM port,
scm_print_state *pstate)
}
static void
-display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port,
scm_print_state *pstate)
+display_frame (SCM frame, int n, int nfield, int indentation,
+ SCM sport, SCM port, scm_print_state *pstate)
{
- int n, i, j;
-
- /* Announce missing frames? */
- if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_puts ("...\n", port);
- }
+ int i, j;
/* display file name and line number */
if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
display_backtrace_file_and_line (frame, port, pstate);
/* Check size of frame number. */
- n = SCM_FRAME_NUMBER (frame);
for (i = 0, j = n; j > 0; ++i) j /= 10;
/* Number indentation. */
@@ -531,38 +518,12 @@ display_frame (SCM frame, int nfield, int indentation,
SCM sport, SCM port, scm_
/* Frame number. */
scm_iprin1 (scm_from_int (n), port, pstate);
- /* Real frame marker */
- scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
-
/* Indentation. */
indent (indentation, port);
- if (SCM_FRAME_PROC_P (frame))
- /* Display an application. */
- display_application (frame, nfield + 1 + indentation, sport, port, pstate);
- else
- /* Display a special form. */
- {
- SCM source = SCM_FRAME_SOURCE (frame);
- SCM copy = (scm_is_pair (source)
- ? scm_source_property (source, scm_sym_copy)
- : SCM_BOOL_F);
- display_frame_expr ("(",
- copy,
- ")",
- nfield + 1 + indentation,
- sport,
- port,
- pstate);
- }
+ /* Display an application. */
+ display_application (frame, nfield + 1 + indentation, sport, port, pstate);
scm_putc ('\n', port);
-
- /* Announce missing frames? */
- if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_puts ("...\n", port);
- }
}
struct display_backtrace_args {
@@ -633,48 +594,26 @@ display_backtrace_body (struct display_backtrace_args *a)
pstate->highlight_objects = a->highlight_objects;
/* First find out if it's reasonable to do indentation. */
- if (SCM_BACKWARDS_P)
- indent_p = 0;
- else
- {
- unsigned int j;
-
- indent_p = 1;
- frame = scm_stack_ref (a->stack, scm_from_int (beg));
- for (i = 0, j = 0; i < n; ++i)
- {
- if (SCM_FRAME_REAL_P (frame))
- ++j;
- if (j > SCM_BACKTRACE_INDENT)
- {
- indent_p = 0;
- break;
- }
- frame = (SCM_BACKWARDS_P
- ? SCM_FRAME_PREV (frame)
- : SCM_FRAME_NEXT (frame));
- }
- }
+ indent_p = 0;
/* Determine size of frame number field. */
- j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end)));
+ j = end;
for (i = 0; j > 0; ++i) j /= 10;
nfield = i ? i : 1;
/* Print frames. */
- frame = scm_stack_ref (a->stack, scm_from_int (beg));
indentation = 1;
last_file = SCM_UNDEFINED;
- for (i = 0; i < n; ++i)
+ if (SCM_BACKWARDS_P)
+ end++;
+ else
+ end--;
+ for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i)
{
+ frame = scm_stack_ref (a->stack, scm_from_int (i));
if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
display_backtrace_file (frame, &last_file, a->port, pstate);
-
- display_frame (frame, nfield, indentation, sport, a->port, pstate);
- if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
- ++indentation;
- frame = (SCM_BACKWARDS_P ?
- SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
+ display_frame (frame, i, nfield, indentation, sport, a->port, pstate);
}
scm_remember_upto_here_1 (print_state);
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index c3b6f3e..3e23adf 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -878,7 +878,8 @@ bitvector_get_handle (SCM bv, scm_t_array_handle *h)
h->elements = h->writable_elements = BITVECTOR_BITS (bv);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_bitvector),
+ SCM_SMOB_TYPE_MASK,
bitvector_handle_ref, bitvector_handle_set,
bitvector_get_handle);
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 992fa3f..ac5bc16 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -2202,13 +2202,12 @@ scm_bootstrap_bytevectors (void)
/* This must be instantiated here because the generalized-vector API may
want to access bytevectors even though `(rnrs bytevector)' hasn't been
loaded. */
- scm_null_bytevector =
- scm_gc_protect_object (make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8));
+ scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8);
#ifdef WORDS_BIGENDIAN
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol
("big"));
+ scm_i_native_endianness = scm_from_locale_symbol ("big");
#else
- scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol
("little"));
+ scm_i_native_endianness = scm_from_locale_symbol ("little");
#endif
scm_c_register_extension ("libguile", "scm_init_bytevectors",
diff --git a/libguile/chars.c b/libguile/chars.c
index 59ac6f4..68e6dc1 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -43,11 +43,28 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the Unicode code point of @var{x} is equal
to the\n"
- "code point of @var{y}, else @code{#f}.\n")
-#define FUNC_NAME s_scm_char_eq_p
+SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is equal to
the\n"
+ "code point of @var{y}, else @code{#f}.\n")
+#define FUNC_NAME s_scm_i_char_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -56,11 +73,28 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the code point of @var{x} is less than the
code\n"
- "point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_less_p
+SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the code point of @var{x} is less than the
code\n"
+ "point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -68,11 +102,28 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the Unicode code point of @var{x} is less
than or\n"
- "equal to the code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_leq_p
+SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is less
than or\n"
+ "equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -80,11 +131,28 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
- "the code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_gr_p
+SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
+ "the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -92,11 +160,28 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
- "or equal to the code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_geq_p
+SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
+ "or equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -111,11 +196,28 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
implementation would be to use that table and make a char-foldcase
function. */
-SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the case-folded Unicode code point of
@var{x} is\n"
- "the same as the case-folded code point of @var{y}, else
@code{#f}.")
-#define FUNC_NAME s_scm_char_ci_eq_p
+SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
+ "the same as the case-folded code point of @var{y}, else
@code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -123,11 +225,28 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?",
scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if the case-folded Unicode code point of
@var{x} is\n"
- "less than the case-folded code point of @var{y}, else
@code{#f}.")
-#define FUNC_NAME s_scm_char_ci_less_p
+SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
+ "less than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -135,12 +254,29 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?",
scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded Unicodd code point of
@var{x} is\n"
- "less than or equal to the case-folded code point of @var{y},
else\n"
- "@code{#f}")
-#define FUNC_NAME s_scm_char_ci_leq_p
+SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicodd code point of
@var{x} is\n"
+ "less than or equal to the case-folded code point of @var{y},
else\n"
+ "@code{#f}")
+#define FUNC_NAME s_scm_i_char_ci_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -148,11 +284,28 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?",
scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is
greater\n"
- "than the case-folded code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_gr_p
+SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded code point of @var{x} is
greater\n"
+ "than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
@@ -160,12 +313,29 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?",
scm_tc7_rpsubr,
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded Unicode code point of
@var{x} is\n"
- "greater than or equal to the case-folded code point of @var{y},
else\n"
- "@code{#f}.")
-#define FUNC_NAME s_scm_char_ci_geq_p
+SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicode code point of
@var{x} is\n"
+ "greater than or equal to the case-folded code point of @var{y},
else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
diff --git a/libguile/continuations.c b/libguile/continuations.c
index a0e2f6d..aeff62e 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 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
@@ -57,7 +57,7 @@ continuation_print (SCM obj, SCM port, scm_print_state *state
SCM_UNUSED)
scm_puts ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
scm_puts (" @ ", port);
- scm_uintprint (SCM_CELL_WORD_1 (obj), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
scm_putc ('>', port);
return 1;
}
@@ -84,7 +84,6 @@ scm_make_continuation (int *first)
continuation->dynenv = scm_i_dynwinds ();
continuation->throw_value = SCM_EOL;
continuation->root = thread->continuation_root;
- continuation->dframe = scm_i_last_debug_frame ();
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
src -= stack_size;
@@ -190,8 +189,6 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
data.dst = dst;
scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
- scm_i_set_last_debug_frame (continuation->dframe);
-
continuation->throw_value = val;
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
@@ -276,17 +273,14 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM old_controot;
SCM_STACKITEM *old_contbase;
- scm_t_debug_frame *old_lastframe;
SCM result;
/* Establish a fresh continuation root.
*/
old_controot = thread->continuation_root;
old_contbase = thread->continuation_base;
- old_lastframe = thread->last_debug_frame;
thread->continuation_root = scm_cons (thread->handle, old_controot);
thread->continuation_base = &stack_item;
- thread->last_debug_frame = NULL;
/* Call FUNC inside a catch all. This is now guaranteed to return
directly and exactly once.
@@ -298,7 +292,6 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
/* Return to old continuation root.
*/
- thread->last_debug_frame = old_lastframe;
thread->continuation_base = old_contbase;
thread->continuation_root = old_controot;
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 82cf178..a04c53f 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 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
@@ -64,17 +64,12 @@ typedef struct
*/
scm_t_ptrdiff offset;
- /* The most recently created debug frame on the live stack, before
- it was saved. This needs to be adjusted with OFFSET, above.
- */
- struct scm_t_debug_frame *dframe;
-
SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
} scm_t_contregs;
#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
-#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_CELL_WORD_1 (x))
+#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_SMOB_DATA_1 (x))
#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
diff --git a/libguile/debug.c b/libguile/debug.c
index f0dd29a..0f83ea0 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -49,6 +49,7 @@
#include "libguile/fluids.h"
#include "libguile/programs.h"
#include "libguile/memoize.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/debug.h"
@@ -73,7 +74,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0,
1, 0,
scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
- if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
+ if (SCM_N_FRAMES < 1)
{
scm_options (ans, scm_debug_opts, FUNC_NAME);
SCM_OUT_OF_RANGE (1, setting);
@@ -137,19 +138,11 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
{
SCM_VALIDATE_PROC (1, proc);
switch (SCM_TYP7 (proc)) {
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
return SCM_SUBR_NAME (proc);
default:
{
SCM name = scm_procedure_property (proc, scm_sym_name);
-#if 0
- /* Source property scm_sym_procname not implemented yet... */
- SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)),
scm_sym_procname);
- if (scm_is_false (name))
- name = scm_procedure_property (proc, scm_sym_name);
-#endif
- if (scm_is_false (name) && SCM_CLOSUREP (proc))
- name = scm_reverse_lookup (SCM_ENV (proc), proc);
if (scm_is_false (name) && SCM_PROGRAM_P (proc))
name = scm_program_name (proc);
return name;
@@ -179,9 +172,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0,
0,
break;
proc = SCM_STRUCT_PROCEDURE (proc);
continue;
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- continue;
default:
break;
}
@@ -192,27 +182,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1,
0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
- (SCM proc),
- "Return the module that was current when @var{proc} was defined.")
-#define FUNC_NAME s_scm_procedure_module
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- if (scm_is_true (scm_program_p (proc)))
- return scm_program_module (proc);
- else if (SCM_CLOSUREP (proc))
- {
- SCM env = SCM_ENV (proc);
- while (scm_is_pair (env))
- env = scm_cdr (env);
- return env;
- }
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
@@ -246,52 +215,10 @@ SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
"Call @var{thunk} on an evaluator stack tagged with @var{id}.")
#define FUNC_NAME s_scm_sys_start_stack
{
- SCM answer;
- scm_t_debug_frame vframe;
- scm_t_debug_info vframe_vect_body;
- vframe.prev = scm_i_last_debug_frame ();
- vframe.status = SCM_VOIDFRAME;
- vframe.vect = &vframe_vect_body;
- vframe.vect[0].id = id;
- scm_i_set_last_debug_frame (&vframe);
- answer = scm_call_0 (thunk);
- scm_i_set_last_debug_frame (vframe.prev);
- return answer;
-}
-#undef FUNC_NAME
-
-/* {Debug Objects}
- *
- * The debugging evaluator throws these on frame traps.
- */
-
-scm_t_bits scm_tc16_debugobj;
-
-static int
-debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<debug-object ", port);
- scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a debug object.")
-#define FUNC_NAME s_scm_debug_object_p
-{
- return scm_from_bool(SCM_DEBUGOBJP (obj));
+ return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
}
#undef FUNC_NAME
-
-SCM
-scm_make_debugobj (scm_t_debug_frame *frame)
-{
- return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
-}
-
/* Undocumented debugging procedure */
@@ -337,9 +264,6 @@ scm_init_debug ()
init_stack_limit ();
scm_init_opts (scm_debug_options, scm_debug_opts);
- scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
- scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
-
scm_add_feature ("debug-extensions");
#include "libguile/debug.x"
diff --git a/libguile/debug.h b/libguile/debug.h
index 24c6b9e..6a1ee5a 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -29,22 +29,6 @@
#include "libguile/options.h"
-/*
- * Here comes some definitions for the debugging machinery.
- * It might seem strange to represent debug flags as ints,
- * but consider that any particular piece of code is normally
- * only interested in one flag at a time. This is then
- * the most efficient representation.
- */
-
-/* {Options}
- */
-
-/* scm_debug_opts is defined in eval.c.
- */
-
-
-
/* {Evaluator}
*/
@@ -55,68 +39,16 @@ typedef union scm_t_debug_info
SCM id;
} scm_t_debug_info;
-typedef struct scm_t_debug_frame
-{
- struct scm_t_debug_frame *prev;
- long status;
- scm_t_debug_info *vect;
- scm_t_debug_info *info;
-} scm_t_debug_frame;
-
-#define SCM_EVALFRAME (0L << 11)
-#define SCM_APPLYFRAME (1L << 11)
-#define SCM_VOIDFRAME (3L << 11)
-#define SCM_MACROEXPF (1L << 10)
-#define SCM_TAILREC (1L << 9)
-#define SCM_TRACED_FRAME (1L << 8)
-#define SCM_ARGS_READY (1L << 7)
-#define SCM_DOVERFLOW (1L << 6)
-#define SCM_MAX_FRAME_SIZE 63
-
-#define SCM_FRAMETYPE (3L << 11)
-
-#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME)
-#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME)
-#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME)
-#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
-#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
-#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
-#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
-#define SCM_MACROEXPP(x) (((x).status & SCM_MACROEXPF) != 0)
-#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
-#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
-#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
-#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
-#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
-#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
-#define SCM_SET_MACROEXP(x) ((x).status |= SCM_MACROEXPF)
-#define SCM_CLEAR_MACROEXP(x) ((x).status &= ~SCM_MACROEXPF)
-
-/* {Debug Objects}
- */
-
-SCM_API scm_t_bits scm_tc16_debugobj;
-
-#define SCM_DEBUGOBJP(x) \
- SCM_TYP16_PREDICATE (scm_tc16_debugobj, x)
-#define SCM_DEBUGOBJ_FRAME(x) \
- ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
-#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
-
-SCM_API SCM scm_debug_object_p (SCM obj);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
-SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);
-SCM_API SCM scm_make_debugobj (scm_t_debug_frame *debug);
-SCM_INTERNAL SCM scm_i_unmemoize_expr (SCM memoized);
SCM_INTERNAL void scm_init_debug (void);
#ifdef GUILE_DEBUG
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 1f35d2a..c53776c 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -55,6 +55,7 @@
#include "libguile/socket.h"
#include "libguile/feature.h"
+#include <math.h>
#include <stdio.h>
#include <string.h>
@@ -248,15 +249,13 @@ static SCM try_module_autoload_var;
static void
init_module_stuff ()
{
-#define PERM(x) scm_permanent_object(x)
-
if (module_prefix == SCM_BOOL_F)
{
- module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
- make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
+ module_prefix = scm_list_2 (scm_sym_app, scm_sym_modules);
+ make_modules_in_var = scm_c_lookup ("make-modules-in");
beautify_user_module_x_var =
- PERM (scm_c_lookup ("beautify-user-module!"));
- try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
+ scm_c_lookup ("beautify-user-module!");
+ try_module_autoload_var = scm_c_lookup ("try-module-autoload");
}
}
@@ -424,7 +423,7 @@ scm_create_hook (const char *name, int n_args)
{
SCM hook = scm_make_hook (scm_from_int (n_args));
scm_c_define (name, hook);
- return scm_permanent_object (hook);
+ return hook;
}
}
@@ -626,7 +625,7 @@ scm_smob_free (SCM obj)
"It is no longer needed.");
if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
+ scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
scm_smobs[n].size, SCM_SMOBNAME (n));
return 0;
}
@@ -1215,6 +1214,58 @@ scm_round (double x)
return scm_c_round (x);
}
+SCM
+scm_sys_expt (SCM x, SCM y)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_expt is deprecated. Use scm_expt instead.");
+ return scm_expt (x, y);
+}
+
+double
+scm_asinh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_asinh is deprecated. Use asinh instead.");
+#if HAVE_ASINH
+ return asinh (x);
+#else
+ return log (x + sqrt (x * x + 1));
+#endif
+}
+
+double
+scm_acosh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_acosh is deprecated. Use acosh instead.");
+#if HAVE_ACOSH
+ return acosh (x);
+#else
+ return log (x + sqrt (x * x - 1));
+#endif
+}
+
+double
+scm_atanh (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_atanh is deprecated. Use atanh instead.");
+#if HAVE_ATANH
+ return atanh (x);
+#else
+ return 0.5 * log ((1 + x) / (1 - x));
+#endif
+}
+
+SCM
+scm_sys_atan2 (SCM z1, SCM z2)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
+ return scm_atan (z1, z2);
+}
+
char *
scm_i_deprecated_symbol_chars (SCM sym)
{
@@ -1416,14 +1467,6 @@ scm_i_deprecated_dynwinds (void)
return scm_i_dynwinds ();
}
-scm_t_debug_frame *
-scm_i_deprecated_last_debug_frame (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_last_debug_frame is deprecated. Do not use it.");
- return scm_i_last_debug_frame ();
-}
-
SCM_STACKITEM *
scm_i_stack_base (void)
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 5570a43..be56d37 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -240,8 +240,6 @@ SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define scm_option scm_t_option
#define scm_srcprops scm_t_srcprops
#define scm_srcprops_chunk scm_t_srcprops_chunk
-#define scm_info_frame scm_t_info_frame
-#define scm_stack scm_t_stack
#define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim
#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
@@ -402,6 +400,14 @@ SCM_DEPRECATED char *scm_c_symbol2str (SCM obj, char *str,
size_t *lenp);
*/
SCM_DEPRECATED double scm_truncate (double x);
SCM_DEPRECATED double scm_round (double x);
+/* Deprecated, use scm_expt */
+SCM_DEPRECATED SCM scm_sys_expt (SCM x, SCM y);
+
+/* if your platform doesn't have asinh et al */
+SCM_API double scm_asinh (double x);
+SCM_API double scm_acosh (double x);
+SCM_API double scm_atanh (double x);
+SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
/* Deprecated because we don't want people to access the internal
representation of strings directly.
@@ -499,7 +505,6 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define scm_cur_loadp scm_i_cur_loadp ()
#define scm_progargs scm_i_progargs ()
#define scm_dynwinds scm_i_deprecated_dynwinds ()
-#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
#define scm_stack_base scm_i_stack_base ()
SCM_DEPRECATED SCM scm_i_cur_inp (void);
@@ -508,7 +513,6 @@ SCM_DEPRECATED SCM scm_i_cur_errp (void);
SCM_DEPRECATED SCM scm_i_cur_loadp (void);
SCM_DEPRECATED SCM scm_i_progargs (void);
SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void);
-SCM_DEPRECATED scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void);
/* Deprecated because it evaluates its argument twice.
@@ -596,6 +600,14 @@ SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM
proc);
SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
+
+/* Deprecated 2009-12-06, use the procedures instead */
+#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true
(scm_procedure_with_setter_p (obj)))
+#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0)
+#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1)
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/eq.c b/libguile/eq.c
index 6cb9bc2..eaf1acc 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -30,6 +30,7 @@
#include "libguile/smob.h"
#include "libguile/arrays.h"
#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
#include "libguile/bytevectors.h"
#include "libguile/struct.h"
@@ -47,8 +48,8 @@
#endif
-SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
- (SCM x, SCM y),
+SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object,\n"
"except for numbers and characters. For example,\n"
"\n"
@@ -87,12 +88,28 @@ SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
"(define x (string->symbol \"foo\"))\n"
"(eq? x 'foo) @result{} #t\n"
"@end example")
-#define FUNC_NAME s_scm_eq_p
+#define FUNC_NAME s_scm_i_eq_p
{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (scm_is_pair (rest))
+ {
+ if (!scm_is_eq (x, y))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME
+SCM
+scm_eq_p (SCM x, SCM y)
+{
+ return scm_from_bool (scm_is_eq (x, y));
+}
+
/* We compare doubles in a special way for 'eqv?' to be able to
distinguish plus and minus zero and to identify NaNs.
*/
@@ -104,8 +121,8 @@ real_eqv (double x, double y)
}
#include <stdio.h>
-SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
- (SCM x, SCM y),
+SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
"for characters and numbers the same value.\n"
"\n"
@@ -122,7 +139,24 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
"(eqv? 3 (+ 1 2)) @result{} #t\n"
"(eqv? 1 1.0) @result{} #f\n"
"@end example")
-#define FUNC_NAME s_scm_eqv_p
+#define FUNC_NAME s_scm_i_eqv_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (!scm_is_true (scm_eqv_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_eqv_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_eqv_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_eqv_p
{
if (scm_is_eq (x, y))
return SCM_BOOL_T;
@@ -178,44 +212,63 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
#undef FUNC_NAME
-SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
- "their contents or value are equal.\n"
- "\n"
- "For a pair, string, vector or array, @code{equal?} compares the\n"
- "contents, and does so using using the same @code{equal?}\n"
- "recursively, so a deep structure can be traversed.\n"
- "\n"
- "@example\n"
- "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
- "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
- "@end example\n"
- "\n"
- "For other objects, @code{equal?} compares as per @code{eqv?},\n"
- "which means characters and numbers are compared by type and\n"
- "value (and like @code{eqv?}, exact and inexact numbers are not\n"
- "@code{equal?}, even if their value is the same).\n"
- "\n"
- "@example\n"
- "(equal? 3 (+ 1 2)) @result{} #t\n"
- "(equal? 1 1.0) @result{} #f\n"
- "@end example\n"
- "\n"
- "Hash tables are currently only compared as per @code{eq?}, so\n"
- "two different tables are not @code{equal?}, even if their\n"
- "contents are the same.\n"
- "\n"
- "@code{equal?} does not support circular data structures, it may\n"
- "go into an infinite loop if asked to compare two circular lists\n"
- "or similar.\n"
- "\n"
- "New application-defined object types (Smobs) have an\n"
- "@code{equalp} handler which is called by @code{equal?}. This\n"
- "lets an application traverse the contents or control what is\n"
- "considered @code{equal?} for two such objects. If there's no\n"
- "handler, the default is to just compare as per @code{eq?}.")
-#define FUNC_NAME s_scm_equal_p
+SCM scm_i_equal_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if @var{x} and @var{y} are the same
type, and\n"
+ "their contents or value are equal.\n"
+ "\n"
+ "For a pair, string, vector or array, @code{equal?}
compares the\n"
+ "contents, and does so using using the same
@code{equal?}\n"
+ "recursively, so a deep structure can be traversed.\n"
+ "\n"
+ "@example\n"
+ "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
+ "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "For other objects, @code{equal?} compares as per
@code{eqv?},\n"
+ "which means characters and numbers are compared by
type and\n"
+ "value (and like @code{eqv?}, exact and inexact numbers
are not\n"
+ "@code{equal?}, even if their value is the same).\n"
+ "\n"
+ "@example\n"
+ "(equal? 3 (+ 1 2)) @result{} #t\n"
+ "(equal? 1 1.0) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "Hash tables are currently only compared as per
@code{eq?}, so\n"
+ "two different tables are not @code{equal?}, even if
their\n"
+ "contents are the same.\n"
+ "\n"
+ "@code{equal?} does not support circular data
structures, it may\n"
+ "go into an infinite loop if asked to compare two
circular lists\n"
+ "or similar.\n"
+ "\n"
+ "New application-defined object types (Smobs) have an\n"
+ "@code{equalp} handler which is called by
@code{equal?}. This\n"
+ "lets an application traverse the contents or control
what is\n"
+ "considered @code{equal?} for two such objects. If
there's no\n"
+ "handler, the default is to just compare as per
@code{eq?}.")
+#define FUNC_NAME s_scm_i_equal_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (!scm_is_true (scm_equal_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = SCM_CDR (rest);
+ }
+ return scm_equal_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM
+scm_equal_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_equal_p
{
SCM_CHECK_STACK;
tailrecurse:
@@ -306,8 +359,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?",
scm_tc7_rpsubr,
return SCM_BOOL_F;
generic_equal:
- if (SCM_UNPACK (g_scm_equal_p))
- return scm_call_generic_2 (g_scm_equal_p, x, y);
+ if (SCM_UNPACK (g_scm_i_equal_p))
+ return scm_call_generic_2 (g_scm_i_equal_p, x, y);
else
return SCM_BOOL_F;
}
diff --git a/libguile/eval.c b/libguile/eval.c
index d540595..ec19c23 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -97,6 +97,21 @@
*/
+/* Boot closures. We only see these when compiling eval.scm, because once
+ eval.scm is in the house, closures are standard VM closures.
+ */
+
+static scm_t_bits scm_tc16_boot_closure;
+#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2
(scm_tc16_boot_closure, (code), (env))
+#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
+#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
+#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE
(x)))
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE
(x)))
+#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
+
+
+
#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
@@ -192,7 +207,7 @@ eval (SCM x, SCM env)
}
case SCM_M_LAMBDA:
- return scm_closure (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
@@ -210,11 +225,11 @@ eval (SCM x, SCM env)
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc);
@@ -229,7 +244,7 @@ eval (SCM x, SCM env)
for (; scm_is_pair (args); args = CDR (args))
new_env = scm_cons (CAR (args), new_env);
}
- x = SCM_CLOSURE_BODY (proc);
+ x = BOOT_CLOSURE_BODY (proc);
env = new_env;
goto loop;
}
@@ -242,11 +257,11 @@ eval (SCM x, SCM env)
mx = CDR (mx);
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
scm_wrong_num_args (proc);
@@ -267,7 +282,7 @@ eval (SCM x, SCM env)
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
}
- x = SCM_CLOSURE_BODY (proc);
+ x = BOOT_CLOSURE_BODY (proc);
env = new_env;
goto loop;
}
@@ -390,42 +405,6 @@ eval (SCM x, SCM env)
}
}
-SCM
-scm_closure_apply (SCM proc, SCM args)
-{
- unsigned int nargs;
- int nreq;
- SCM env;
-
- /* Args contains a list of all args. */
- {
- int ilen = scm_ilength (args);
- if (ilen < 0)
- scm_wrong_num_args (proc);
- nargs = ilen;
- }
-
- nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
- {
- if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- env = scm_cons (CAR (args), env);
- env = scm_cons (args, env);
- }
- else
- {
- for (; scm_is_pair (args); args = CDR (args), nreq--)
- env = scm_cons (CAR (args), env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
- }
- return eval (SCM_CLOSURE_BODY (proc), env);
-}
-
-
scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine
words)." },
{ 0 }
@@ -543,56 +522,34 @@ SCM_DEFINE (scm_evaluator_traps,
"evaluator-traps-interface", 0, 1, 0,
SCM
scm_call_0 (SCM proc)
{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
- else
- return scm_apply (proc, SCM_EOL, SCM_EOL);
+ return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
- else
- return scm_apply (proc, arg1, scm_listofnull);
+ return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
}
SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 2);
- }
- else
- return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+ SCM args[] = { arg1, arg2 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 2);
}
SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 3);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+ SCM args[] = { arg1, arg2, arg3 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 3);
}
SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3, arg4 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 4);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
- scm_cons (arg4, scm_listofnull)));
+ SCM args[] = { arg1, arg2, arg3, arg4 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 4);
}
/* Simple procedure applies
@@ -836,18 +793,6 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME
-SCM
-scm_closure (SCM code, SCM env)
-{
- SCM z;
- SCM closcar = scm_cons (code, SCM_EOL);
- z = scm_immutable_cell (SCM_UNPACK (closcar) + scm_tc3_closure,
- (scm_t_bits) env);
- scm_remember_upto_here (closcar);
- return z;
-}
-
-
static SCM
scm_c_primitive_eval (SCM exp)
{
@@ -929,6 +874,45 @@ scm_apply (SCM proc, SCM arg1, SCM args)
}
+static SCM
+boot_closure_apply (SCM closure, SCM args)
+{
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
+ SCM new_env = BOOT_CLOSURE_ENV (closure);
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (closure);
+ for (; nreq; nreq--, args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ new_env = scm_cons (args, new_env);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (closure);
+ for (; scm_is_pair (args); args = CDR (args))
+ new_env = scm_cons (CAR (args), new_env);
+ }
+ return eval (BOOT_CLOSURE_BODY (closure), new_env);
+}
+
+static int
+boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
+{
+ SCM args;
+ scm_puts ("#<boot-closure ", port);
+ scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
+ scm_putc (' ', port);
+ args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS
(closure)),
+ scm_from_locale_symbol ("_"));
+ if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ scm_display (args, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
void
scm_init_eval ()
{
@@ -939,10 +923,11 @@ scm_init_eval ()
scm_init_opts (scm_eval_options_interface,
scm_eval_opts);
- scm_listofnull = scm_list_1 (SCM_EOL);
+ f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
- f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
- scm_permanent_object (f_apply);
+ scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
+ scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
+ scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
scm_c_primitive_eval);
diff --git a/libguile/eval.h b/libguile/eval.h
index 62b84c1..6341f14 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -73,14 +73,11 @@ SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
-SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
-SCM_INTERNAL SCM scm_closure_apply (SCM proc, SCM args);
#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
-SCM_API SCM scm_closure (SCM code, SCM env);
SCM_API SCM scm_primitive_eval (SCM exp);
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 78b666f..84218b3 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -75,16 +75,17 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1,
0, 0,
case scm_tc3_cons:
switch (SCM_TYP7 (obj))
{
- case scm_tcs_closures:
case scm_tc7_vector:
case scm_tc7_wvect:
+ case scm_tc7_hashtable:
+ case scm_tc7_fluid:
+ case scm_tc7_dynamic_state:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
- case scm_tc7_pws:
case scm_tc7_program:
case scm_tc7_bytevector:
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/feature.c b/libguile/feature.c
index 9ef4b65..7007403 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007,
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
@@ -99,7 +99,7 @@ SCM_DEFINE (scm_set_program_arguments_scm,
"set-program-arguments", 1, 0, 0,
void
scm_init_feature()
{
- progargs_fluid = scm_permanent_object (scm_make_fluid ());
+ progargs_fluid = scm_make_fluid ();
features_var = scm_c_define ("*features*", SCM_EOL);
#ifndef _Windows
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 311f1ef..02f2da6 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -852,7 +852,7 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
if (ds == NULL)
SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds);
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
}
#undef FUNC_NAME
@@ -893,7 +893,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
somewhere in the smob, or just the dirent size calculated once. */
{
struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_CELL_WORD_1 (port);
+ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
size_t namlen;
#ifdef NAME_MAX
char buf [SCM_MAX (sizeof (de),
@@ -926,7 +926,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_CELL_WORD_1
(port)));
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1
(port)));
if (errno != 0)
SCM_SYSERROR;
@@ -951,7 +951,7 @@ SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
if (!SCM_DIR_OPEN_P (port))
SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
- rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
+ rewinddir ((DIR *) SCM_SMOB_DATA_1 (port));
return SCM_UNSPECIFIED;
}
@@ -970,11 +970,11 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
{
int sts;
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
if (sts != 0)
SCM_SYSERROR;
- SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
+ SCM_SET_SMOB_DATA_0 (port, scm_tc16_dir);
}
return SCM_UNSPECIFIED;
@@ -989,7 +989,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
if (!SCM_DIR_OPEN_P (exp))
scm_puts ("closed: ", port);
scm_puts ("directory stream ", port);
- scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
scm_putc ('>', port);
return 1;
}
@@ -999,7 +999,7 @@ static size_t
scm_dir_free (SCM p)
{
if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_CELL_WORD_1 (p));
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
return 0;
}
@@ -1712,7 +1712,7 @@ scm_init_filesys ()
scm_set_smob_free (scm_tc16_dir, scm_dir_free);
scm_set_smob_print (scm_tc16_dir, scm_dir_print);
- scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
+ scm_dot_string = scm_from_locale_string (".");
#ifdef O_RDONLY
scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
diff --git a/libguile/filesys.h b/libguile/filesys.h
index b9a6ca8..a07f204 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -3,7 +3,7 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 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
@@ -29,10 +29,10 @@
SCM_API scm_t_bits scm_tc16_dir;
-#define SCM_DIR_FLAG_OPEN (1L << 16)
+#define SCM_DIR_FLAG_OPEN (1L << 0)
#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
-#define SCM_DIR_OPEN_P(x) (SCM_CELL_WORD_0 (x) & SCM_DIR_FLAG_OPEN)
+#define SCM_DIR_OPEN_P(x) (SCM_SMOB_FLAGS (x) & SCM_DIR_FLAG_OPEN)
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 75dcccf..427d406 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -26,7 +26,6 @@
#include "libguile/_scm.h"
#include "libguile/print.h"
-#include "libguile/smob.h"
#include "libguile/dynwind.h"
#include "libguile/fluids.h"
#include "libguile/alist.h"
@@ -66,22 +65,12 @@ static size_t allocated_fluids_len = 0;
static size_t allocated_fluids_num = 0;
static char *allocated_fluids = NULL;
-static scm_t_bits tc16_fluid;
+#define IS_FLUID(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
+#define FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
-#define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
-#define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
-#define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
-#define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
-#define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
-
-static scm_t_bits tc16_dynamic_state;
-
-#define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
-#define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
-#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
-#define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
-#define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
-#define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
+#define IS_DYNAMIC_STATE(x) (!SCM_IMP (x) && SCM_TYP7 (x) ==
scm_tc7_dynamic_state)
+#define DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
+#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK
(y)))
@@ -115,13 +104,20 @@ grow_dynamic_state (SCM state)
scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
}
-static int
-fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+void
+scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
scm_putc ('>', port);
- return 1;
+}
+
+void
+scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
+{
+ scm_puts ("#<dynamic-state ", port);
+ scm_intprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
}
static size_t
@@ -190,12 +186,7 @@ SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
"with its own dynamic state, you can use fluids for thread local
storage.")
#define FUNC_NAME s_scm_make_fluid
{
- SCM fluid;
-
- SCM_NEWSMOB2 (fluid, tc16_fluid,
- (scm_t_bits) next_fluid_num (), SCM_UNPACK (SCM_EOL));
-
- return fluid;
+ return scm_cell (scm_tc7_fluid, (scm_t_bits) next_fluid_num ());
}
#undef FUNC_NAME
@@ -406,10 +397,7 @@ SCM
scm_i_make_initial_dynamic_state ()
{
SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
- SCM state;
- SCM_NEWSMOB2 (state, tc16_dynamic_state,
- SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
- return state;
+ return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
}
SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
@@ -418,17 +406,14 @@ SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state",
0, 1, 0,
"or of the current dynamic state when @var{parent} is omitted.")
#define FUNC_NAME s_scm_make_dynamic_state
{
- SCM fluids, state;
+ SCM fluids;
if (SCM_UNBNDP (parent))
parent = scm_current_dynamic_state ();
- scm_assert_smob_type (tc16_dynamic_state, parent);
+ SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME);
fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
- SCM_NEWSMOB2 (state, tc16_dynamic_state,
- SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
-
- return state;
+ return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
}
#undef FUNC_NAME
@@ -465,7 +450,7 @@ SCM_DEFINE (scm_set_current_dynamic_state,
"set-current-dynamic-state", 1,0,0,
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
SCM old = t->dynamic_state;
- scm_assert_smob_type (tc16_dynamic_state, state);
+ SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME);
t->dynamic_state = state;
return old;
}
@@ -481,7 +466,7 @@ void
scm_dynwind_current_dynamic_state (SCM state)
{
SCM loc = scm_cons (state, SCM_EOL);
- scm_assert_smob_type (tc16_dynamic_state, state);
+ SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL);
scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
@@ -514,14 +499,6 @@ SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state",
2, 0, 0,
}
#undef FUNC_NAME
-void
-scm_fluids_prehistory ()
-{
- tc16_fluid = scm_make_smob_type ("fluid", 0);
- scm_set_smob_print (tc16_fluid, fluid_print);
-
- tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0);
-}
void
scm_init_fluids ()
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 2bfcce5..3a651fb 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -3,7 +3,7 @@
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
-/* Copyright (C) 1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 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
@@ -29,18 +29,17 @@
/* Fluids.
- Fluids are objects of a certain type (a smob) that can hold one SCM
- value per dynamic state. That is, modifications to this value are
- only visible to code that executes with the same dynamic state as
- the modifying code. When a new dynamic state is constructed, it
- inherits the values from its parent. Because each thread executes
- with its own dynamic state, you can use fluids for thread local
- storage.
-
- Each fluid is identified by a small integer. This integer is used
- to index a vector that holds the values of all fluids. A dynamic
- state consists of this vector, wrapped in a smob so that the vector
- can grow.
+ Fluids are objects of a certain type that can hold one SCM value per
+ dynamic state. That is, modifications to this value are only visible
+ to code that executes with the same dynamic state as the modifying
+ code. When a new dynamic state is constructed, it inherits the
+ values from its parent. Because each thread executes with its own
+ dynamic state, you can use fluids for thread local storage.
+
+ Each fluid is identified by a small integer. This integer is used to
+ index a vector that holds the values of all fluids. A dynamic state
+ consists of this vector, wrapped in an object so that the vector can
+ grow.
*/
/* The fastest way to acces/modify the value of a fluid. These macros
@@ -78,7 +77,8 @@ SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc);
SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void);
-SCM_INTERNAL void scm_fluids_prehistory (void);
+SCM_INTERNAL void scm_i_fluid_print (SCM exp, SCM port, scm_print_state
*pstate);
+SCM_INTERNAL void scm_i_dynamic_state_print (SCM exp, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
diff --git a/libguile/frames.c b/libguile/frames.c
index c0d7d61..e38fc00 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -27,31 +27,31 @@
#include "frames.h"
-scm_t_bits scm_tc16_vm_frame;
+scm_t_bits scm_tc16_frame;
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset)
+scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
- struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
- "vmframe");
+ struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
+ "vmframe");
p->stack_holder = stack_holder;
p->fp = fp;
p->sp = sp;
p->ip = ip;
p->offset = offset;
- SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
+ SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
}
static int
-vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
+frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-frame ", port);
+ scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
scm_putc (' ', port);
- scm_write (scm_vm_frame_program (frame), port);
+ scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts (">", port);
@@ -61,28 +61,29 @@ vm_frame_print (SCM frame, SCM port, scm_print_state
*pstate)
/* Scheme interface */
-SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"")
-#define FUNC_NAME s_scm_vm_frame_p
+#define FUNC_NAME s_scm_frame_p
{
return scm_from_bool (SCM_VM_FRAME_P (obj));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
+SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_program
+#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_VM_FRAME (1, frame);
return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
}
#undef FUNC_NAME
-SCM
-scm_vm_frame_arguments (SCM frame)
-#define FUNC_NAME "vm-frame-arguments"
+SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_arguments
{
static SCM var = SCM_BOOL_F;
@@ -90,16 +91,16 @@ scm_vm_frame_arguments (SCM frame)
if (scm_is_false (var))
var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
- "vm-frame-arguments");
+ "frame-arguments");
return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
+SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_source
+#define FUNC_NAME s_scm_frame_source
{
SCM *fp;
struct scm_objcode *bp;
@@ -118,11 +119,11 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0,
0,
the presence of not-yet-active frames on the stack. So we have a cheap
heuristic to detect not-yet-active frames, and skip over them. Perhaps we
should represent them more usefully.
- */
-SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
+*/
+SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_num_locals
+#define FUNC_NAME s_scm_frame_num_locals
{
SCM *sp, *p;
unsigned int n = 0;
@@ -146,11 +147,11 @@ SCM_DEFINE (scm_vm_frame_num_locals,
"vm-frame-num-locals", 1, 0, 0,
}
#undef FUNC_NAME
-/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
-SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
+/* Need same not-yet-active frame logic here as in frame-num-locals */
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
-#define FUNC_NAME s_scm_vm_frame_local_ref
+#define FUNC_NAME s_scm_frame_local_ref
{
SCM *sp, *p;
unsigned int n = 0;
@@ -178,11 +179,11 @@ SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref",
2, 0, 0,
}
#undef FUNC_NAME
-/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
-SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
+/* Need same not-yet-active frame logic here as in frame-num-locals */
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
-#define FUNC_NAME s_scm_vm_frame_local_set_x
+#define FUNC_NAME s_scm_frame_local_set_x
{
SCM *sp, *p;
unsigned int n = 0;
@@ -213,22 +214,22 @@ SCM_DEFINE (scm_vm_frame_local_set_x,
"vm-frame-local-set!", 3, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer",
1, 0, 0,
+SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0,
0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_instruction_pointer
+#define FUNC_NAME s_scm_frame_instruction_pointer
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
(SCM_VM_FRAME_IP (frame)
- - SCM_PROGRAM_DATA (scm_vm_frame_program
(frame))->base));
+ - SCM_PROGRAM_DATA (scm_frame_procedure
(frame))->base));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_return_address
+#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
@@ -237,10 +238,10 @@ SCM_DEFINE (scm_vm_frame_return_address,
"vm-frame-return-address", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1,
0, 0,
+SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_mv_return_address
+#define FUNC_NAME s_scm_frame_mv_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
return scm_from_ulong ((unsigned long)
@@ -249,10 +250,10 @@ SCM_DEFINE (scm_vm_frame_mv_return_address,
"vm-frame-mv-return-address", 1, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
-#define FUNC_NAME s_scm_vm_frame_dynamic_link
+#define FUNC_NAME s_scm_frame_dynamic_link
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */
@@ -264,7 +265,7 @@ SCM_DEFINE (scm_vm_frame_dynamic_link,
"vm-frame-dynamic-link", 1, 0, 0,
#undef FUNC_NAME
extern SCM
-scm_c_vm_frame_prev (SCM frame)
+scm_c_frame_prev (SCM frame)
{
SCM *this_fp, *new_fp, *new_sp;
this_fp = SCM_VM_FRAME_FP (frame);
@@ -272,10 +273,10 @@ scm_c_vm_frame_prev (SCM frame)
if (new_fp)
{ new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
- return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
- new_fp, new_sp,
- SCM_FRAME_RETURN_ADDRESS (this_fp),
- SCM_VM_FRAME_OFFSET (frame));
+ return scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
+ new_fp, new_sp,
+ SCM_FRAME_RETURN_ADDRESS (this_fp),
+ SCM_VM_FRAME_OFFSET (frame));
}
else
return SCM_BOOL_F;
@@ -285,8 +286,8 @@ scm_c_vm_frame_prev (SCM frame)
void
scm_bootstrap_frames (void)
{
- scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
- scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
+ scm_tc16_frame = scm_make_smob_type ("frame", 0);
+ scm_set_smob_print (scm_tc16_frame, frame_print);
scm_c_register_extension ("libguile", "scm_init_frames",
(scm_t_extension_init_func)scm_init_frames, NULL);
}
diff --git a/libguile/frames.h b/libguile/frames.h
index f744c2b..45ade5a 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -27,6 +27,16 @@
* VM frames
*/
+/*
+ * It's a little confusing, but there are two representations of frames in this
+ * file: frame pointers and Scheme objects wrapping those frame pointers. The
+ * former uses the SCM_FRAME_... macro prefix, the latter SCM_VM_FRAME_..
+ * prefix.
+ *
+ * The confusing thing is that only Scheme frame objects have functions that
use
+ * them, and they use the scm_frame_.. prefix. Hysterical raisins.
+ */
+
/* VM Frame Layout
---------------
@@ -77,9 +87,9 @@
* Heap frames
*/
-SCM_API scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_frame;
-struct scm_vm_frame
+struct scm_frame
{
SCM stack_holder;
SCM *fp;
@@ -88,8 +98,8 @@ struct scm_vm_frame
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
@@ -97,21 +107,21 @@ struct scm_vm_frame
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset);
-SCM_API SCM scm_vm_frame_p (SCM obj);
-SCM_API SCM scm_vm_frame_program (SCM frame);
-SCM_API SCM scm_vm_frame_arguments (SCM frame);
-SCM_API SCM scm_vm_frame_source (SCM frame);
-SCM_API SCM scm_vm_frame_num_locals (SCM frame);
-SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-SCM_API SCM scm_vm_frame_instruction_pointer (SCM frame);
-SCM_API SCM scm_vm_frame_return_address (SCM frame);
-SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
-SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-
-SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
+ scm_t_uint8 *ip, scm_t_ptrdiff offset);
+SCM_API SCM scm_frame_p (SCM obj);
+SCM_API SCM scm_frame_procedure (SCM frame);
+SCM_API SCM scm_frame_arguments (SCM frame);
+SCM_API SCM scm_frame_source (SCM frame);
+SCM_API SCM scm_frame_num_locals (SCM frame);
+SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
+SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_frame_instruction_pointer (SCM frame);
+SCM_API SCM scm_frame_return_address (SCM frame);
+SCM_API SCM scm_frame_mv_return_address (SCM frame);
+SCM_API SCM scm_frame_dynamic_link (SCM frame);
+
+SCM_API SCM scm_c_frame_prev (SCM frame);
SCM_INTERNAL void scm_bootstrap_frames (void);
SCM_INTERNAL void scm_init_frames (void);
diff --git a/libguile/gc.c b/libguile/gc.c
index 96e3c30..38051e1 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -90,6 +90,9 @@ int scm_debug_cells_gc_interval = 0;
*/
int scm_i_cell_validation_already_running ;
+static SCM protects;
+
+
#if (SCM_DEBUG_CELL_ACCESSES == 1)
@@ -505,7 +508,7 @@ scm_gc_protect_object (SCM obj)
critsec/mutex inconsistency here. */
SCM_CRITICAL_SECTION_START;
- handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
+ handle = scm_hashq_create_handle_x (protects, obj, scm_from_int (0));
SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
protected_obj_count ++;
@@ -535,7 +538,7 @@ scm_gc_unprotect_object (SCM obj)
abort ();
}
- handle = scm_hashq_get_handle (scm_protects, obj);
+ handle = scm_hashq_get_handle (protects, obj);
if (scm_is_false (handle))
{
@@ -546,7 +549,7 @@ scm_gc_unprotect_object (SCM obj)
{
SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
if (scm_is_eq (count, scm_from_int (0)))
- scm_hashq_remove_x (scm_protects, obj);
+ scm_hashq_remove_x (protects, obj);
else
SCM_SETCDR (handle, count);
}
@@ -631,10 +634,10 @@ scm_storage_prehistory ()
pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
handled in `scm_alloc_struct ()'. */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
- GC_REGISTER_DISPLACEMENT (scm_tc3_closure);
+ /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */
- if (!GC_is_visible (scm_sys_protects))
+ if (!GC_is_visible (&protects))
abort ();
scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
@@ -646,14 +649,10 @@ scm_storage_prehistory ()
scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-int
-scm_init_storage ()
+void
+scm_init_gc_protect_object ()
{
- size_t j;
-
- j = SCM_NUM_PROTECTS;
- while (j)
- scm_sys_protects[--j] = SCM_BOOL_F;
+ protects = scm_c_make_hash_table (31);
#if 0
/* We can't have a cleanup handler since we have no thread to run it
@@ -668,10 +667,6 @@ scm_init_storage ()
#endif
#endif
-
- scm_protects = scm_c_make_hash_table (31);
-
- return 0;
}
@@ -754,18 +749,16 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)";
case scm_tcs_cons_nimcar:
return "cons (non-immediate car)";
- case scm_tcs_closures:
- return "closures";
- case scm_tc7_pws:
- return "pws";
+ case scm_tc7_hashtable:
+ return "hashtable";
+ case scm_tc7_fluid:
+ return "fluid";
+ case scm_tc7_dynamic_state:
+ return "dynamic state";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
return "vector";
-#ifdef CCLO
- case scm_tc7_cclo:
- return "compiled closure";
-#endif
case scm_tc7_number:
switch (tag)
{
@@ -795,8 +788,8 @@ scm_i_tag_name (scm_t_bits tag)
case scm_tc7_variable:
return "variable";
break;
- case scm_tcs_subrs:
- return "subrs";
+ case scm_tc7_gsubr:
+ return "gsubr";
break;
case scm_tc7_port:
return "port";
@@ -817,11 +810,10 @@ scm_init_gc ()
{
/* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'. */
- scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
+ scm_after_gc_hook = scm_make_hook (SCM_INUM0);
scm_c_define ("after-gc-hook", scm_after_gc_hook);
- gc_async = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0,
- gc_async_thunk);
+ gc_async = scm_c_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk);
scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
diff --git a/libguile/gc.h b/libguile/gc.h
index 34c9b84..05b08af 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -237,9 +237,9 @@ SCM_API void scm_gc_register_root (SCM *p);
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
-SCM_API void scm_storage_prehistory (void);
-SCM_API int scm_init_storage (void);
-SCM_API void scm_init_gc (void);
+SCM_INTERNAL void scm_storage_prehistory (void);
+SCM_INTERNAL void scm_init_gc_protect_object (void);
+SCM_INTERNAL void scm_init_gc (void);
#if SCM_ENABLE_DEPRECATED == 1
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 351b7ba..7cc9535 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -166,7 +166,7 @@ gdb_read (char *str)
}
}
gdb_result = ans;
- /* Protect answer from future GC */
+ /* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
if (SCM_NIMP (ans))
scm_permanent_object (ans);
exit:
diff --git a/libguile/goops.c b/libguile/goops.c
index dcb1b7d..a402fc5 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -132,7 +132,7 @@ static scm_t_rstate *goops_rstate;
/* These variables are filled in by the object system when loaded. */
SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
-SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
+SCM scm_class_primitive_generic;
SCM scm_class_vector, scm_class_null;
SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
SCM scm_class_unknown;
@@ -158,6 +158,10 @@ SCM scm_class_protected_hidden,
scm_class_protected_opaque, scm_class_protected_
SCM scm_class_scm;
SCM scm_class_int, scm_class_float, scm_class_double;
+static SCM class_hashtable;
+static SCM class_fluid;
+static SCM class_dynamic_state;
+
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
offsets. See `SCM_IN_PCLASS_INDEX' et al. */
@@ -205,13 +209,17 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
{
case scm_tcs_cons_nimcar:
return scm_class_pair;
- case scm_tcs_closures:
- return scm_class_procedure;
case scm_tc7_symbol:
return scm_class_symbol;
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_class_vector;
+ case scm_tc7_hashtable:
+ return class_hashtable;
+ case scm_tc7_fluid:
+ return class_fluid;
+ case scm_tc7_dynamic_state:
+ return class_dynamic_state;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
@@ -225,27 +233,13 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_asubr:
- case scm_tc7_subr_0:
- case scm_tc7_subr_1:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- case scm_tc7_subr_3:
- case scm_tc7_subr_2:
- case scm_tc7_rpsubr:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_lsubr_2:
- case scm_tc7_lsubr:
+ case scm_tc7_gsubr:
if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_gsubr:
case scm_tc7_program:
return scm_class_procedure;
- case scm_tc7_pws:
- return scm_class_procedure_with_setter;
case scm_tc7_smob:
{
@@ -304,7 +298,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc3_struct:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
- case scm_tc3_closure:
+ /* case scm_tc3_unused: */
/* Never reached */
break;
}
@@ -883,9 +877,7 @@ create_basic_classes (void)
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_locale_symbol ("<class>");
- scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
- SCM_INUM0,
- SCM_EOL));
+ scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
@@ -907,19 +899,15 @@ create_basic_classes (void)
/**** <top> ****/
name = scm_from_locale_symbol ("<top>");
- scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
- name,
- SCM_EOL,
- SCM_EOL));
+ scm_class_top = scm_basic_make_class (scm_class_class, name,
+ SCM_EOL, SCM_EOL);
DEFVAR(name, scm_class_top);
/**** <object> ****/
name = scm_from_locale_symbol ("<object>");
- scm_class_object = scm_permanent_object (scm_basic_make_class
(scm_class_class,
- name,
- scm_list_1
(scm_class_top),
- SCM_EOL));
+ scm_class_object = scm_basic_make_class (scm_class_class, name,
+ scm_list_1 (scm_class_top),
SCM_EOL);
DEFVAR (name, scm_class_object);
@@ -1443,7 +1431,7 @@ SCM_DEFINE (scm_sys_allocate_instance,
"%allocate-instance", 2, 0, 0,
/* FIXME: duplicates some of scm_make_struct. */
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n, "struct");
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (class), n);
layout = SCM_VTABLE_LAYOUT (class);
@@ -1634,10 +1622,6 @@ scm_change_object_class (SCM obj, SCM old_class
SCM_UNUSED, SCM new_class)
SCM_KEYWORD (k_name, "name");
-SCM_SYMBOL (sym_no_method, "no-method");
-
-static SCM list_of_no_method;
-
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
@@ -2272,12 +2256,9 @@ make_stdcls (SCM *var, char *name, SCM meta, SCM super,
SCM slots)
{
SCM tmp = scm_from_locale_symbol (name);
- *var = scm_permanent_object (scm_basic_make_class (meta,
- tmp,
- scm_is_pair (super)
- ? super
- : scm_list_1 (super),
- slots));
+ *var = scm_basic_make_class (meta, tmp,
+ scm_is_pair (super) ? super : scm_list_1
(super),
+ slots);
DEFVAR(tmp, *var);
}
@@ -2414,6 +2395,12 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_vector, "<vector>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_hashtable, "<hashtable>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_fluid, "<fluid>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_dynamic_state, "<dynamic-state>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
@@ -2430,8 +2417,6 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_procedure, "<procedure>",
scm_class_procedure_class, scm_class_applicable, SCM_EOL);
- make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
- scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_port, "<port>",
@@ -2465,12 +2450,8 @@ make_class_from_template (char const *template, char
const *type_name, SCM super
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (applicablep
- ?
scm_class_procedure_class
- : scm_class_class,
- name,
- supers,
- SCM_EOL));
+ class = scm_basic_make_class (applicablep ? scm_class_procedure_class :
scm_class_class,
+ name, supers, SCM_EOL);
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
@@ -2493,12 +2474,8 @@ make_class_from_symbol (SCM type_name_sym, SCM supers,
int applicablep)
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (applicablep
- ?
scm_class_procedure_class
- : scm_class_class,
- name,
- supers,
- SCM_EOL));
+ class = scm_basic_make_class (applicablep ? scm_class_procedure_class :
scm_class_class,
+ name, supers, SCM_EOL);
/* Only define name if doesn't already exist. */
if (!SCM_GOOPS_UNBOUNDP (name)
@@ -2708,23 +2685,17 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0,
0, 0,
{
goops_loaded_p = 1;
var_compute_applicable_methods =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+ scm_module_variable (scm_module_goops, sym_compute_applicable_methods);
var_slot_unbound =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_slot_unbound));
+ scm_module_variable (scm_module_goops, sym_slot_unbound);
var_slot_missing =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_slot_missing));
+ scm_module_variable (scm_module_goops, sym_slot_missing);
var_compute_cpl =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_compute_cpl));
+ scm_module_variable (scm_module_goops, sym_compute_cpl);
var_no_applicable_method =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+ scm_module_variable (scm_module_goops, sym_no_applicable_method);
var_change_class =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_change_class));
+ scm_module_variable (scm_module_goops, sym_change_class);
setup_extended_primitive_generics ();
return SCM_UNSPECIFIED;
}
@@ -2737,18 +2708,12 @@ scm_init_goops_builtins (void)
{
scm_module_goops = scm_current_module ();
- /* Not really necessary right now, but who knows...
- */
- scm_permanent_object (scm_module_goops);
-
goops_rstate = scm_c_make_rstate ("GOOPS", 5);
#include "libguile/goops.x"
- list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
-
hell = scm_calloc (hell_size * sizeof (*hell));
- hell_mutex = scm_permanent_object (scm_make_mutex ());
+ hell_mutex = scm_make_mutex ();
create_basic_classes ();
create_standard_classes ();
@@ -2758,10 +2723,8 @@ scm_init_goops_builtins (void)
{
SCM name = scm_from_locale_symbol ("no-applicable-method");
- scm_no_applicable_method
- = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
- k_name,
- name)));
+ scm_no_applicable_method =
+ scm_make (scm_list_3 (scm_class_generic, k_name, name));
DEFVAR (name, scm_no_applicable_method);
}
diff --git a/libguile/goops.h b/libguile/goops.h
index 914ab3c..b775ae3 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -177,9 +177,9 @@ SCM_API SCM scm_class_pair;
SCM_API SCM scm_class_procedure;
SCM_API SCM scm_class_string;
SCM_API SCM scm_class_symbol;
-SCM_API SCM scm_class_procedure_with_setter;
SCM_API SCM scm_class_primitive_generic;
-SCM_API SCM scm_class_vector, scm_class_null;
+SCM_API SCM scm_class_vector;
+SCM_API SCM scm_class_null;
SCM_API SCM scm_class_real;
SCM_API SCM scm_class_complex;
SCM_API SCM scm_class_integer;
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 6123a0b..24ba670 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -51,47 +51,16 @@ create_gsubr (int define, const char *name,
SCM (*fcn) ())
{
SCM subr;
+ unsigned type;
- switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
- {
- case SCM_GSUBR_MAKTYPE(0, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(1, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(0, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(1, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(2, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(3, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(0, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
- break;
- case SCM_GSUBR_MAKTYPE(2, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
- break;
- default:
- {
- unsigned type;
-
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
-
- subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
- fcn);
- }
- }
+ type = SCM_GSUBR_MAKTYPE (req, opt, rst);
+ if (SCM_GSUBR_REQ (type) != req
+ || SCM_GSUBR_OPT (type) != opt
+ || SCM_GSUBR_REST (type) != rst)
+ scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+
+ subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
+ fcn);
if (define)
scm_define (SCM_SUBR_NAME (subr), subr);
@@ -121,43 +90,21 @@ create_gsubr_with_generic (int define,
SCM *gf)
{
SCM subr;
+ unsigned type;
- switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
- {
- case SCM_GSUBR_MAKTYPE(0, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 1, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 1, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(3, 0, 0):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 0, 1):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 1):
- subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
- create_subr:
- if (define)
- scm_define (SCM_SUBR_NAME (subr), subr);
- return subr;
- default:
- ;
- }
- scm_misc_error ("scm_c_make_gsubr_with_generic",
- "can't make primitive-generic with this arity",
- SCM_EOL);
- return SCM_BOOL_F; /* never reached */
+ type = SCM_GSUBR_MAKTYPE (req, opt, rst);
+ if (SCM_GSUBR_REQ (type) != req
+ || SCM_GSUBR_OPT (type) != opt
+ || SCM_GSUBR_REST (type) != rst)
+ scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
+
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_gsubr | (type << 8U),
+ fcn, gf);
+
+ if (define)
+ scm_define (SCM_SUBR_NAME (subr), subr);
+
+ return subr;
}
SCM
@@ -258,6 +205,10 @@ scm_i_gsubr_apply (SCM proc, SCM arg, ...)
argv[argc] = arg;
if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
+ /* too few args */
+ scm_wrong_num_args (SCM_SUBR_NAME (proc));
+ if (SCM_UNLIKELY (!SCM_UNBNDP (arg) && !SCM_GSUBR_REST (type)))
+ /* too many args */
scm_wrong_num_args (SCM_SUBR_NAME (proc));
/* Fill in optional arguments that were not passed. */
diff --git a/libguile/guardians.c b/libguile/guardians.c
index b85ec02..a341fbf 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -77,7 +77,7 @@ typedef struct t_guardian
} t_guardian;
#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
-#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
+#define GUARDIAN_DATA(x) ((t_guardian *) SCM_SMOB_DATA_1 (x))
diff --git a/libguile/hash.c b/libguile/hash.c
index e6e38ba..e56fab0 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 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
@@ -169,8 +169,8 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- case scm_tcs_closures:
- case scm_tcs_subrs:
+ /* case scm_tcs_closures: */
+ case scm_tc7_gsubr:
return 262 % n;
}
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index f3b3548..059be6f 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -50,10 +50,7 @@
*
*/
-/* Hash tables are either vectors of association lists or smobs
- * containing such vectors. Currently, the vector version represents
- * constant size tables while those wrapped in a smob represents
- * resizing tables.
+/* A hash table is a cell containing a vector of association lists.
*
* Growing or shrinking, with following rehashing, is triggered when
* the load factor
@@ -69,8 +66,6 @@
* hashtable_size.
*/
-scm_t_bits scm_tc16_hashtable;
-
static unsigned long hashtable_size[] = {
31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
@@ -230,7 +225,7 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t
bucket_index,
static SCM
make_hash_table (int flags, unsigned long k, const char *func_name)
{
- SCM table, vector;
+ SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
@@ -250,9 +245,9 @@ make_hash_table (int flags, unsigned long k, const char
*func_name)
t->flags = flags;
t->hash_fn = NULL;
- SCM_NEWSMOB2 (table, scm_tc16_hashtable, vector, t);
-
- return table;
+ /* FIXME: we just need two words of storage, not three */
+ return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
+ (scm_t_bits)t, 0);
}
void
@@ -342,8 +337,8 @@ scm_i_rehash (SCM table,
}
-static int
-hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+void
+scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<", port);
if (SCM_HASHTABLE_WEAK_KEY_P (exp))
@@ -358,7 +353,6 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
scm_puts (">", port);
- return 1;
}
@@ -650,7 +644,7 @@ scm_hash_fn_remove_x (SCM table, SCM obj,
SCM_ARG1, "hash_fn_remove_x");
buckets = table;
}
- if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_EOL;
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
@@ -1259,14 +1253,6 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2,
0, 0,
void
-scm_hashtab_prehistory ()
-{
- /* Initialize the hashtab SMOB type. */
- scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
- scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
-}
-
-void
scm_init_hashtab ()
{
#include "libguile/hashtab.x"
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index b60cd43..75b60e9 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -32,14 +32,12 @@
#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE
-SCM_API scm_t_bits scm_tc16_hashtable;
-
-#define SCM_HASHTABLE_P(x) SCM_SMOB_PREDICATE (scm_tc16_hashtable, x)
+#define SCM_HASHTABLE_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_hashtable)
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
-#define SCM_HASHTABLE_VECTOR(h) SCM_SMOB_OBJECT (h)
-#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_SMOB_OBJECT ((x), (v))
-#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_SMOB_DATA_2 (x))
+#define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h)
+#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 ((x), (v))
+#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x))
#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags)
#define SCM_HASHTABLE_WEAK_KEY_P(x) \
(SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR)
@@ -158,7 +156,7 @@ SCM_API SCM scm_hash_fold (SCM proc, SCM init, SCM hash);
SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
-SCM_INTERNAL void scm_hashtab_prehistory (void);
+SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state
*pstate);
SCM_INTERNAL void scm_init_hashtab (void);
#endif /* SCM_HASHTAB_H */
diff --git a/libguile/hooks.c b/libguile/hooks.c
index c6541fa..d7bf018 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -203,16 +203,13 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
"procedure is not specified.")
#define FUNC_NAME s_scm_add_hook_x
{
- SCM arity, rest;
- int n_args;
+ SCM rest;
+ int n_args, p_req, p_opt, p_rest;
SCM_VALIDATE_HOOK (1, hook);
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
+ SCM_ASSERT (scm_i_procedure_arity (proc, &p_req, &p_opt, &p_rest),
proc, SCM_ARG2, FUNC_NAME);
n_args = SCM_HOOK_ARITY (hook);
- if (scm_to_int (SCM_CAR (arity)) > n_args
- || (scm_is_false (SCM_CADDR (arity))
- && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
- < n_args)))
+ if (p_req > n_args || (!p_rest && p_req + p_opt < n_args))
scm_wrong_type_arg (FUNC_NAME, 2, proc);
rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
SCM_SET_HOOK_PROCEDURES (hook,
diff --git a/libguile/init.c b/libguile/init.c
index 3712a9a..0571d6b 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -49,9 +49,6 @@
#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
-#if 0
-#include "libguile/environments.h"
-#endif
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
@@ -438,79 +435,69 @@ scm_i_init_guile (SCM_STACKITEM *base)
}
scm_storage_prehistory ();
- scm_threads_prehistory (base);
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_fluids_prehistory ();
- scm_weaks_prehistory ();
- scm_hashtab_prehistory (); /* requires storage_prehistory, and
- weaks_prehistory */
+ scm_threads_prehistory (base); /* requires storage_prehistory */
+ scm_weaks_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- if (scm_init_storage ()) /* requires threads_prehistory,
- smob_prehistory and
- hashtab_prehistory */
- abort ();
-
- scm_struct_prehistory (); /* requires storage */
- scm_symbols_prehistory (); /* requires storage */
-#if 0
- scm_environments_prehistory (); /* requires storage */
-#endif
- scm_modules_prehistory (); /* requires storage and hash tables */
- scm_init_variable (); /* all bindings need variables */
- scm_init_continuations ();
+ scm_symbols_prehistory (); /* requires weaks_prehistory */
+ scm_modules_prehistory ();
+ scm_init_array_handle ();
+ scm_init_generalized_arrays ();
+ scm_init_generalized_vectors ();
+ scm_init_strings (); /* Requires array-handle,
generalized-vectors */
+ scm_init_struct (); /* Requires strings */
+ scm_smob_prehistory ();
+ scm_init_variable ();
+ scm_init_continuations (); /* requires smob_prehistory */
scm_init_root (); /* requires continuations */
- scm_init_threads (); /* requires fluids */
+ scm_init_threads (); /* requires smob_prehistory */
scm_init_gsubr ();
scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
-#if 0
- scm_init_environments ();
-#endif
scm_init_alist ();
- scm_init_arbiters ();
- scm_init_async ();
+ scm_init_arbiters (); /* requires smob_prehistory */
+ scm_init_async (); /* requires smob_prehistory */
scm_init_boolean ();
scm_init_chars ();
#ifdef GUILE_DEBUG_MALLOC
scm_init_debug_malloc ();
#endif
- scm_init_dynwind ();
+ scm_init_dynwind (); /* requires smob_prehistory */
scm_init_eq ();
scm_init_error ();
scm_init_fluids ();
- scm_init_feature (); /* Requires fluids */
- scm_init_backtrace (); /* Requires fluids */
+ scm_init_feature ();
+ scm_init_backtrace ();
scm_init_fports ();
scm_init_strports ();
scm_init_ports ();
- scm_init_gdbint (); /* Requires strports */
scm_init_hash ();
scm_init_hashtab ();
- scm_init_deprecation (); /* Requires hashtabs */
+ scm_init_deprecation ();
scm_init_objprop ();
- scm_init_promises ();
+ scm_init_promises (); /* requires smob_prehistory */
scm_init_properties ();
scm_init_hooks (); /* Requires smob_prehistory */
- scm_init_gc (); /* Requires hooks, async */
+ scm_init_gc (); /* Requires hooks */
+ scm_init_gc_protect_object (); /* requires threads_prehistory */
+ scm_init_gdbint (); /* Requires strports, gc_protect_object */
scm_init_gettext ();
scm_init_ioext ();
- scm_init_keywords ();
+ scm_init_keywords (); /* Requires smob_prehistory */
scm_init_list ();
- scm_init_macros ();
- scm_init_mallocs ();
- scm_init_modules ();
+ scm_init_macros (); /* Requires smob_prehistory */
+ scm_init_mallocs (); /* Requires smob_prehistory */
+ scm_init_modules (); /* Requires smob_prehistory */
scm_init_numbers ();
scm_init_options ();
scm_init_pairs ();
#ifdef HAVE_POSIX
- scm_init_filesys ();
+ scm_init_filesys (); /* Requires smob_prehistory */
scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
- scm_init_regex_posix ();
+ scm_init_regex_posix (); /* Requires smob_prehistory */
#endif
scm_init_procs ();
scm_init_scmsigs ();
@@ -519,49 +506,46 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_socket ();
#endif
scm_init_sort ();
- scm_init_srcprop ();
+ scm_init_srcprop (); /* requires smob_prehistory */
scm_init_stackchk ();
- scm_init_array_handle ();
- scm_init_generalized_arrays ();
- scm_init_generalized_vectors ();
- scm_init_vectors ();
+ scm_init_vectors (); /* Requires array-handle, generalized-vectors */
scm_init_uniform ();
- scm_init_bitvectors ();
- scm_bootstrap_bytevectors ();
- scm_init_srfi_4 ();
- scm_init_arrays ();
+ scm_init_bitvectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
+ scm_bootstrap_bytevectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
+ scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
+ scm_init_arrays (); /* Requires smob_prehistory, array-handle */
scm_init_array_map ();
- scm_init_strings (); /* Requires array-handle */
- scm_init_struct (); /* Requires strings */
- scm_init_stacks (); /* Requires strings, struct */
+ scm_bootstrap_vm (); /* requires smob_prehistory, gc_permanent_object */
+
+ scm_init_frames (); /* Requires smob_prehistory */
+ scm_init_stacks (); /* Requires strings, struct, frames */
scm_init_symbols ();
scm_init_values (); /* Requires struct */
scm_init_load (); /* Requires strings */
- scm_init_print (); /* Requires strings, struct */
+ scm_init_print (); /* Requires strings, struct, smob */
scm_init_read ();
scm_init_stime ();
scm_init_strorder ();
scm_init_srfi_13 ();
- scm_init_srfi_14 ();
- scm_init_throw ();
+ scm_init_srfi_14 (); /* Requires smob_prehistory */
+ scm_init_throw (); /* Requires smob_prehistory */
scm_init_trees ();
scm_init_version ();
scm_init_weaks ();
- scm_init_guardians ();
+ scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
- scm_bootstrap_vm ();
- scm_init_memoize ();
- scm_init_eval ();
+ scm_init_memoize (); /* Requires smob_prehistory */
+ scm_init_eval (); /* Requires smob_prehistory */
scm_init_load_path ();
scm_init_eval_in_scheme ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
- scm_init_random ();
+ scm_init_random (); /* Requires smob_prehistory */
scm_init_simpos ();
- scm_init_dynamic_linking ();
+ scm_init_dynamic_linking (); /* Requires smob_prehistory */
scm_bootstrap_i18n ();
#if SCM_ENABLE_ELISP
scm_init_lang ();
diff --git a/libguile/instructions.c b/libguile/instructions.c
index c870b31..c8d95cc 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -67,8 +67,7 @@ fetch_instruction_table ()
{
table[i].opcode = i;
if (table[i].name)
- table[i].symname =
- scm_permanent_object (scm_from_locale_symbol (table[i].name));
+ table[i].symname = scm_from_locale_symbol (table[i].name);
else
table[i].symname = SCM_BOOL_F;
}
diff --git a/libguile/keywords.c b/libguile/keywords.c
index c415ccb..0740801 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 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
@@ -37,6 +37,8 @@
+static SCM keyword_obarray;
+
scm_t_bits scm_tc16_keyword;
#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
@@ -71,11 +73,11 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0,
0,
SCM_CRITICAL_SECTION_START;
/* njrev: NEWSMOB and hashq_set_x can raise errors */
- keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
+ keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
- scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
+ scm_hashq_set_x (keyword_obarray, symbol, keyword);
}
SCM_CRITICAL_SECTION_END;
return keyword;
@@ -117,7 +119,7 @@ scm_init_keywords ()
scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
scm_set_smob_print (scm_tc16_keyword, keyword_print);
- scm_keyword_obarray = scm_c_make_hash_table (0);
+ keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}
diff --git a/libguile/load.c b/libguile/load.c
index fd3626f..c150030 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -881,7 +881,7 @@ init_build_info ()
void
scm_init_load ()
{
- scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr));
+ scm_listofnullstr = scm_list_1 (scm_nullstr);
scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL));
scm_loc_load_extensions
= SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
diff --git a/libguile/macros.c b/libguile/macros.c
index 970a41d..0d71400 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -46,46 +46,42 @@ static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
SCM code = SCM_MACRO_CODE (macro);
- if (!SCM_CLOSUREP (code)
- || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- macro, port, pstate)))
- {
- scm_puts ("#<", port);
- if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
- scm_puts ("extended-", port);
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
- if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("primitive-", port);
+ /* FIXME: doesn't catch boot closures; but do we care? */
+ if (!SCM_PROGRAM_P (code))
+ scm_puts ("primitive-", port);
- if (SCM_MACRO_TYPE (macro) == 0)
- scm_puts ("syntax", port);
+ if (SCM_MACRO_TYPE (macro) == 0)
+ scm_puts ("syntax", port);
#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_MACRO_TYPE (macro) == 1)
- scm_puts ("macro", port);
+ if (SCM_MACRO_TYPE (macro) == 1)
+ scm_puts ("macro", port);
#endif
- if (SCM_MACRO_TYPE (macro) == 2)
- scm_puts ("macro!", port);
- if (SCM_MACRO_TYPE (macro) == 3)
- scm_puts ("builtin-macro!", port);
- if (SCM_MACRO_TYPE (macro) == 4)
- scm_puts ("syncase-macro", port);
-
- scm_putc (' ', port);
- scm_iprin1 (scm_macro_name (macro), port, pstate);
+ if (SCM_MACRO_TYPE (macro) == 2)
+ scm_puts ("macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 3)
+ scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
- if (SCM_MACRO_IS_EXTENDED (macro))
- {
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_2 (macro), port);
- scm_putc (' ', port);
- scm_write (SCM_SMOB_OBJECT_3 (macro), port);
- }
+ scm_putc (' ', port);
+ scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
}
+ scm_putc ('>', port);
+
return 1;
}
@@ -273,7 +269,7 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1,
0, 0,
SCM_VALIDATE_SMOB (1, m, macro);
data = SCM_PACK (SCM_SMOB_DATA (m));
- if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data))
+ if (scm_is_true (scm_procedure_p (data)))
return data;
else
return SCM_BOOL_F;
@@ -312,7 +308,7 @@ SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
SCM var = scm_c_define (name, SCM_UNDEFINED);
- SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
+ SCM transformer = scm_c_make_gsubr (name, 2, 0, 0, fcn);
SCM_VARIABLE_SET (var, macroizer (transformer));
return SCM_UNSPECIFIED;
}
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 0574e11..ae3bbea 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -23,8 +23,6 @@
# include <config.h>
#endif
-#include <alloca.h>
-
#include "libguile/__scm.h"
#include <assert.h>
@@ -295,7 +293,7 @@ memoize_env_ref_transformer (SCM env, SCM x)
{
SCM mac = scm_variable_ref (var);
if (SCM_IMP (SCM_MACRO_CODE (mac))
- || SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_subr_2)
+ || (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
syntax_error ("bad macro", x, SCM_UNDEFINED);
else
return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /*
global macro */
@@ -1169,7 +1167,7 @@ static void error_unbound_variable (SCM symbol)
SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0,
0,
(SCM m, SCM mod),
"Look up and cache the variable that @var{m} will access, returning
the variable.")
-#define FUNC_NAME s_scm_memoized_expression_data
+#define FUNC_NAME s_scm_memoize_variable_access_x
{
SCM mx;
SCM_VALIDATE_MEMOIZED (1, m);
diff --git a/libguile/modules.c b/libguile/modules.c
index c48c2e8..545281a 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -483,9 +483,9 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
scm_t_bits scm_tc16_eval_closure;
-#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
- (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+ (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
/* NOTE: This function may be called by a smob application
or from another C function directly. */
@@ -521,7 +521,7 @@ SCM_DEFINE (scm_standard_interface_eval_closure,
"Such a closure does not allow new bindings to be added.")
#define FUNC_NAME s_scm_standard_interface_eval_closure
{
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure |
(SCM_F_EVAL_CLOSURE_INTERFACE<<16),
SCM_UNPACK (module));
}
#undef FUNC_NAME
@@ -862,8 +862,7 @@ SCM_SYMBOL (scm_sym_system_module, "system-module");
void
scm_modules_prehistory ()
{
- scm_pre_modules_obarray
- = scm_permanent_object (scm_c_make_hash_table (1533));
+ scm_pre_modules_obarray = scm_c_make_hash_table (1533);
}
void
@@ -875,24 +874,22 @@ scm_init_modules ()
scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
- the_module = scm_permanent_object (scm_make_fluid ());
+ the_module = scm_make_fluid ();
}
static void
scm_post_boot_init_modules ()
{
-#define PERM(x) scm_permanent_object(x)
-
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
- resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
- process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
- process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
- module_export_x_var = PERM (scm_c_lookup ("module-export!"));
- the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
- default_duplicate_binding_procedures_var =
- PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
+ resolve_module_var = scm_c_lookup ("resolve-module");
+ process_define_module_var = scm_c_lookup ("process-define-module");
+ process_use_modules_var = scm_c_lookup ("process-use-modules");
+ module_export_x_var = scm_c_lookup ("module-export!");
+ the_root_module_var = scm_c_lookup ("the-root-module");
+ default_duplicate_binding_procedures_var =
+ scm_c_lookup ("default-duplicate-binding-procedures");
scm_module_system_booted_p = 1;
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 15c49c0..358a1cd 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -98,6 +98,8 @@
/* the macro above will not work as is with fractions */
+static SCM flo0;
+
#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
/* FLOBUFLEN is the maximum number of characters neccessary for the
@@ -126,6 +128,16 @@ isinf (double x)
#endif
+#if !defined (HAVE_ASINH)
+static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
+#endif
+#if !defined (HAVE_ACOSH)
+static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
+#endif
+#if !defined (HAVE_ATANH)
+static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
+#endif
+
/* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
an explicit check. In some future gmp (don't know what version number),
mpz_cmp_d is supposed to do this itself. */
@@ -1016,10 +1028,24 @@ scm_modulo (SCM x, SCM y)
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
}
-SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
-/* "Return the greatest common divisor of all arguments.\n"
- * "If called without arguments, 0 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the greatest common divisor of all parameter
values.\n"
+ "If called without arguments, 0 is returned.")
+#define FUNC_NAME s_scm_i_gcd
+{
+ while (!scm_is_null (rest))
+ { x = scm_gcd (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gcd (x, y);
+}
+#undef FUNC_NAME
+
+#define s_gcd s_scm_i_gcd
+#define g_gcd g_scm_i_gcd
+
SCM
scm_gcd (SCM x, SCM y)
{
@@ -1116,10 +1142,24 @@ scm_gcd (SCM x, SCM y)
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
-SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
-/* "Return the least common multiple of the arguments.\n"
- * "If called without arguments, 1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the least common multiple of the arguments.\n"
+ "If called without arguments, 1 is returned.")
+#define FUNC_NAME s_scm_i_lcm
+{
+ while (!scm_is_null (rest))
+ { x = scm_lcm (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_lcm (x, y);
+}
+#undef FUNC_NAME
+
+#define s_lcm s_scm_i_lcm
+#define g_lcm g_scm_i_lcm
+
SCM
scm_lcm (SCM n1, SCM n2)
{
@@ -1217,14 +1257,28 @@ scm_lcm (SCM n1, SCM n2)
*/
-SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise AND of the integer arguments.\n\n"
- "@lisp\n"
- "(logand) @result{} -1\n"
- "(logand 7) @result{} 7\n"
- "(logand #b111 #b011 #b001) @result{} 1\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise AND of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logand) @result{} -1\n"
+ "(logand 7) @result{} 7\n"
+ "(logand #b111 #b011 #b001) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logand
+{
+ while (!scm_is_null (rest))
+ { x = scm_logand (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logand (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logand s_scm_i_logand
+
+SCM scm_logand (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logand
{
long int nn1;
@@ -1293,14 +1347,28 @@ SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
- (SCM n1, SCM n2),
- "Return the bitwise OR of the integer arguments.\n\n"
- "@lisp\n"
- "(logior) @result{} 0\n"
- "(logior 7) @result{} 7\n"
- "(logior #b000 #b001 #b011) @result{} 3\n"
- "@end lisp")
+SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the bitwise OR of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logior) @result{} 0\n"
+ "(logior 7) @result{} 7\n"
+ "(logior #b000 #b001 #b011) @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_i_logior
+{
+ while (!scm_is_null (rest))
+ { x = scm_logior (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logior (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logior s_scm_i_logior
+
+SCM scm_logior (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logior
{
long int nn1;
@@ -1367,8 +1435,8 @@ SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
#undef FUNC_NAME
-SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
- (SCM n1, SCM n2),
+SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
"Return the bitwise XOR of the integer arguments. A bit is\n"
"set in the result if it is set in an odd number of arguments.\n"
"@lisp\n"
@@ -1377,6 +1445,20 @@ SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
"(logxor #b000 #b001 #b011) @result{} 2\n"
"(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
"@end lisp")
+#define FUNC_NAME s_scm_i_logxor
+{
+ while (!scm_is_null (rest))
+ { x = scm_logxor (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_logxor (x, y);
+}
+#undef FUNC_NAME
+
+#define s_scm_logxor s_scm_i_logxor
+
+SCM scm_logxor (SCM n1, SCM n2)
#define FUNC_NAME s_scm_logxor
{
long int nn1;
@@ -3251,8 +3333,25 @@ SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
#undef FUNC_NAME
-SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
-/* "Return @code{#t} if all parameters are numerically equal." */
+SCM scm_i_num_eq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if all parameters are numerically
equal.")
+#define FUNC_NAME s_scm_i_num_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_num_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_num_eq_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_num_eq_p (SCM x, SCM y)
{
@@ -3295,7 +3394,7 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
@@ -3330,7 +3429,7 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
@@ -3368,7 +3467,7 @@ scm_num_eq_p (SCM x, SCM y)
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_COMPLEXP (x))
{
@@ -3406,7 +3505,7 @@ scm_num_eq_p (SCM x, SCM y)
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
@@ -3440,10 +3539,10 @@ scm_num_eq_p (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
}
@@ -3453,10 +3552,26 @@ scm_num_eq_p (SCM x, SCM y)
mpq_cmp. flonum/frac compares likewise, but with the slight complication
of the float exponent to take into account. */
-SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "increasing."
- */
+SCM scm_i_num_less_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is
monotonically\n"
+ "increasing.")
+#define FUNC_NAME s_scm_i_num_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_less_p (x, y);
+}
+#undef FUNC_NAME
SCM
scm_less_p (SCM x, SCM y)
{
@@ -3486,7 +3601,7 @@ scm_less_p (SCM x, SCM y)
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
@@ -3514,7 +3629,7 @@ scm_less_p (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
@@ -3542,7 +3657,7 @@ scm_less_p (SCM x, SCM y)
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
@@ -3575,43 +3690,75 @@ scm_less_p (SCM x, SCM y)
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
s_scm_i_num_less_p);
}
-SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "decreasing."
- */
-#define FUNC_NAME s_scm_gr_p
+SCM scm_i_num_gr_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is
monotonically\n"
+ "decreasing.")
+#define FUNC_NAME s_scm_i_num_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_gr_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_gr_p
SCM
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-decreasing."
- */
-#define FUNC_NAME s_scm_leq_p
+SCM scm_i_num_leq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is
monotonically\n"
+ "non-decreasing.")
+#define FUNC_NAME s_scm_i_num_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_leq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_leq_p
SCM
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
@@ -3620,18 +3767,34 @@ scm_leq_p (SCM x, SCM y)
#undef FUNC_NAME
-SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
-/* "Return @code{#t} if the list of parameters is monotonically\n"
- * "non-increasing."
- */
-#define FUNC_NAME s_scm_geq_p
+SCM scm_i_num_geq_p (SCM, SCM, SCM);
+SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the list of parameters is
monotonically\n"
+ "non-increasing.")
+#define FUNC_NAME s_scm_i_num_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_geq_p (x, y);
+}
+#undef FUNC_NAME
+#define FUNC_NAME s_scm_i_num_geq_p
SCM
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
@@ -3717,9 +3880,23 @@ scm_negative_p (SCM x)
unlike scm_less_p above which takes some trouble to preserve all bits in
its test, such trouble is not required for min and max. */
-SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
-/* "Return the maximum of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the maximum of all parameter values.")
+#define FUNC_NAME s_scm_i_max
+{
+ while (!scm_is_null (rest))
+ { x = scm_max (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_max (x, y);
+}
+#undef FUNC_NAME
+
+#define s_max s_scm_i_max
+#define g_max g_scm_i_max
+
SCM
scm_max (SCM x, SCM y)
{
@@ -3849,9 +4026,23 @@ scm_max (SCM x, SCM y)
}
-SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
-/* "Return the minium of all parameter values."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the minimum of all parameter values.")
+#define FUNC_NAME s_scm_i_min
+{
+ while (!scm_is_null (rest))
+ { x = scm_min (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_min (x, y);
+}
+#undef FUNC_NAME
+
+#define s_min s_scm_i_min
+#define g_min g_scm_i_min
+
SCM
scm_min (SCM x, SCM y)
{
@@ -3974,17 +4165,31 @@ scm_min (SCM x, SCM y)
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
}
-SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
-/* "Return the sum of all parameter values. Return 0 if called without\n"
- * "any parameters."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the sum of all parameter values. Return 0 if
called without\n"
+ "any parameters." )
+#define FUNC_NAME s_scm_i_sum
+{
+ while (!scm_is_null (rest))
+ { x = scm_sum (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_sum (x, y);
+}
+#undef FUNC_NAME
+
+#define s_sum s_scm_i_sum
+#define g_sum g_scm_i_sum
+
SCM
scm_sum (SCM x, SCM y)
{
@@ -4174,13 +4379,28 @@ SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
#undef FUNC_NAME
-SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
-/* If called with one argument @var{z1}, address@hidden returned. Otherwise
- * the sum of all but the first argument are subtracted from the first
- * argument. */
-#define FUNC_NAME s_difference
+SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "If called with one argument @var{z1}, address@hidden
returned. Otherwise\n"
+ "the sum of all but the first argument are subtracted
from the first\n"
+ "argument.")
+#define FUNC_NAME s_scm_i_difference
+{
+ while (!scm_is_null (rest))
+ { x = scm_difference (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_difference (x, y);
+}
+#undef FUNC_NAME
+
+#define s_difference s_scm_i_difference
+#define g_difference g_scm_i_difference
+
SCM
scm_difference (SCM x, SCM y)
+#define FUNC_NAME s_difference
{
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
@@ -4419,10 +4639,24 @@ SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
#undef FUNC_NAME
-SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
-/* "Return the product of all arguments. If called without arguments,\n"
- * "1 is returned."
- */
+SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return the product of all arguments. If called
without arguments,\n"
+ "1 is returned.")
+#define FUNC_NAME s_scm_i_product
+{
+ while (!scm_is_null (rest))
+ { x = scm_product (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_product (x, y);
+}
+#undef FUNC_NAME
+
+#define s_product s_scm_i_product
+#define g_product g_scm_i_product
+
SCM
scm_product (SCM x, SCM y)
{
@@ -4639,13 +4873,28 @@ arising out of or in connection with the use or
performance of
this software.
****************************************************************/
-SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
-/* Divide the first argument by the product of the remaining
- arguments. If called with one argument @var{z1}, 1/@var{z1} is
- returned. */
-#define FUNC_NAME s_divide
+SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Divide the first argument by the product of the
remaining\n"
+ "arguments. If called with one argument @var{z1},
1/@var{z1} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_i_divide
+{
+ while (!scm_is_null (rest))
+ { x = scm_divide (x, y);
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_divide (x, y);
+}
+#undef FUNC_NAME
+
+#define s_divide s_scm_i_divide
+#define g_divide g_scm_i_divide
+
static SCM
-scm_i_divide (SCM x, SCM y, int inexact)
+do_divide (SCM x, SCM y, int inexact)
+#define FUNC_NAME s_divide
{
double a;
@@ -5038,62 +5287,17 @@ scm_i_divide (SCM x, SCM y, int inexact)
SCM
scm_divide (SCM x, SCM y)
{
- return scm_i_divide (x, y, 0);
+ return do_divide (x, y, 0);
}
static SCM scm_divide2real (SCM x, SCM y)
{
- return scm_i_divide (x, y, 1);
+ return do_divide (x, y, 1);
}
#undef FUNC_NAME
double
-scm_asinh (double x)
-{
-#if HAVE_ASINH
- return asinh (x);
-#else
-#define asinh scm_asinh
- return log (x + sqrt (x * x + 1));
-#endif
-}
-SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
-/* "Return the inverse hyperbolic sine of @var{x}."
- */
-
-
-double
-scm_acosh (double x)
-{
-#if HAVE_ACOSH
- return acosh (x);
-#else
-#define acosh scm_acosh
- return log (x + sqrt (x * x - 1));
-#endif
-}
-SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
-/* "Return the inverse hyperbolic cosine of @var{x}."
- */
-
-
-double
-scm_atanh (double x)
-{
-#if HAVE_ATANH
- return atanh (x);
-#else
-#define atanh scm_atanh
- return 0.5 * log ((1 + x) / (1 - x));
-#endif
-}
-SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
-/* "Return the inverse hyperbolic tangent of @var{x}."
- */
-
-
-double
scm_c_truncate (double x)
{
#if HAVE_TRUNC
@@ -5251,108 +5455,284 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0,
0,
}
#undef FUNC_NAME
-SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
-/* "Return the square root of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
-/* "Return the absolute value of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
-/* "Return the @var{x}th power of e."
- */
-SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
-/* "Return the natural logarithm of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
-/* "Return the sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
-/* "Return the cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
-/* "Return the tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
-/* "Return the arc sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
-/* "Return the arc cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
-/* "Return the arc tangent of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
-/* "Return the hyperbolic sine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
-/* "Return the hyperbolic cosine of the real number @var{x}."
- */
-SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
-/* "Return the hyperbolic tangent of the real number @var{x}."
- */
+/* sin/cos/tan/asin/acos/atan
+ sinh/cosh/tanh/asinh/acosh/atanh
+ Derived from "Transcen.scm", Complex trancendental functions for SCM.
+ Written by Jerry D. Hedden, (C) FSF.
+ See the file `COPYING' for terms applying to this program. */
-struct dpair
+SCM_DEFINE (scm_expt, "expt", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @var{x} raised to the power of @var{y}.")
+#define FUNC_NAME s_scm_expt
{
- double x, y;
-};
+ if (!SCM_INEXACTP (y) && scm_is_integer (y))
+ return scm_integer_expt (x, y);
+ else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
+ {
+ return scm_from_double (pow (scm_to_double (x), scm_to_double (y)));
+ }
+ else
+ return scm_exp (scm_product (scm_log (x), y));
+}
+#undef FUNC_NAME
-static void scm_two_doubles (SCM x,
- SCM y,
- const char *sstring,
- struct dpair * xy);
+SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
+ (SCM z),
+ "Compute the sine of @var{z}.")
+#define FUNC_NAME s_scm_sin
+{
+ if (scm_is_real (z))
+ return scm_from_double (sin (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sin (x) * cosh (y),
+ cos (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+}
+#undef FUNC_NAME
-static void
-scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
+SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
+ (SCM z),
+ "Compute the cosine of @var{z}.")
+#define FUNC_NAME s_scm_cos
{
- if (SCM_I_INUMP (x))
- xy->x = SCM_I_INUM (x);
- else if (SCM_BIGP (x))
- xy->x = scm_i_big2dbl (x);
- else if (SCM_REALP (x))
- xy->x = SCM_REAL_VALUE (x);
- else if (SCM_FRACTIONP (x))
- xy->x = scm_i_fraction2double (x);
+ if (scm_is_real (z))
+ return scm_from_double (cos (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cos (x) * cosh (y),
+ -sin (x) * sinh (y));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
+ (SCM z),
+ "Compute the tangent of @var{z}.")
+#define FUNC_NAME s_scm_tan
+{
+ if (scm_is_real (z))
+ return scm_from_double (tan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cos (x) + cosh (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tan);
+#endif
+ return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (sinh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (sinh (x) * cos (y),
+ cosh (x) * sin (y));
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG1, x);
-
- if (SCM_I_INUMP (y))
- xy->y = SCM_I_INUM (y);
- else if (SCM_BIGP (y))
- xy->y = scm_i_big2dbl (y);
- else if (SCM_REALP (y))
- xy->y = SCM_REAL_VALUE (y);
- else if (SCM_FRACTIONP (y))
- xy->y = scm_i_fraction2double (y);
+ SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_cosh
+{
+ if (scm_is_real (z))
+ return scm_from_double (cosh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (cosh (x) * cos (y),
+ sinh (x) * sin (y));
+ }
else
- scm_wrong_type_arg (sstring, SCM_ARG2, y);
+ SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
+#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
+ (SCM z),
+ "Compute the hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_tanh
+{
+ if (scm_is_real (z))
+ return scm_from_double (tanh (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ { double x, y, w;
+ x = 2.0 * SCM_COMPLEX_REAL (z);
+ y = 2.0 * SCM_COMPLEX_IMAG (z);
+ w = cosh (x) + cos (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (w == 0.0)
+ scm_num_overflow (s_scm_tanh);
+#endif
+ return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
- (SCM x, SCM y),
- "Return @var{x} raised to the power of @var{y}. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_expt
+SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
+ (SCM z),
+ "Compute the arc sine of @var{z}.")
+#define FUNC_NAME s_scm_asin
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (pow (xy.x, xy.y));
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (asin (w));
+ else
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (0, w)));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_product (scm_c_make_rectangular (0, -1),
+ scm_sys_asinh (scm_c_make_rectangular (-y, x)));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
+SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
+ (SCM z),
+ "Compute the arc cosine of @var{z}.")
+#define FUNC_NAME s_scm_acos
+{
+ if (scm_is_real (z))
+ {
+ double w = scm_to_double (z);
+ if (w >= -1.0 && w <= 1.0)
+ return scm_from_double (acos (w));
+ else
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (0,
w))));
+ }
+ else if (SCM_COMPLEXP (z))
+ { double x, y;
+ x = SCM_COMPLEX_REAL (z);
+ y = SCM_COMPLEX_IMAG (z);
+ return scm_sum (scm_from_double (acos (0.0)),
+ scm_product (scm_c_make_rectangular (0, 1),
+ scm_sys_asinh (scm_c_make_rectangular (-y,
x))));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+}
+#undef FUNC_NAME
-SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
- (SCM x, SCM y),
- "Return the arc tangent of the two arguments @var{x} and\n"
- "@var{y}. This is similar to calculating the arc tangent of\n"
- "@var{x} / @var{y}, except that the signs of both arguments\n"
- "are used to determine the quadrant of the result. This\n"
- "procedure does not accept complex arguments.")
-#define FUNC_NAME s_scm_sys_atan2
+SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
+ (SCM z, SCM y),
+ "With one argument, compute the arc tangent of
@var{z}.\n"
+ "If @var{y} is present, compute the arc tangent of
@var{z}/@var{y},\n"
+ "using the sign of @var{z} and @var{y} to determine the
quadrant.")
+#define FUNC_NAME s_scm_atan
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_from_double (atan2 (xy.x, xy.y));
+ if (SCM_UNBNDP (y))
+ {
+ if (scm_is_real (z))
+ return scm_from_double (atan (scm_to_double (z)));
+ else if (SCM_COMPLEXP (z))
+ {
+ double v, w;
+ v = SCM_COMPLEX_REAL (z);
+ w = SCM_COMPLEX_IMAG (z);
+ return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w
- 1.0),
+ scm_c_make_rectangular (v, w
+ 1.0))),
+ scm_c_make_rectangular (0, 2));
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ }
+ else if (scm_is_real (z))
+ {
+ if (scm_is_real (y))
+ return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic sine of @var{z}.")
+#define FUNC_NAME s_scm_sys_asinh
+{
+ if (scm_is_real (z))
+ return scm_from_double (asinh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_sum (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic cosine of @var{z}.")
+#define FUNC_NAME s_scm_sys_acosh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= 1.0)
+ return scm_from_double (acosh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_log (scm_sum (z,
+ scm_sqrt (scm_difference (scm_product (z, z),
+ SCM_I_MAKINUM (1)))));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
+ (SCM z),
+ "Compute the inverse hyperbolic tangent of @var{z}.")
+#define FUNC_NAME s_scm_sys_atanh
+{
+ if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
+ return scm_from_double (atanh (scm_to_double (z)));
+ else if (scm_is_number (z))
+ return scm_divide (scm_log (scm_divide (scm_sum (SCM_I_MAKINUM (1), z),
+ scm_difference (SCM_I_MAKINUM (1),
z))),
+ SCM_I_MAKINUM (2));
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
@@ -5379,9 +5759,12 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2,
0, 0,
"and @var{imaginary-part} parts.")
#define FUNC_NAME s_scm_make_rectangular
{
- struct dpair xy;
- scm_two_doubles (real_part, imaginary_part, FUNC_NAME, &xy);
- return scm_c_make_rectangular (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
+ SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
+ SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_rectangular (scm_to_double (real_part),
+ scm_to_double (imaginary_part));
}
#undef FUNC_NAME
@@ -5408,9 +5791,9 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
"Return the complex number @var{x} * e^(i * @var{y}).")
#define FUNC_NAME s_scm_make_polar
{
- struct dpair xy;
- scm_two_doubles (x, y, FUNC_NAME, &xy);
- return scm_c_make_polar (xy.x, xy.y);
+ SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
+ SCM_ASSERT_TYPE (scm_is_real (y), y, SCM_ARG2, FUNC_NAME, "real");
+ return scm_c_make_polar (scm_to_double (x), scm_to_double (y));
}
#undef FUNC_NAME
@@ -5447,7 +5830,7 @@ scm_imag_part (SCM z)
else if (SCM_BIGP (z))
return SCM_INUM0;
else if (SCM_REALP (z))
- return scm_flo0;
+ return flo0;
else if (SCM_COMPLEXP (z))
return scm_from_double (SCM_COMPLEX_IMAG (z));
else if (SCM_FRACTIONP (z))
@@ -5542,13 +5925,13 @@ SCM
scm_angle (SCM z)
{
/* atan(0,-1) is pi and it'd be possible to have that as a constant like
- scm_flo0 to save allocating a new flonum with scm_from_double each time.
+ flo0 to save allocating a new flonum with scm_from_double each time.
But if atan2 follows the floating point rounding mode, then the value
is not a constant. Maybe it'd be close enough though. */
if (SCM_I_INUMP (z))
{
if (SCM_I_INUM (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
@@ -5559,12 +5942,12 @@ scm_angle (SCM z)
if (sgn < 0)
return scm_from_double (atan2 (0.0, -1.0));
else
- return scm_flo0;
+ return flo0;
}
else if (SCM_REALP (z))
{
if (SCM_REAL_VALUE (z) >= 0)
- return scm_flo0;
+ return flo0;
else
return scm_from_double (atan2 (0.0, -1.0));
}
@@ -5573,7 +5956,7 @@ scm_angle (SCM z)
else if (SCM_FRACTIONP (z))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
- return scm_flo0;
+ return flo0;
else return scm_from_double (atan2 (0.0, -1.0));
}
else
@@ -6213,7 +6596,7 @@ scm_init_numbers ()
scm_add_feature ("complex");
scm_add_feature ("inexact");
- scm_flo0 = scm_from_double (0.0);
+ flo0 = scm_from_double (0.0);
/* determine floating point precision */
for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
@@ -6223,11 +6606,10 @@ scm_init_numbers ()
}
#ifdef DBL_DIG
/* hard code precision for base 10 if the preprocessor tells us to... */
- scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
+ scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
#endif
- exactly_one_half = scm_permanent_object (scm_divide (SCM_I_MAKINUM (1),
- SCM_I_MAKINUM (2)));
+ exactly_one_half = scm_divide (SCM_I_MAKINUM (1), SCM_I_MAKINUM (2));
#include "libguile/numbers.x"
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 9597afb..95d59b8 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -208,6 +208,12 @@ 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);
@@ -245,15 +251,23 @@ 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_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);
@@ -268,6 +282,13 @@ 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);
diff --git a/libguile/objprop.c b/libguile/objprop.c
index 6dd1da6..39fcfb5 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008 Free Software
Foundation, Inc.
+/* 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
@@ -35,12 +35,14 @@
/* {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 (scm_object_whash, obj, SCM_EOL);
+ return scm_hashq_ref (object_whash, obj, SCM_EOL);
}
#undef FUNC_NAME
@@ -50,7 +52,7 @@ SCM_DEFINE (scm_set_object_properties_x,
"set-object-properties!", 2, 0, 0,
"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 handle = scm_hashq_create_handle_x (object_whash, obj, alist);
SCM_SETCDR (handle, alist);
return alist;
}
@@ -75,7 +77,7 @@ SCM_DEFINE (scm_set_object_property_x,
"set-object-property!", 3, 0, 0,
{
SCM h;
SCM assoc;
- h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
+ 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))
@@ -94,7 +96,7 @@ SCM_DEFINE (scm_set_object_property_x,
"set-object-property!", 3, 0, 0,
void
scm_init_objprop ()
{
- scm_object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/objprop.x"
}
diff --git a/libguile/options.c b/libguile/options.c
index ee7001a..ba2e95e 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 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
@@ -281,7 +281,6 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[])
{
SCM name = scm_from_locale_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);
- scm_permanent_object (name);
}
func (SCM_UNDEFINED);
}
diff --git a/libguile/pairs.c b/libguile/pairs.c
index fb8b21f..68fa4c9 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -96,36 +96,6 @@ SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
}
#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"
@@ -159,59 +129,146 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
* 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}
-};
+/* 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 ()
{
- 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"
}
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 47bb187..81d89b5 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -112,67 +112,34 @@ 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 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);
diff --git a/libguile/ports.c b/libguile/ports.c
index 1fd6f63..f56c092 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -95,8 +95,8 @@
* Indexes into this table are used when generating type
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
-scm_t_ptob_descriptor *scm_ptobs;
-long scm_numptob;
+scm_t_ptob_descriptor *scm_ptobs = NULL;
+long scm_numptob = 0;
/* GC marker for a port with stream of SCM type. */
SCM
@@ -2266,13 +2266,6 @@ scm_port_print (SCM exp, SCM port, scm_print_state
*pstate SCM_UNUSED)
return 1;
}
-void
-scm_ports_prehistory ()
-{
- scm_numptob = 0;
- scm_ptobs = NULL;
-}
-
/* Void ports. */
@@ -2340,12 +2333,12 @@ scm_init_ports ()
scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
write_void_port);
- cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
- cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_inport_fluid = scm_make_fluid ();
+ cur_outport_fluid = scm_make_fluid ();
+ cur_errport_fluid = scm_make_fluid ();
+ cur_loadport_fluid = scm_make_fluid ();
- scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table
(SCM_I_MAKINUM(31)));
+ scm_i_port_weak_hash = scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
#include "libguile/ports.x"
diff --git a/libguile/ports.h b/libguile/ports.h
index 2ac736e..3af3441 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -304,7 +304,6 @@ SCM_API SCM scm_port_conversion_strategy (SCM port);
SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
-SCM_API void scm_ports_prehistory (void);
SCM_API SCM scm_void_port (char * mode_str);
SCM_API SCM scm_sys_make_void_port (SCM mode);
SCM_INTERNAL void scm_init_ports (void);
diff --git a/libguile/print.c b/libguile/print.c
index 3069edc..efb3081 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -428,7 +428,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
switch (SCM_ITAG3 (exp))
{
- case scm_tc3_closure:
case scm_tc3_tc7_1:
case scm_tc3_tc7_2:
/* These tc3 tags should never occur in an immediate value. They are
@@ -561,22 +560,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
circref:
print_circref (port, pstate, exp);
break;
- case scm_tcs_closures:
- if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
- || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
- exp, port, pstate)))
- {
- scm_puts ("#<procedure", port);
- scm_putc (' ', port);
- scm_iprin1 (scm_procedure_name (exp), port, pstate);
- scm_putc (' ', port);
- scm_iprin1
- (scm_cons (SCM_I_MAKINUM (SCM_CLOSURE_NUM_REQUIRED_ARGS (exp)),
- scm_from_bool (SCM_CLOSURE_HAS_REST_ARGS (exp))),
- port, pstate);
- scm_putc ('>', port);
- }
- break;
case scm_tc7_number:
switch SCM_TYP16 (exp) {
case scm_tc16_big:
@@ -726,6 +709,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
+ case scm_tc7_hashtable:
+ scm_i_hashtable_print (exp, port, pstate);
+ break;
+ case scm_tc7_fluid:
+ scm_i_fluid_print (exp, port, pstate);
+ break;
+ case scm_tc7_dynamic_state:
+ scm_i_dynamic_state_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
@@ -782,7 +774,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
EXIT_NESTED_DATA (pstate);
break;
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
{
SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
scm_puts (SCM_SUBR_GENERIC (exp)
@@ -793,18 +785,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_putc ('>', port);
break;
}
- case scm_tc7_pws:
- scm_puts ("#<procedure-with-setter", port);
- {
- SCM name = scm_procedure_name (exp);
- if (scm_is_true (name))
- {
- scm_putc (' ', port);
- scm_display (name, port);
- }
- }
- scm_putc ('>', port);
- break;
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
@@ -820,6 +800,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
break;
default:
+ /* case scm_tcs_closures: */
punk:
scm_ipruk ("type", exp, port);
}
diff --git a/libguile/procprop.c b/libguile/procprop.c
index cce800f..7cfd2e6 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -41,91 +41,46 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-static SCM non_closure_props;
-static scm_i_pthread_mutex_t non_closure_props_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM props;
+static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-SCM
-scm_i_procedure_arity (SCM proc)
+int
+scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
- int a = 0, o = 0, r = 0;
if (SCM_IMP (proc))
- return SCM_BOOL_F;
+ return 0;
loop:
switch (SCM_TYP7 (proc))
{
- case scm_tc7_subr_1o:
- o = 1;
- case scm_tc7_subr_0:
- break;
- case scm_tc7_subr_2o:
- o = 1;
- case scm_tc7_subr_1:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- a += 1;
- break;
- case scm_tc7_subr_2:
- a += 2;
- break;
- case scm_tc7_subr_3:
- a += 3;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_lsubr:
- r = 1;
- break;
case scm_tc7_program:
- if (scm_i_program_arity (proc, &a, &o, &r))
- break;
- else
- return SCM_BOOL_F;
- case scm_tc7_lsubr_2:
- a += 2;
- r = 1;
- break;
+ return scm_i_program_arity (proc, req, opt, rest);
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
{
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- a += SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
else
- {
- return SCM_BOOL_F;
- }
+ return 0;
case scm_tc7_gsubr:
{
unsigned int type = SCM_GSUBR_TYPE (proc);
- a = SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
}
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- goto loop;
- case scm_tcs_closures:
- a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0;
- break;
case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- r = 1;
- break;
- }
- else if (!SCM_STRUCT_APPLICABLE_P (proc))
- return SCM_BOOL_F;
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
proc = SCM_STRUCT_PROCEDURE (proc);
goto loop;
default:
- return SCM_BOOL_F;
+ return 0;
}
- return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
@@ -137,18 +92,22 @@ SCM_DEFINE (scm_procedure_properties,
"procedure-properties", 1, 0, 0,
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
- SCM props;
+ SCM ret;
+ int req, opt, rest;
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+
+ return scm_acons (scm_sym_arity,
+ scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest)),
+ ret);
}
#undef FUNC_NAME
@@ -159,14 +118,10 @@ SCM_DEFINE (scm_set_procedure_properties_x,
"set-procedure-properties!", 2, 0, 0
{
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc, alist);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc, alist);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc, alist);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -180,19 +135,22 @@ SCM_DEFINE (scm_procedure_property, "procedure-property",
2, 0, 0,
if (scm_is_eq (key, scm_sym_arity))
/* avoid a cons in this case */
- return scm_i_procedure_arity (proc);
+ {
+ int req, opt, rest;
+ scm_i_procedure_arity (proc, &req, &opt, &rest);
+ return scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest));
+ }
else
{
- SCM props;
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_assq_ref (props, key);
+ SCM ret;
+
+ scm_i_pthread_mutex_lock (&props_lock);
+ ret = scm_hashq_ref (props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&props_lock);
+
+ return scm_assq_ref (ret, key);
}
}
#undef FUNC_NAME
@@ -208,18 +166,12 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc,
- scm_assq_set_x (SCM_PROCPROPS (proc), key, val));
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc,
- scm_assq_set_x (scm_hashq_ref (non_closure_props, proc,
- SCM_EOL),
- key, val));
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
+ scm_i_pthread_mutex_lock (&props_lock);
+ scm_hashq_set_x (props, proc,
+ scm_assq_set_x (scm_hashq_ref (props, proc,
+ SCM_EOL),
+ key, val));
+ scm_i_pthread_mutex_unlock (&props_lock);
return SCM_UNSPECIFIED;
}
@@ -231,7 +183,7 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
void
scm_init_procprop ()
{
- non_closure_props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 7a11314..50f04b2 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -33,7 +33,7 @@ SCM_API SCM scm_sym_system_procedure;
-SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
+SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
diff --git a/libguile/procs.c b/libguile/procs.c
index 898a371..6c03911 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -100,9 +100,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
- case scm_tcs_closures:
- case scm_tcs_subrs:
- case scm_tc7_pws:
+ case scm_tc7_gsubr:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
@@ -114,51 +112,14 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a closure.")
-#define FUNC_NAME s_scm_closure_p
-{
- return scm_from_bool (SCM_CLOSUREP (obj));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p
{
- if (SCM_NIMP (obj))
- {
- again:
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
- case scm_tc7_subr_0:
- case scm_tc7_subr_1o:
- case scm_tc7_lsubr:
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- return SCM_BOOL_T;
- case scm_tc7_gsubr:
- return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
- case scm_tc7_program:
- {
- int a, o, r;
- if (scm_i_program_arity (obj, &a, &o, &r))
- return scm_from_bool (a == 0);
- else
- return SCM_BOOL_F;
- }
- case scm_tc7_pws:
- obj = SCM_PROCEDURE (obj);
- goto again;
- default:
- return SCM_BOOL_F;
- }
- }
- return SCM_BOOL_F;
+ int req, opt, rest;
+ return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest)
+ && req == 0);
}
#undef FUNC_NAME
@@ -169,7 +130,7 @@ scm_subr_p (SCM obj)
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
{
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
return 1;
default:
;
@@ -187,25 +148,11 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
"documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
- SCM code;
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
- proc, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_program_properties (proc), sym_documentation);
- switch (SCM_TYP7 (proc))
- {
- case scm_tcs_closures:
- code = SCM_CLOSURE_BODY (proc);
- if (scm_is_null (SCM_CDR (code)))
- return SCM_BOOL_F;
- code = SCM_CAR (code);
- if (scm_is_string (code))
- return code;
- else
- return SCM_BOOL_F;
- default:
- return SCM_BOOL_F;
- }
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -213,13 +160,16 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
/* Procedure-with-setter
*/
+static SCM pws_vtable;
+
+
SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a procedure with an\n"
"associated setter procedure.")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
- return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
+ return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj));
}
#undef FUNC_NAME
@@ -232,13 +182,13 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- ret = scm_double_cell (scm_tc7_pws,
- SCM_UNPACK (procedure),
- SCM_UNPACK (setter), 0);
+ ret = scm_make_struct (pws_vtable, SCM_INUM0,
+ scm_list_2 (procedure, setter));
+
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
switch (SCM_TYP7 (procedure)) {
- case scm_tcs_subrs:
+ case scm_tc7_gsubr:
name = SCM_SUBR_NAME (procedure);
break;
default:
@@ -253,51 +203,43 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
(SCM proc),
- "Return the procedure of @var{proc}, which must be either a\n"
- "procedure with setter, or an applicable struct.")
+ "Return the procedure of @var{proc}, which must be an\n"
+ "applicable struct.")
#define FUNC_NAME s_scm_procedure
{
SCM_VALIDATE_NIM (1, proc);
- if (SCM_PROCEDURE_WITH_SETTER_P (proc))
- return SCM_PROCEDURE (proc);
- else if (SCM_STRUCTP (proc))
- {
- SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc),
- proc, SCM_ARG1, FUNC_NAME);
- return proc;
- }
- SCM_WRONG_TYPE_ARG (1, proc);
- return SCM_BOOL_F; /* not reached */
+ SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME);
+ return SCM_STRUCT_PROCEDURE (proc);
}
#undef FUNC_NAME
-SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
-
-SCM
-scm_setter (SCM proc)
+SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
+ (SCM proc),
+ "Return the setter of @var{proc}, which must be an\n"
+ "applicable struct with a setter.")
+#define FUNC_NAME s_scm_setter
{
- SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
- if (SCM_PROCEDURE_WITH_SETTER_P (proc))
- return SCM_SETTER (proc);
- else if (SCM_STRUCTP (proc))
- {
- SCM setter = SCM_BOOL_F;
- if (SCM_PUREGENERICP (proc))
- setter = SCM_GENERIC_SETTER (proc);
- else if (SCM_STRUCT_SETTER_P (proc))
- setter = SCM_STRUCT_SETTER (proc);
- if (SCM_NIMP (setter))
- return setter;
- /* fall through */
- }
- SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
+ SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+ if (SCM_STRUCT_SETTER_P (proc))
+ return SCM_STRUCT_SETTER (proc);
+ if (SCM_PUREGENERICP (proc))
+ /* FIXME: might not be an accessor */
+ return SCM_GENERIC_SETTER (proc);
+ SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
return SCM_BOOL_F; /* not reached */
}
+#undef FUNC_NAME
void
scm_init_procs ()
{
+ pws_vtable =
+ scm_c_make_struct (scm_applicable_struct_with_setter_vtable_vtable,
+ 0,
+ 1,
+ SCM_UNPACK (scm_from_locale_symbol ("pwpw")));
+
#include "libguile/procs.x"
}
diff --git a/libguile/procs.h b/libguile/procs.h
index dc764ed..a832cd0 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -34,7 +34,6 @@
#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
-#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
@@ -44,106 +43,7 @@
OPT optional arguments, and REST (0 or 1) arguments. This has to be in
sync with `create_gsubr ()'. */
#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
- ((rest) == 0 \
- ? ((opt) == 0 \
- ? ((req) == 0 \
- ? scm_tc7_subr_0 \
- : ((req) == 1 \
- ? scm_tc7_subr_1 \
- : ((req) == 2 \
- ? scm_tc7_subr_2 \
- : ((req) == 3 \
- ? scm_tc7_subr_3 \
- : scm_tc7_gsubr \
- | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))))) \
- : ((opt) == 1 \
- ? ((req) == 0 \
- ? scm_tc7_subr_1o \
- : ((req) == 1 \
- ? scm_tc7_subr_2o \
- : scm_tc7_gsubr | \
- (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
- : scm_tc7_gsubr | \
- (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
- : ((rest) == 1 \
- ? ((opt) == 0 \
- ? ((req) == 0 \
- ? scm_tc7_lsubr \
- : ((req) == 2 \
- ? scm_tc7_lsubr_2 \
- : scm_tc7_gsubr \
- | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
- : scm_tc7_gsubr \
- | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)) \
- : scm_tc7_gsubr \
- | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))
-
-
-
-/* Closures
- */
-
-#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
-#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
-#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
-#define SCM_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (SCM_CAR (SCM_CODE (x)))
-#define SCM_CLOSURE_HAS_REST_ARGS(x) scm_is_true (SCM_CADR (SCM_CODE (x)))
-#define SCM_CLOSURE_BODY(x) SCM_CDDR (SCM_CODE (x))
-#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
-#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
-#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
-#define SCM_TOP_LEVEL(ENV) (scm_is_null (ENV) || (scm_is_true
(scm_procedure_p (SCM_CAR (ENV)))))
-
-/* Procedure-with-setter
-
- Four representations for procedure-with-setters were
- considered before selecting this one:
-
- 1. A closure where the CODE and ENV slots are used to represent
- the getter and a new SETTER slot is used for the setter. The
- original getter is stored as a `getter' procedure property. For
- closure getters, the CODE and ENV slots contains a copy of the
- getter's CODE and ENV slots. For subr getters, the CODE contains
- a call to the subr.
-
- 2. A compiled closure with a call to the getter in the cclo
- procedure. The getter and setter are stored in slots 1 and 2.
-
- 3. An entity (i.e. a struct with an associated procedure) with a
- call to the getter in the entity procedure and the setter stored
- in slot 0. The original getter is stored in slot 1.
-
- 4. A new primitive procedure type supported in the evaluator. The
- getter and setter are stored in a GETTER and SETTER slot. A call
- to this procedure type results in a retrieval of the getter and a
- jump back to the correct eval dispatcher.
-
- Representation 4 was selected because of efficiency and
- simplicity.
-
- Rep 1 has the advantage that there is zero penalty for closure
- getters, but primitive getters will get considerable overhead
- because the procedure-with-getter will be a closure which calls
- the getter.
-
- Rep 3 has the advantage that a GOOPS accessor can be a subclass of
- <procedure-with-setter>, but together with rep 2 it suffers from a
- three level dispatch for non-GOOPS getters:
-
- cclo/struct --> dispatch proc --> getter
-
- This is because the dispatch procedure must take an extra initial
- argument (cclo for rep 2, struct for rep 3).
-
- Rep 4 has the single disadvantage that it uses up one tc7 type
- code, but the plan for uniform vectors will very likely free tc7
- codes, so this is probably no big problem. Also note that the
- GETTER and SETTER slots can live directly on the heap, using the
- new four-word cells. */
-
-#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) ==
scm_tc7_pws))
-#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
-#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
+ (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
@@ -155,7 +55,6 @@ SCM_API SCM scm_c_define_subr (const char *name, long type,
SCM (*fcn)());
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_procedure_p (SCM obj);
-SCM_API SCM scm_closure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
diff --git a/libguile/properties.c b/libguile/properties.c
index 60ff2ff..1f3c668 100644
--- a/libguile/properties.c
+++ b/libguile/properties.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software
Foundation, Inc.
+/* 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
@@ -36,6 +36,8 @@
/* {Properties}
*/
+static SCM properties_whash;
+
SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
(SCM not_found_proc),
"Create a @dfn{property token} that can be used with\n"
@@ -67,7 +69,7 @@ SCM_DEFINE (scm_primitive_property_ref,
"primitive-property-ref", 2, 0, 0,
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (scm_properties_whash, obj);
+ h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
{
SCM assoc = scm_assq (prop, SCM_CDR (h));
@@ -81,7 +83,7 @@ SCM_DEFINE (scm_primitive_property_ref,
"primitive-property-ref", 2, 0, 0,
{
SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
if (scm_is_false (h))
- h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
return val;
}
@@ -96,7 +98,7 @@ SCM_DEFINE (scm_primitive_property_set_x,
"primitive-property-set!", 3, 0, 0,
{
SCM h, assoc;
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
assoc = scm_assq (prop, SCM_CDR (h));
if (SCM_NIMP (assoc))
SCM_SETCDR (assoc, val);
@@ -117,7 +119,7 @@ SCM_DEFINE (scm_primitive_property_del_x,
"primitive-property-del!", 2, 0, 0,
{
SCM h;
SCM_VALIDATE_CONS (SCM_ARG1, prop);
- h = scm_hashq_get_handle (scm_properties_whash, obj);
+ h = scm_hashq_get_handle (properties_whash, obj);
if (scm_is_true (h))
SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
return SCM_UNSPECIFIED;
@@ -128,7 +130,7 @@ SCM_DEFINE (scm_primitive_property_del_x,
"primitive-property-del!", 2, 0, 0,
void
scm_init_properties ()
{
- scm_properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/properties.x"
}
diff --git a/libguile/root.c b/libguile/root.c
index 83960b5..d35d8e8 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 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
@@ -38,10 +38,6 @@
#include "libguile/root.h"
-SCM scm_sys_protects[SCM_NUM_PROTECTS];
-
-
-
/* {call-with-dynamic-root}
*
* Suspending the current thread to evaluate a thunk on the
diff --git a/libguile/root.h b/libguile/root.h
index 46b9be0..68ab5c7 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -29,22 +29,6 @@
-#define scm_flo0 scm_sys_protects[0]
-#define scm_listofnull scm_sys_protects[1]
-#define scm_nullvect scm_sys_protects[2]
-#define scm_nullstr scm_sys_protects[3]
-#define scm_keyword_obarray scm_sys_protects[4]
-#define scm_object_whash scm_sys_protects[5]
-#define scm_asyncs scm_sys_protects[6]
-#define scm_protects scm_sys_protects[7]
-#define scm_properties_whash scm_sys_protects[8]
-#define scm_source_whash scm_sys_protects[9]
-#define SCM_NUM_PROTECTS 10
-
-SCM_API SCM scm_sys_protects[];
-
-
-
SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
void *body_data,
scm_t_catch_handler handler,
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index f38d15c..699a6de 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -668,10 +668,8 @@ scm_init_scmsigs ()
signal_handlers =
SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
scm_c_make_vector (NSIG, SCM_BOOL_F)));
- signal_handler_asyncs =
- scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
- signal_handler_threads =
- scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
+ signal_handler_asyncs = scm_c_make_vector (NSIG, SCM_BOOL_F);
+ signal_handler_threads = scm_c_make_vector (NSIG, SCM_BOOL_F);
for (i = 0; i < NSIG; i++)
{
diff --git a/libguile/smob.c b/libguile/smob.c
index 31f6dd0..d96a043 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -54,14 +54,6 @@
long scm_numsmob;
scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
-/* Lower 16 bit of data must be zero.
-*/
-void
-scm_i_set_smob_flags (SCM x, scm_t_bits data)
-{
- SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
-}
-
void
scm_assert_smob_type (scm_t_bits tag, SCM val)
{
diff --git a/libguile/smob.h b/libguile/smob.h
index ee0e53e..f9b5110 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -122,25 +122,47 @@ while (0)
} while (0)
-#define SCM_SMOB_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_SMOB_DATA(x) (SCM_CELL_WORD_1 (x))
-#define SCM_SMOB_DATA_2(x) (SCM_CELL_WORD_2 (x))
-#define SCM_SMOB_DATA_3(x) (SCM_CELL_WORD_3 (x))
-#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_CELL_WORD_1 ((x), (data)))
-#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_CELL_WORD_2 ((x), (data)))
-#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_CELL_WORD_3 ((x), (data)))
-#define SCM_SET_SMOB_FLAGS(x, data) (scm_i_set_smob_flags((x),(data)<<16))
-
-#define SCM_SMOB_OBJECT(x) (SCM_CELL_OBJECT_1 (x))
-#define SCM_SMOB_OBJECT_2(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_SMOB_OBJECT_3(x) (SCM_CELL_OBJECT_3 (x))
-#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_CELL_OBJECT_1 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_CELL_OBJECT_2 ((x), (obj)))
-#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_CELL_OBJECT_3 ((x), (obj)))
-#define SCM_SMOB_OBJECT_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
-#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 2))
-#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 3))
-
+#define SCM_SMOB_DATA_N(x, n) (SCM_CELL_WORD ((x), (n)))
+#define SCM_SET_SMOB_DATA_N(x, n, data) (SCM_SET_CELL_WORD ((x), (n),
(data)))
+
+#define SCM_SMOB_DATA_0(x) (SCM_SMOB_DATA_N ((x), 0))
+#define SCM_SMOB_DATA_1(x) (SCM_SMOB_DATA_N ((x), 1))
+#define SCM_SMOB_DATA_2(x) (SCM_SMOB_DATA_N ((x), 2))
+#define SCM_SMOB_DATA_3(x) (SCM_SMOB_DATA_N ((x), 3))
+#define SCM_SET_SMOB_DATA_0(x, data) (SCM_SET_SMOB_DATA_N ((x), 0, (data)))
+#define SCM_SET_SMOB_DATA_1(x, data) (SCM_SET_SMOB_DATA_N ((x), 1, (data)))
+#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_SMOB_DATA_N ((x), 2, (data)))
+#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_SMOB_DATA_N ((x), 3, (data)))
+
+#define SCM_SMOB_FLAGS(x) (SCM_SMOB_DATA_0 (x) >> 16)
+#define SCM_SMOB_DATA(x) (SCM_SMOB_DATA_1 (x))
+#define SCM_SET_SMOB_FLAGS(x, data) (SCM_SET_SMOB_DATA_0 ((x),
(SCM_CELL_TYPE (x)&0xffff)|((data)<<16)))
+#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_SMOB_DATA_1 ((x), (data)))
+
+#define SCM_SMOB_OBJECT_N(x,n) (SCM_CELL_OBJECT ((x), (n)))
+#define SCM_SET_SMOB_OBJECT_N(x,n,obj) (SCM_SET_CELL_OBJECT ((x), (n), (obj)))
+#define SCM_SMOB_OBJECT_N_LOC(x,n) (SCM_CELL_OBJECT_LOC ((x), (n)))
+
+/*#define SCM_SMOB_OBJECT_0(x) (SCM_SMOB_OBJECT_N ((x), 0))*/
+#define SCM_SMOB_OBJECT_1(x) (SCM_SMOB_OBJECT_N ((x), 1))
+#define SCM_SMOB_OBJECT_2(x) (SCM_SMOB_OBJECT_N ((x), 2))
+#define SCM_SMOB_OBJECT_3(x) (SCM_SMOB_OBJECT_N ((x), 3))
+/*#define SCM_SET_SMOB_OBJECT_0(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 0,
(obj)))*/
+#define SCM_SET_SMOB_OBJECT_1(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 1, (obj)))
+#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 2, (obj)))
+#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_SMOB_OBJECT_N ((x), 3, (obj)))
+#define SCM_SMOB_OBJECT_0_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 0)))
+#define SCM_SMOB_OBJECT_1_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 1)))
+#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 2)))
+#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_SMOB_OBJECT_N_LOC ((x), 3)))
+
+#define SCM_SMOB_OBJECT(x) (SCM_SMOB_OBJECT_1 (x))
+#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_SMOB_OBJECT_1 ((x), (obj)))
+#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)))
+
+
+#define SCM_SMOB_TYPE_MASK 0xffff
+#define SCM_SMOB_TYPE_BITS(tc) (tc)
#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
@@ -159,7 +181,6 @@ while (0)
SCM_API long scm_numsmob;
SCM_API scm_smob_descriptor scm_smobs[];
-SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data);
SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 720cff5..ef1fcd0 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -237,37 +237,37 @@ SCM_SNARF_INIT(
\
# define SCM_SYMBOL(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol
(scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
# define SCM_GLOBAL_SYMBOL(c_name, scheme_name)
\
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol
(scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
#define SCM_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword
(scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
#define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword
(scheme_name)))
+SCM_SNARF_INIT(c_name = scm_from_locale_keyword (scheme_name))
#define SCM_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name,
SCM_BOOL_F));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name,
SCM_BOOL_F));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, SCM_BOOL_F);)
#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name,
init_val));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name,
init_val));)
+SCM_SNARF_INIT(c_name = scm_c_define (scheme_name, init_val);)
#define SCM_MUTEX(c_name) \
SCM_SNARF_HERE(static scm_t_mutex c_name) \
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index 1103864..8ea7bf7 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -59,6 +59,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
+SCM scm_source_whash;
@@ -74,11 +75,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
-#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
+#define SRCPROPPOS(p) (SCM_SMOB_DATA(p))
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
-#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
-#define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p))
+#define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p))
+#define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p))
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
@@ -86,11 +87,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
-#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
+#define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c)))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
-#define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c))
-#define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
+#define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c))
+#define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l))
static SCM scm_srcprops_to_alist (SCM obj);
@@ -331,9 +332,8 @@ scm_init_srcprop ()
scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
scm_c_define ("source-whash", scm_source_whash);
- scm_last_alist_filename
- = scm_permanent_object (scm_cons (SCM_EOL,
- scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
+ scm_last_alist_filename = scm_cons (SCM_EOL,
+ scm_acons (SCM_EOL, SCM_EOL, SCM_EOL));
#include "libguile/srcprop.x"
}
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index a0f4772..34538d0 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -57,6 +57,7 @@ do { \
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
SCM_API scm_t_bits scm_tc16_srcprops;
+SCM_INTERNAL SCM scm_source_whash;
SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index 38ef320..09fe90c 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -2010,7 +2010,7 @@ define_charset (const char *name, const scm_t_char_set *p)
SCM_NEWSMOB (cs, scm_tc16_charset, p);
scm_c_define (name, cs);
- return scm_permanent_object (cs);
+ return cs;
}
SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index af8eaa3..45b9de0 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -65,9 +65,9 @@ int scm_tc16_uvec = 0;
- The vector's length (counted in elements).
- The address of the data area (holding the elements of the
vector). */
-#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
+#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
+#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
+#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
/* Symbolic constants encoding the various types of uniform
@@ -883,7 +883,8 @@ uvec_get_handle (SCM v, scm_t_array_handle *h)
h->elements = h->writable_elements = SCM_UVEC_BASE (v);
}
-SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
+ SCM_SMOB_TYPE_MASK,
uvec_handle_ref, uvec_handle_set,
uvec_get_handle);
@@ -895,14 +896,10 @@ scm_init_srfi_4 (void)
scm_set_smob_print (scm_tc16_uvec, uvec_print);
#if SCM_HAVE_T_INT64 == 0
- scm_uint64_min =
- scm_permanent_object (scm_from_int (0));
- scm_uint64_max =
- scm_permanent_object (scm_c_read_string ("18446744073709551615"));
- scm_int64_min =
- scm_permanent_object (scm_c_read_string ("-9223372036854775808"));
- scm_int64_max =
- scm_permanent_object (scm_c_read_string ("9223372036854775807"));
+ scm_uint64_min = scm_from_int (0);
+ scm_uint64_max = scm_c_read_string ("18446744073709551615");
+ scm_int64_min = scm_c_read_string ("-9223372036854775808");
+ scm_int64_max = scm_c_read_string ("9223372036854775807");
#endif
#define REGISTER(tag, TAG) \
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 79fe2bd..60f0159 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,4 +1,4 @@
-/* Representation of stack frame debug information
+/* A stack holds a frame chain
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software
Foundation
*
* This library is free software; you can redistribute it and/or
@@ -42,40 +42,10 @@
-/* {Frames and stacks}
+/* {Stacks}
*
- * The debugging evaluator creates debug frames on the stack. These
- * are linked from the innermost frame and outwards. The last frame
- * created can always be accessed as SCM_LAST_DEBUG_FRAME.
- * Continuations contain a pointer to the innermost debug frame on the
- * continuation stack.
- *
- * Each debug frame contains a set of flags and information about one
- * or more stack frames. The case of multiple frames occurs due to
- * tail recursion. The maximal number of stack frames which can be
- * recorded in one debug frame can be set dynamically with the debug
- * option FRAMES.
- *
- * Stack frame information is of two types: eval information (the
- * expression being evaluated and its environment) and apply
- * information (the procedure being applied and its arguments). A
- * stack frame normally corresponds to an eval/apply pair, but macros
- * and special forms (which are implemented as macros in Guile) only
- * have eval information and apply calls leads to apply only frames.
- *
- * Since we want to record the total stack information and later
- * manipulate this data at the scheme level in the debugger, we need
- * to transform it into a new representation. In the following code
- * section you'll find the functions implementing this data type.
- *
- * Representation:
- *
- * The stack is represented as a struct with an id slot and a tail
- * array of scm_t_info_frame structs.
- *
- * A frame is represented as a pair where the car contains a stack and
- * the cdr an inum. The inum is an index to the first SCM value of
- * the scm_t_info_frame struct.
+ * The stack is represented as a struct that holds a frame. The frame itself is
+ * linked to the next frame, or #f.
*
* Stacks
* Constructor
@@ -85,271 +55,26 @@
* stack-ref
* Inspector
* stack-length
- *
- * Frames
- * Constructor
- * last-stack-frame
- * Selectors
- * frame-number
- * frame-source
- * frame-procedure
- * frame-arguments
- * frame-previous
- * frame-next
- * Predicates
- * frame-real?
- * frame-procedure?
- * frame-evaluating-args?
- * frame-overflow? */
+ */
-/* Some auxiliary functions for reading debug frames off the stack.
- */
+static SCM stack_id_with_fp (SCM frame, SCM **fp);
-/* Stacks often contain pointers to other items on the stack; for
- example, each scm_t_debug_frame structure contains a pointer to the
- next frame out. When we capture a continuation, we copy the stack
- into the heap, and just leave all the pointers unchanged. This
- makes it simple to restore the continuation --- just copy the stack
- back! However, if we retrieve a pointer from the heap copy to
- another item that was originally on the stack, we have to add an
- offset to the pointer to discover the new referent.
-
- If PTR is a pointer retrieved from a continuation, whose original
- target was on the stack, and OFFSET is the appropriate offset from
- the original stack to the continuation, then RELOC_MUMBLE (PTR,
- OFFSET) is a pointer to the copy in the continuation of the
- original referent, cast to an scm_debug_MUMBLE *. */
-#define RELOC_INFO(ptr, offset) \
- ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
-#define RELOC_FRAME(ptr, offset) \
- ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
-
-/* Count number of debug info frames on a stack, beginning with
- * DFRAME. OFFSET is used for relocation of pointers when the stack
- * is read from a continuation.
+/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
- SCM *id)
+stack_depth (SCM frame, SCM *fp)
{
long n;
- for (n = 0;
- dframe && !SCM_VOIDFRAMEP (*dframe);
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && n > 0)
- --n;
- n += (info - vect) / 2 + 1;
- /* Data in the apply part of an eval info frame comes from previous
- stack frame if the scm_t_debug_info vector is overflowed. */
- if ((((info - vect) & 1) == 0)
- && SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- ++n;
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if (SCM_PROGRAM_P (vect[0].a.proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
- /* Programs can end up in the debug stack via deval; but we
just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- /* count vmframe back to previous boot frame */
- for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev
(vmframe))
- {
- if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
- ++n;
- else
- { /* skip boot frame, cut out of the vm backtrace */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- }
- }
- else
- ++n; /* increment for non-program apply frame */
- }
- }
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- *id = RELOC_INFO(dframe->vect, offset)[0].id;
+ /* count frames, skipping boot frames */
+ for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
+ frame = scm_c_frame_prev (frame))
+ if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ ++n;
return n;
}
-/* Read debug info from DFRAME into IFRAME.
- */
-static void
-read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- scm_t_info_frame *iframe)
-{
- scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
- if (SCM_EVALFRAMEP (*dframe))
- {
- scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- {
- /* Debug.vect ends with apply info. */
- --info;
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- if (!SCM_ARGS_READY_P (*dframe))
- flags |= SCM_FRAMEF_EVAL_ARGS;
- }
- }
- }
- else
- {
- scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
- flags |= SCM_FRAMEF_PROC;
- iframe->proc = vect[0].a.proc;
- iframe->args = vect[0].a.args;
- }
- iframe->flags = flags;
-}
-
-/* Look up the first body form of the apply closure. We'll use this
- below to prevent it from being displayed.
-*/
-static SCM
-get_applybody ()
-{
- SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
- return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
- else
- return SCM_UNDEFINED;
-}
-
-#define NEXT_FRAME(iframe, n, quit) \
-do { \
- ++iframe; \
- if (--n == 0) \
- goto quit; \
-} while (0)
-
-
-/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
- * starting with the first stack frame represented by debug frame
- * DFRAME.
- */
-
-static scm_t_bits
-read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
- SCM vmframe, long n, scm_t_info_frame *iframes)
-{
- scm_t_info_frame *iframe = iframes;
- scm_t_debug_info *info, *vect;
- static SCM applybody = SCM_UNDEFINED;
-
- /* The value of applybody has to be setup after r4rs.scm has executed. */
- if (SCM_UNBNDP (applybody))
- applybody = get_applybody ();
- for (;
- dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
- dframe = RELOC_FRAME (dframe->prev, offset))
- {
- read_frame (dframe, offset, iframe);
- if (SCM_EVALFRAMEP (*dframe))
- {
- /* If current frame is a macro during expansion, we should
- skip the previously recorded macro transformer
- application frame. */
- if (SCM_MACROEXPP (*dframe) && iframe > iframes)
- {
- *(iframe - 1) = *iframe;
- --iframe;
- ++n;
- }
- info = RELOC_INFO (dframe->info, offset);
- vect = RELOC_INFO (dframe->vect, offset);
- if ((info - vect) & 1)
- --info;
- /* Data in the apply part of an eval info frame comes from
- previous stack frame if the scm_t_debug_info vector is
- overflowed. */
- else if (SCM_OVERFLOWP (*dframe)
- && !SCM_UNBNDP (info[1].a.proc))
- {
- NEXT_FRAME (iframe, n, quit);
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- if (SCM_OVERFLOWP (*dframe))
- iframe->flags |= SCM_FRAMEF_OVERFLOW;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- while (info >= vect)
- {
- if (!SCM_UNBNDP (info[1].a.proc))
- {
- iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->proc = info[1].a.proc;
- iframe->args = info[1].a.args;
- }
- else
- iframe->flags = SCM_UNPACK (SCM_INUM0);
- iframe->source = SCM_BOOL_F;
- info -= 2;
- NEXT_FRAME (iframe, n, quit);
- }
- }
- else if (SCM_PROGRAM_P (iframe->proc))
- {
- if (!SCM_PROGRAM_IS_BOOT (iframe->proc))
- /* Programs can end up in the debug stack via deval; but we just
- ignore those, because we know that the debugging VM engine
- pushes one dframe per invocation, with the boot program as
- the proc, so we only count those. */
- continue;
- for (; scm_is_true (vmframe);
- vmframe = scm_c_vm_frame_prev (vmframe))
- {
- if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
- { /* skip boot frame, back to interpreted frames */
- vmframe = scm_c_vm_frame_prev (vmframe);
- break;
- }
- else
- {
- /* Oh dear, oh dear, oh dear. */
- iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
- iframe->source = scm_vm_frame_source (vmframe);
- iframe->proc = scm_vm_frame_program (vmframe);
- iframe->args = scm_vm_frame_arguments (vmframe);
- ++iframe;
- if (--n == 0)
- goto quit;
- }
- }
- }
- else
- {
- NEXT_FRAME (iframe, n, quit);
- }
- quit:
- if (iframe > iframes)
- (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
- }
- return iframe - iframes; /* Number of frames actually read */
-}
-
/* Narrow STACK by cutting away stackframes (mutatingly).
*
* Inner frames (most recent) are cut by advancing the frames pointer.
@@ -374,33 +99,48 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff
offset,
static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
- scm_t_stack *s = SCM_STACK (stack);
- unsigned long int i;
- long n = s->length;
+ unsigned long int len;
+ SCM frame;
+ len = SCM_STACK_LENGTH (stack);
+ frame = SCM_STACK_FRAME (stack);
+
/* Cut inner part. */
if (scm_is_eq (inner_key, SCM_BOOL_T))
{
- /* Cut all frames up to user module code */
- for (i = 0; inner; ++i, --inner)
- ;
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
+ {
+ len--;
+ frame = scm_c_frame_prev (frame);
+ }
}
else
- /* Use standard cutting procedure. */
{
- for (i = 0; inner; --inner)
- if (scm_is_eq (s->frames[i++].proc, inner_key))
- break;
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
+ {
+ SCM proc = scm_frame_procedure (frame);
+ len--;
+ frame = scm_c_frame_prev (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
+ }
}
- s->frames = &s->frames[i];
- n -= i;
+
+ SCM_SET_STACK_LENGTH (stack, len);
+ SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */
- for (; n && outer; --outer)
- if (scm_is_eq (s->frames[--n].proc, outer_key))
- break;
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ break;
+ }
- s->length = n;
+ SCM_SET_STACK_LENGTH (stack, len);
}
@@ -446,50 +186,44 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
- long n, size;
+ long n;
int maxp;
- scm_t_debug_frame *dframe;
- scm_t_info_frame *iframe;
- SCM vmframe;
- long offset = 0;
- SCM stack, id;
+ SCM frame;
+ SCM stack;
+ SCM id, *id_fp;
SCM inner_cut, outer_cut;
/* Extract a pointer to the innermost frame of whatever object
scm_make_stack was given. */
if (scm_is_eq (obj, SCM_BOOL_T))
{
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- dframe = scm_i_last_debug_frame ();
- vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
- }
- else if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- vmframe = SCM_BOOL_F;
+ SCM cont;
+ struct scm_vm_cont *c;
+
+ cont = scm_cdar (scm_vm_capture_continuations ());
+ c = SCM_VM_CONT_DATA (cont);
+
+ frame = scm_c_make_frame (cont, c->fp + c->reloc,
+ c->sp + c->reloc, c->ip,
+ c->reloc);
}
else if (SCM_VM_FRAME_P (obj))
- {
- dframe = NULL;
- vmframe = obj;
- }
+ frame = obj;
else if (SCM_CONTINUATIONP (obj))
{
scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
if (!scm_is_null (cont->vm_conts))
{ SCM vm_cont;
struct scm_vm_cont *data;
vm_cont = scm_cdr (scm_car (cont->vm_conts));
data = SCM_VM_CONT_DATA (vm_cont);
- vmframe = scm_c_make_vm_frame (vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ip,
- data->reloc);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
} else
- vmframe = SCM_BOOL_F;
+ frame = SCM_BOOL_F;
}
else
{
@@ -497,30 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* not reached */
}
+ if (scm_is_false (frame))
+ return SCM_BOOL_F;
+
+ /* Get ID of the stack corresponding to the given frame. */
+ id = stack_id_with_fp (frame, &id_fp);
+
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
id = SCM_BOOL_F;
maxp = 0;
- n = stack_depth (dframe, offset, vmframe, &id);
- /* FIXME: redo maxp? */
- size = n * SCM_FRAME_N_SLOTS;
+ n = stack_depth (frame, id_fp);
/* Make the stack object. */
- stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
- SCM_STACK (stack) -> id = id;
- iframe = &SCM_STACK (stack) -> tail[0];
- SCM_STACK (stack) -> frames = iframe;
- SCM_STACK (stack) -> length = n;
-
- /* Translate the current chain of stack frames into debugging information. */
- n = read_frames (dframe, offset, vmframe, n, iframe);
- if (n != SCM_STACK (stack)->length)
- {
- scm_puts ("warning: stack count incorrect!\n", scm_current_error_port
());
- SCM_STACK (stack)->length = n;
- }
-
+ stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, id);
+ SCM_SET_STACK_FRAME (stack, frame);
+
/* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (args);
while (n > 0 && !scm_is_null (args))
@@ -543,12 +272,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
scm_is_integer (outer_cut) ? 0 : outer_cut);
- n = SCM_STACK (stack) -> length;
+ n = SCM_STACK_LENGTH (stack);
}
- if (n > 0 && maxp)
- iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
-
if (n > 0)
return stack;
else
@@ -561,49 +287,76 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
"Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id
{
- scm_t_debug_frame *dframe;
- long offset = 0;
+ SCM frame, *id_fp;
+
if (scm_is_eq (stack, SCM_BOOL_T))
{
- dframe = scm_i_last_debug_frame ();
- }
- else if (SCM_DEBUGOBJP (stack))
- {
- dframe = SCM_DEBUGOBJ_FRAME (stack);
+ struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
+ frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
}
+ else if (SCM_VM_FRAME_P (stack))
+ frame = stack;
else if (SCM_CONTINUATIONP (stack))
{
scm_t_contregs *cont = SCM_CONTREGS (stack);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else if (SCM_STACKP (stack))
- {
- return SCM_STACK (stack) -> id;
+ if (!scm_is_null (cont->vm_conts))
+ { SCM vm_cont;
+ struct scm_vm_cont *data;
+ vm_cont = scm_cdr (scm_car (cont->vm_conts));
+ data = SCM_VM_CONT_DATA (vm_cont);
+ frame = scm_c_make_frame (vm_cont,
+ data->fp + data->reloc,
+ data->sp + data->reloc,
+ data->ip,
+ data->reloc);
+ } else
+ frame = SCM_BOOL_F;
}
else
{
- SCM_WRONG_TYPE_ARG (1, stack);
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
+ /* not reached */
}
- while (dframe && !SCM_VOIDFRAMEP (*dframe))
- dframe = RELOC_FRAME (dframe->prev, offset);
- if (dframe && SCM_VOIDFRAMEP (*dframe))
- return RELOC_INFO (dframe->vect, offset)[0].id;
- return SCM_BOOL_F;
+ return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
+static SCM
+stack_id_with_fp (SCM frame, SCM **fp)
+{
+ SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ if (SCM_VM_CONT_P (holder))
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ *fp = NULL;
+ return SCM_BOOL_F;
+ }
+}
+
SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM index),
"Return the @var{index}'th frame from @var{stack}.")
#define FUNC_NAME s_scm_stack_ref
{
unsigned long int c_index;
+ SCM frame;
SCM_VALIDATE_STACK (1, stack);
c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
- return scm_cons (stack, index);
+ frame = SCM_STACK_FRAME (stack);
+ while (c_index--)
+ {
+ frame = scm_c_frame_prev (frame);
+ while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ frame = scm_c_frame_prev (frame);
+ }
+ return frame;
}
#undef FUNC_NAME
@@ -613,174 +366,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
#define FUNC_NAME s_scm_stack_length
{
SCM_VALIDATE_STACK (1, stack);
- return scm_from_int (SCM_STACK_LENGTH (stack));
-}
-#undef FUNC_NAME
-
-/* Frames
- */
-
-SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a stack frame.")
-#define FUNC_NAME s_scm_frame_p
-{
- return scm_from_bool(SCM_FRAMEP (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
- (SCM obj),
- "Return the last (innermost) frame of @var{obj}, which must be\n"
- "either a debug object or a continuation.")
-#define FUNC_NAME s_scm_last_stack_frame
-{
- scm_t_debug_frame *dframe;
- long offset = 0;
- SCM stack;
-
- if (SCM_DEBUGOBJP (obj))
- {
- dframe = SCM_DEBUGOBJ_FRAME (obj);
- }
- else if (SCM_CONTINUATIONP (obj))
- {
- scm_t_contregs *cont = SCM_CONTREGS (obj);
- offset = cont->offset;
- dframe = RELOC_FRAME (cont->dframe, offset);
- }
- else
- {
- SCM_WRONG_TYPE_ARG (1, obj);
- /* not reached */
- }
-
- if (!dframe || SCM_VOIDFRAMEP (*dframe))
- return SCM_BOOL_F;
-
- stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
- SCM_EOL);
- SCM_STACK (stack) -> length = 1;
- SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
- read_frame (dframe, offset,
- (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
-
- return scm_cons (stack, SCM_INUM0);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
- (SCM frame),
- "Return the frame number of @var{frame}.")
-#define FUNC_NAME s_scm_frame_number
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_int (SCM_FRAME_NUMBER (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
- (SCM frame),
- "Return the source of @var{frame}.")
-#define FUNC_NAME s_scm_frame_source
-{
- SCM_VALIDATE_FRAME (1, frame);
- return SCM_FRAME_SOURCE (frame);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
- (SCM frame),
- "Return the procedure for @var{frame}, or @code{#f} if no\n"
- "procedure is associated with @var{frame}.")
-#define FUNC_NAME s_scm_frame_procedure
-{
- SCM_VALIDATE_FRAME (1, frame);
- return (SCM_FRAME_PROC_P (frame)
- ? SCM_FRAME_PROC (frame)
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
- (SCM frame),
- "Return the arguments of @var{frame}.")
-#define FUNC_NAME s_scm_frame_arguments
-{
- SCM_VALIDATE_FRAME (1, frame);
- return SCM_FRAME_ARGS (frame);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
- (SCM frame),
- "Return the previous frame of @var{frame}, or @code{#f} if\n"
- "@var{frame} is the first frame in its stack.")
-#define FUNC_NAME s_scm_frame_previous
-{
- unsigned long int n;
- SCM_VALIDATE_FRAME (1, frame);
- n = scm_to_ulong (SCM_CDR (frame)) + 1;
- if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
- return SCM_BOOL_F;
- else
- return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
- (SCM frame),
- "Return the next frame of @var{frame}, or @code{#f} if\n"
- "@var{frame} is the last frame in its stack.")
-#define FUNC_NAME s_scm_frame_next
-{
- unsigned long int n;
- SCM_VALIDATE_FRAME (1, frame);
- n = scm_to_ulong (SCM_CDR (frame));
- if (n == 0)
- return SCM_BOOL_F;
- else
- return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} is a real frame.")
-#define FUNC_NAME s_scm_frame_real_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_REAL_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if a procedure is associated with @var{frame}.")
-#define FUNC_NAME s_scm_frame_procedure_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_PROC_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} contains evaluated arguments.")
-#define FUNC_NAME s_scm_frame_evaluating_args_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
- (SCM frame),
- "Return @code{#t} if @var{frame} is an overflow frame.")
-#define FUNC_NAME s_scm_frame_overflow_p
-{
- SCM_VALIDATE_FRAME (1, frame);
- return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
+ return scm_from_long (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME
@@ -789,10 +375,8 @@ SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0,
0,
void
scm_init_stacks ()
{
- scm_stack_type =
- scm_permanent_object
- (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
- SCM_UNDEFINED));
+ scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
+ SCM_UNDEFINED);
scm_set_struct_vtable_name_x (scm_stack_type,
scm_from_locale_symbol ("stack"));
#include "libguile/stacks.x"
diff --git a/libguile/stacks.h b/libguile/stacks.h
index 20735ef..ba97e08 100644
--- a/libguile/stacks.h
+++ b/libguile/stacks.h
@@ -24,67 +24,28 @@
#include "libguile/__scm.h"
+#include "libguile/frames.h"
/* {Frames and stacks}
*/
-typedef struct scm_t_info_frame {
- /* SCM flags; */
- scm_t_bits flags;
- SCM source;
- SCM proc;
- SCM args;
-} scm_t_info_frame;
-#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM))
-
-#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj))
-#define SCM_STACK_LAYOUT "pwuourpW"
-typedef struct scm_t_stack {
- SCM id; /* Stack id */
- scm_t_info_frame *frames; /* Info frames */
- unsigned long length; /* Stack length */
- unsigned long tail_length;
- scm_t_info_frame tail[1];
-} scm_t_stack;
-
SCM_API SCM scm_stack_type;
-#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE
(obj), scm_stack_type))
-#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)
-
-#define SCM_FRAMEP(obj) \
- (scm_is_pair (obj) && SCM_STACKP (SCM_CAR (obj)) \
- && scm_is_unsigned_integer (SCM_CDR (obj), \
- 0, SCM_STACK_LENGTH (SCM_CAR (obj))-1))
+#define SCM_STACK_LAYOUT \
+ "pw" /* len */ \
+ "pw" /* id */ \
+ "pw" /* frame */
-#define SCM_FRAME_REF(frame, slot) \
-(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot)
-
-#define SCM_FRAME_NUMBER(frame) \
-(SCM_BACKWARDS_P \
- ? scm_to_size_t (SCM_CDR (frame)) \
- : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
- - scm_to_size_t (SCM_CDR (frame)) \
- - 1)) \
-
-#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
-#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
-#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
-#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
-#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
-#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
+#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE
(obj), scm_stack_type))
+#define SCM_STACK_LENGTH(obj) (scm_to_long (SCM_STRUCT_SLOT_REF (obj,0)))
+#define SCM_SET_STACK_LENGTH(obj,f) (SCM_STRUCT_SLOT_SET (obj,0,scm_from_long
(f)))
+#define SCM_STACK_ID(obj) (SCM_STRUCT_SLOT_REF (obj,1))
+#define SCM_SET_STACK_ID(obj,f) (SCM_STRUCT_SLOT_SET (obj,1,f))
+#define SCM_STACK_FRAME(obj) (SCM_STRUCT_SLOT_REF (obj,2))
+#define SCM_SET_STACK_FRAME(obj,f) (SCM_STRUCT_SLOT_SET (obj,2,f))
-#define SCM_FRAMEF_VOID (1L << 2)
-#define SCM_FRAMEF_REAL (1L << 3)
-#define SCM_FRAMEF_PROC (1L << 4)
-#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
-#define SCM_FRAMEF_OVERFLOW (1L << 6)
+#define SCM_FRAMEP(obj) (SCM_VM_FRAME_P (obj))
-#define SCM_FRAME_VOID_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_VOID)
-#define SCM_FRAME_REAL_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_REAL)
-#define SCM_FRAME_PROC_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_PROC)
-#define SCM_FRAME_EVAL_ARGS_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_EVAL_ARGS)
-#define SCM_FRAME_OVERFLOW_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_OVERFLOW)
@@ -94,19 +55,6 @@ SCM_API SCM scm_stack_id (SCM stack);
SCM_API SCM scm_stack_ref (SCM stack, SCM i);
SCM_API SCM scm_stack_length (SCM stack);
-SCM_API SCM scm_frame_p (SCM obj);
-SCM_API SCM scm_last_stack_frame (SCM obj);
-SCM_API SCM scm_frame_number (SCM frame);
-SCM_API SCM scm_frame_source (SCM frame);
-SCM_API SCM scm_frame_procedure (SCM frame);
-SCM_API SCM scm_frame_arguments (SCM frame);
-SCM_API SCM scm_frame_previous (SCM frame);
-SCM_API SCM scm_frame_next (SCM frame);
-SCM_API SCM scm_frame_real_p (SCM frame);
-SCM_API SCM scm_frame_procedure_p (SCM frame);
-SCM_API SCM scm_frame_evaluating_args_p (SCM frame);
-SCM_API SCM scm_frame_overflow_p (SCM frame);
-
SCM_INTERNAL void scm_init_stacks (void);
#endif /* SCM_STACKS_H */
diff --git a/libguile/strings.c b/libguile/strings.c
index 0ea50fd..651b019 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -253,6 +253,8 @@ scm_i_pthread_mutex_t stringbuf_write_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+SCM scm_nullstr;
+
/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
characters. CHARSP, if not NULL, will be set to location of the
char array. */
diff --git a/libguile/strings.h b/libguile/strings.h
index 601bd9c..edff0f8 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -98,6 +98,8 @@ typedef enum
SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE
} scm_t_string_failed_conversion_handler;
+SCM_INTERNAL SCM scm_nullstr;
+
SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
diff --git a/libguile/strorder.c b/libguile/strorder.c
index e0a2183..0338c65 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 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
@@ -42,8 +42,8 @@ srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM,
SCM, SCM))
return SCM_BOOL_F;
}
-SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic equality predicate; return @code{#t} if the two\n"
"strings are the same length and contain the same characters in\n"
"the same positions, otherwise return @code{#f}.\n"
@@ -52,103 +52,273 @@ SCM_DEFINE1 (scm_string_equal_p, "string=?",
scm_tc7_rpsubr,
"letters as though they were the same character, but\n"
"@code{string=?} treats upper and lower case as distinct\n"
"characters.")
-#define FUNC_NAME s_scm_string_equal_p
+#define FUNC_NAME s_scm_i_string_equal_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_eq);
+}
+#undef FUNC_NAME
+
+SCM scm_string_equal_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_equal_p
{
return srfi13_cmp (s1, s2, scm_string_eq);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case-insensitive string equality predicate; return @code{#t} if\n"
"the two strings are the same length and their component\n"
"characters match (ignoring case) at each position; otherwise\n"
"return @code{#f}.")
-#define FUNC_NAME s_scm_string_ci_equal_p
+#define FUNC_NAME s_scm_i_string_ci_equal_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_eq);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_equal_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_equal_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_eq);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically less than @var{s2}.")
-#define FUNC_NAME s_scm_string_less_p
+#define FUNC_NAME s_scm_i_string_less_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_lt);
+}
+#undef FUNC_NAME
+
+SCM scm_string_less_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_less_p
{
return srfi13_cmp (s1, s2, scm_string_lt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically less than or equal to @var{s2}.")
-#define FUNC_NAME s_scm_string_leq_p
+#define FUNC_NAME s_scm_i_string_leq_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_le);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_leq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_leq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_le);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically greater than @var{s2}.")
-#define FUNC_NAME s_scm_string_gr_p
+#define FUNC_NAME s_scm_i_string_gr_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_gt);
+}
+#undef FUNC_NAME
+
+SCM scm_string_gr_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_gr_p
{
return srfi13_cmp (s1, s2, scm_string_gt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
"is lexicographically greater than or equal to @var{s2}.")
-#define FUNC_NAME s_scm_string_geq_p
+#define FUNC_NAME s_scm_i_string_geq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ge);
+}
+#undef FUNC_NAME
+
+SCM scm_string_geq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_geq_p
{
return srfi13_cmp (s1, s2, scm_string_ge);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
"regardless of case.")
-#define FUNC_NAME s_scm_string_ci_less_p
+#define FUNC_NAME s_scm_i_string_ci_less_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_lt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_less_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_less_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_lt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically less than or equal\n"
"to @var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_leq_p
+#define FUNC_NAME s_scm_i_string_ci_leq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ci_le);
+}
+#undef FUNC_NAME
+
+SCM scm_string_ci_leq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_leq_p
{
return srfi13_cmp (s1, s2, scm_string_ci_le);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically greater than\n"
"@var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_gr_p
+#define FUNC_NAME s_scm_i_string_ci_gr_p
{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
return srfi13_cmp (s1, s2, scm_string_ci_gt);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
- (SCM s1, SCM s2),
+SCM scm_string_ci_gr_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_gr_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_gt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
+ (SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
"@code{#t} if @var{s1} is lexicographically greater than or\n"
"equal to @var{s2} regardless of case.")
-#define FUNC_NAME s_scm_string_ci_geq_p
+#define FUNC_NAME s_scm_i_string_ci_geq_p
+{
+ if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
+ return SCM_BOOL_F;
+ s1 = s2;
+ s2 = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return srfi13_cmp (s1, s2, scm_string_ci_ge);
+}
+#undef FUNC_NAME
+
+SCM scm_string_ci_geq_p (SCM s1, SCM s2)
+#define FUNC_NAME s_scm_i_string_ci_geq_p
{
return srfi13_cmp (s1, s2, scm_string_ci_ge);
}
diff --git a/libguile/struct.c b/libguile/struct.c
index 9fd73a6..321f2f1 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -21,6 +21,8 @@
# include <config.h>
#endif
+#include <alloca.h>
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
@@ -52,6 +54,10 @@ static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
SCM scm_struct_table = SCM_BOOL_F;
+SCM scm_applicable_struct_vtable_vtable;
+SCM scm_applicable_struct_with_setter_vtable_vtable;
+SCM scm_standard_vtable_vtable;
+
SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
@@ -206,12 +212,14 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
static void
-scm_struct_init (SCM handle, SCM layout, int tail_elts, SCM inits)
+scm_struct_init (SCM handle, SCM layout, size_t n_tail,
+ size_t n_inits, scm_t_bits *inits)
{
scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
int i;
+ size_t inits_idx = 0;
scm_t_bits *mem = SCM_STRUCT_DATA (handle);
i = -2;
@@ -225,60 +233,35 @@ scm_struct_init (SCM handle, SCM layout, int tail_elts,
SCM inits)
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
- n_fields += tail_elts - 1;
+ *mem++ = (scm_t_bits)n_tail;
+ n_fields += n_tail - 1;
if (n_fields == 0)
break;
}
}
switch (scm_i_symbol_ref (layout, i))
{
-#if 0
- case 'i':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_to_long (SCM_CAR (inits));
- inits = SCM_CDR (inits);
- }
- break;
-#endif
-
case 'u':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = 0;
else
{
- *mem = scm_to_ulong (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
+ inits_idx++;
}
break;
case 'p':
- if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
*mem = SCM_UNPACK (SCM_BOOL_F);
else
{
- *mem = SCM_UNPACK (SCM_CAR (inits));
- inits = SCM_CDR (inits);
+ *mem = inits[inits_idx];
+ inits_idx++;
}
break;
-#if 0
- case 'd':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *((double *)mem) = 0.0;
- else
- {
- *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
- inits = SCM_CDR (inits);
- }
- fields_desc += 2;
- break;
-#endif
-
case 's':
*mem = SCM_UNPACK (handle);
break;
@@ -338,7 +321,7 @@ struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
points to the given vtable data, then a data pointer, then n_words of data.
*/
SCM
-scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words, const char *what)
+scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
{
scm_t_bits ret;
ret = (scm_t_bits)scm_gc_malloc (sizeof (scm_t_bits) * (n_words + 2),
"struct");
@@ -363,40 +346,20 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words,
const char *what)
}
-SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
- (SCM vtable, SCM tail_array_size, SCM init),
- "Create a new structure.\n\n"
- "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
- "@var{tail-elts} must be a non-negative integer. If the layout\n"
- "specification indicated by @var{type} includes a tail-array,\n"
- "this is the number of elements allocated to that array.\n\n"
- "The @var{init1}, @dots{} are optional arguments describing how\n"
- "successive fields of the structure should be initialized. Only
fields\n"
- "with protection 'r' or 'w' can be initialized, except for fields
of\n"
- "type 's', which are automatically initialized to point to the
new\n"
- "structure itself. Fields with protection 'o' can not be
initialized by\n"
- "Scheme programs.\n\n"
- "If fewer optional arguments than initializable fields are
supplied,\n"
- "fields of type 'p' get default value #f while fields of type 'u'
are\n"
- "initialized to 0.\n\n"
- "For more information, see the documentation for
@code{make-vtable-vtable}.")
-#define FUNC_NAME s_scm_make_struct
+SCM
+scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
+#define FUNC_NAME "make-struct"
{
SCM layout;
size_t basic_size;
- size_t tail_elts;
SCM obj;
SCM_VALIDATE_VTABLE (1, vtable);
- SCM_VALIDATE_REST_ARGUMENT (init);
layout = SCM_VTABLE_LAYOUT (vtable);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
- /* A tail array is only allowed if the layout fields string ends in "R",
- "W" or "O". */
- if (tail_elts != 0)
+ if (n_tail != 0)
{
SCM layout_str, last_char;
@@ -413,10 +376,9 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
goto bad_tail;
}
- obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + tail_elts,
- "struct");
+ obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail);
- scm_struct_init (obj, layout, tail_elts, init);
+ scm_struct_init (obj, layout, n_tail, n_init, init);
/* only check things and inherit magic if the layout was passed as an
initarg.
something of a hack, but it's for back-compatibility. */
@@ -428,6 +390,70 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
}
#undef FUNC_NAME
+SCM
+scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init,
...)
+{
+ va_list foo;
+ scm_t_bits *v;
+ size_t i;
+
+ v = alloca (sizeof (scm_t_bits) * n_init);
+
+ va_start (foo, init);
+ for (i = 0; i < n_init; i++)
+ {
+ v[i] = init;
+ init = va_arg (foo, scm_t_bits);
+ }
+ va_end (foo);
+
+ return scm_c_make_structv (vtable, n_tail, n_init, v);
+}
+
+SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+ (SCM vtable, SCM tail_array_size, SCM init),
+ "Create a new structure.\n\n"
+ "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{tail-elts} must be a non-negative integer. If the layout\n"
+ "specification indicated by @var{type} includes a tail-array,\n"
+ "this is the number of elements allocated to that array.\n\n"
+ "The @var{init1}, @dots{} are optional arguments describing how\n"
+ "successive fields of the structure should be initialized. Only
fields\n"
+ "with protection 'r' or 'w' can be initialized, except for fields
of\n"
+ "type 's', which are automatically initialized to point to the
new\n"
+ "structure itself. Fields with protection 'o' can not be
initialized by\n"
+ "Scheme programs.\n\n"
+ "If fewer optional arguments than initializable fields are
supplied,\n"
+ "fields of type 'p' get default value #f while fields of type 'u'
are\n"
+ "initialized to 0.\n\n"
+ "For more information, see the documentation for
@code{make-vtable-vtable}.")
+#define FUNC_NAME s_scm_make_struct
+{
+ size_t i, n_init;
+ long ilen;
+ scm_t_bits *v;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen;
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
+
+ for (i = 0; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
+ return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init,
v);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
@@ -481,31 +507,48 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable",
2, 0, 1,
SCM fields;
SCM layout;
size_t basic_size;
- size_t tail_elts;
+ size_t n_tail, i, n_init;
SCM obj;
+ long ilen;
+ scm_t_bits *v;
SCM_VALIDATE_STRING (1, user_fields);
- SCM_VALIDATE_REST_ARGUMENT (init);
+ ilen = scm_ilength (init);
+ if (ilen < 0)
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
+
+ n_init = (size_t)ilen + 1; /* + 1 for the layout */
+
+ /* best to use alloca, but init could be big, so hack to avoid a possible
+ stack overflow */
+ if (n_init < 64)
+ v = alloca (n_init * sizeof(scm_t_bits));
+ else
+ v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
fields = scm_string_append (scm_list_2 (required_vtable_fields,
user_fields));
layout = scm_make_struct_layout (fields);
basic_size = scm_i_symbol_length (layout) / 2;
- tail_elts = scm_to_size_t (tail_array_size);
+ n_tail = scm_to_size_t (tail_array_size);
+
+ i = 0;
+ v[i++] = SCM_UNPACK (layout);
+ for (; i < n_init; i++, init = SCM_CDR (init))
+ v[i] = SCM_UNPACK (SCM_CAR (init));
+
SCM_CRITICAL_SECTION_START;
- obj = scm_i_alloc_struct (NULL, basic_size + tail_elts, "struct");
+ obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
/* magic magic magic */
SCM_SET_CELL_WORD_0 (obj, (scm_t_bits)SCM_STRUCT_DATA (obj) |
scm_tc3_struct);
SCM_CRITICAL_SECTION_END;
- scm_struct_init (obj, layout, tail_elts, scm_cons (layout, init));
+ scm_struct_init (obj, layout, n_tail, n_init, v);
SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);
return obj;
}
#undef FUNC_NAME
-static SCM scm_i_vtable_vtable_no_extra_fields;
-
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
"Create a vtable, for creating structures with the given\n"
@@ -519,7 +562,7 @@ SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
if (SCM_UNBNDP (printer))
printer = SCM_BOOL_F;
- return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ return scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_2 (scm_make_struct_layout (fields),
printer));
}
@@ -854,17 +897,8 @@ scm_print_struct (SCM exp, SCM port, scm_print_state
*pstate)
}
void
-scm_struct_prehistory ()
-{
- /* Empty. */
-}
-
-void
scm_init_struct ()
{
- SCM scm_applicable_struct_vtable_vtable;
- SCM scm_applicable_struct_with_setter_vtable_vtable;
-
GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)); /* for the self data
pointer */
GC_REGISTER_DISPLACEMENT (2*sizeof(scm_t_bits)
+ scm_tc3_struct); /* for the vtable data pointer
*/
@@ -874,18 +908,18 @@ scm_init_struct ()
required_applicable_fields = scm_from_locale_string
(SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string
(SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_i_vtable_vtable_no_extra_fields =
+ scm_standard_vtable_vtable =
scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
scm_applicable_struct_vtable_vtable =
- scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout
(required_vtable_fields)));
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
scm_c_define ("<applicable-struct-vtable>",
scm_applicable_struct_vtable_vtable);
scm_applicable_struct_with_setter_vtable_vtable =
- scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
scm_list_1 (scm_make_struct_layout
(required_vtable_fields)));
SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
SCM_VTABLE_FLAG_APPLICABLE_VTABLE |
SCM_VTABLE_FLAG_SETTER_VTABLE);
diff --git a/libguile/struct.h b/libguile/struct.h
index 9372cec..537ef90 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -35,7 +35,7 @@
I would like to write this all up here, but for now:
- http://wingolog.org/pub/goops-class-redefinition-3.png
+ http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
*/
/* All vtables have the following fields. */
@@ -81,7 +81,7 @@
#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are
applicable-with-setters? */
#define SCM_VTABLE_FLAG_RESERVED_0 (1L << 5)
#define SCM_VTABLE_FLAG_RESERVED_1 (1L << 6)
-#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 7)
+#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
@@ -110,8 +110,10 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_SET_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) |= (F))
#define SCM_CLEAR_VTABLE_FLAGS(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) &= (~(F)))
#define SCM_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_DATA_REF (X,
scm_vtable_index_flags) & (F))
-#define SCM_VTABLE_INSTANCE_FINALIZER(X)
((scm_t_struct_finalize)SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_instance_finalize))
+#define SCM_VTABLE_INSTANCE_FINALIZER(X)
((scm_t_struct_finalize)SCM_STRUCT_DATA_REF (X,
scm_vtable_index_instance_finalize))
+#define SCM_SET_VTABLE_INSTANCE_FINALIZER(X,P) (SCM_STRUCT_DATA_SET (X,
scm_vtable_index_instance_finalize, (scm_t_bits)(P)))
#define SCM_VTABLE_INSTANCE_PRINTER(X) (SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_instance_printer))
+#define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X,
scm_vtable_index_instance_printer, (P)))
#define SCM_VTABLE_NAME(X) (SCM_STRUCT_SLOT_REF (X,
scm_vtable_index_name))
#define SCM_SET_VTABLE_NAME(X,V) (SCM_STRUCT_SLOT_SET (X,
scm_vtable_index_name, V))
@@ -141,12 +143,20 @@ typedef void (*scm_t_struct_finalize) (SCM obj);
#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
SCM_API SCM scm_struct_table;
+SCM_API SCM scm_standard_vtable_vtable;
+SCM_API SCM scm_applicable_struct_vtable_vtable;
+SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;
+
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
+SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init, ...);
+SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
+ scm_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM
init);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
@@ -157,11 +167,10 @@ SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
-SCM_API void scm_struct_prehistory (void);
SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
-SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words,
const char *what);
+SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL void scm_init_struct (void);
diff --git a/libguile/tags.h b/libguile/tags.h
index 92d0bb8..e1e0913 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -386,7 +386,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc3_cons 0
#define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0)
-#define scm_tc3_closure 3
+#define scm_tc3_unused 3
#define scm_tc3_imm24 4
#define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4)
@@ -411,34 +411,30 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_stringbuf 39
#define scm_tc7_bytevector 77
-/* Many of the following should be turned
- * into structs or smobs. We need back some
- * of these 7 bit tags! */
+#define scm_tc7_unused_1 31
+#define scm_tc7_hashtable 29
+#define scm_tc7_fluid 37
+#define scm_tc7_dynamic_state 45
-#define scm_tc7_pws 31
-
-#define scm_tc7_unused_1 29
-#define scm_tc7_unused_2 37
-#define scm_tc7_unused_3 45
#define scm_tc7_unused_4 47
#define scm_tc7_unused_5 53
#define scm_tc7_unused_6 55
#define scm_tc7_unused_7 71
-#define scm_tc7_dsubr 61
+#define scm_tc7_unused_17 61
#define scm_tc7_gsubr 63
-#define scm_tc7_rpsubr 69
+#define scm_tc7_unused_19 69
#define scm_tc7_program 79
-#define scm_tc7_subr_0 85
-#define scm_tc7_subr_1 87
-#define scm_tc7_cxr 93
-#define scm_tc7_subr_3 95
-#define scm_tc7_subr_2 101
-#define scm_tc7_asubr 103
-#define scm_tc7_subr_1o 109
-#define scm_tc7_subr_2o 111
-#define scm_tc7_lsubr_2 117
-#define scm_tc7_lsubr 119
+#define scm_tc7_unused_9 85
+#define scm_tc7_unused_10 87
+#define scm_tc7_unused_20 93
+#define scm_tc7_unused_11 95
+#define scm_tc7_unused_12 101
+#define scm_tc7_unused_18 103
+#define scm_tc7_unused_13 109
+#define scm_tc7_unused_14 111
+#define scm_tc7_unused_15 117
+#define scm_tc7_unused_16 119
/* There are 256 port subtypes. */
#define scm_tc7_port 125
@@ -652,41 +648,9 @@ enum scm_tc8_tags
case scm_tc3_struct + 112:\
case scm_tc3_struct + 120
-/* For closures
- */
-#define scm_tcs_closures \
- scm_tc3_closure + 0:\
- case scm_tc3_closure + 8:\
- case scm_tc3_closure + 16:\
- case scm_tc3_closure + 24:\
- case scm_tc3_closure + 32:\
- case scm_tc3_closure + 40:\
- case scm_tc3_closure + 48:\
- case scm_tc3_closure + 56:\
- case scm_tc3_closure + 64:\
- case scm_tc3_closure + 72:\
- case scm_tc3_closure + 80:\
- case scm_tc3_closure + 88:\
- case scm_tc3_closure + 96:\
- case scm_tc3_closure + 104:\
- case scm_tc3_closure + 112:\
- case scm_tc3_closure + 120
-
/* For subrs
*/
#define scm_tcs_subrs \
- scm_tc7_asubr:\
- case scm_tc7_subr_0:\
- case scm_tc7_subr_1:\
- case scm_tc7_dsubr:\
- case scm_tc7_cxr:\
- case scm_tc7_subr_3:\
- case scm_tc7_subr_2:\
- case scm_tc7_rpsubr:\
- case scm_tc7_subr_1o:\
- case scm_tc7_subr_2o:\
- case scm_tc7_lsubr_2:\
- case scm_tc7_lsubr: \
case scm_tc7_gsubr
diff --git a/libguile/threads.c b/libguile/threads.c
index 1527e01..f9344e4 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -338,7 +338,6 @@ guilify_self_1 (SCM_STACKITEM *base)
t->block_asyncs = 1;
t->pending_asyncs = 1;
t->critical_section_level = 0;
- t->last_debug_frame = NULL;
t->base = base;
#ifdef __ia64__
/* Calculate and store off the base of this thread's register
@@ -1948,15 +1947,14 @@ scm_init_threads ()
guilify_self_2 (SCM_BOOL_F);
threads_initialized_p = 1;
- dynwind_critical_section_mutex =
- scm_permanent_object (scm_make_recursive_mutex ());
+ dynwind_critical_section_mutex = scm_make_recursive_mutex ();
}
void
scm_init_threads_default_dynamic_state ()
{
SCM state = scm_make_dynamic_state (scm_current_dynamic_state ());
- scm_i_default_dynamic_state = scm_permanent_object (state);
+ scm_i_default_dynamic_state = state;
}
void
diff --git a/libguile/threads.h b/libguile/threads.h
index 5afe45f..4b06590 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -79,7 +79,6 @@ typedef struct scm_i_thread {
/* Other thread local things.
*/
SCM dynamic_state;
- scm_t_debug_frame *last_debug_frame;
SCM dynwinds;
/* For system asyncs.
@@ -209,9 +208,6 @@ SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key;
# define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
# define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
-# define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
-# define scm_i_set_last_debug_frame(f) \
- (SCM_I_CURRENT_THREAD->last_debug_frame =
(f))
#endif /* BUILDING_LIBGUILE */
diff --git a/libguile/throw.c b/libguile/throw.c
index 14153cf..fd08e6e 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -54,18 +54,14 @@ static scm_t_bits tc16_jmpbuffer;
#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
-#define ACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
-#define DEACTIVATEJB(x) \
- (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
-
-#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
-#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
-#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
-#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
-#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3
(x))
-#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
+#define JBACTIVE(OBJ) (SCM_SMOB_FLAGS (OBJ) & 1L)
+#define ACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 1L))
+#define DEACTIVATEJB(x) (SCM_SET_SMOB_FLAGS ((x), 0L))
+
+#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_SMOB_DATA_1 (OBJ))
+#define SETJBJMPBUF(x, v) (SCM_SET_SMOB_DATA_1 ((x), (scm_t_bits) (v)))
+#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_SMOB_DATA_3
(x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_SMOB_DATA_3 ((x), (scm_t_bits) (v)))
static int
jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
@@ -187,7 +183,6 @@ scm_c_catch (SCM tag,
answer = SCM_EOL;
scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
SETJBJMPBUF(jmpbuf, &jbr.buf);
- SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
pre_unwind.handler = pre_unwind_handler;
pre_unwind.handler_data = pre_unwind_handler_data;
@@ -272,7 +267,7 @@ static scm_t_bits tc16_pre_unwind_data;
static int
pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate
SCM_UNUSED)
{
- struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1
(closure);
+ struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_SMOB_DATA_1
(closure);
char buf[200];
sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
@@ -786,7 +781,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
else
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
if (!c->running)
break;
}
@@ -819,7 +814,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
{
struct pre_unwind_data *c =
- (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ (struct pre_unwind_data *) SCM_SMOB_DATA_1 (jmpbuf);
SCM handle, answer;
/* For old-style lazy-catch behaviour, we unwind the dynamic
@@ -888,7 +883,6 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
- scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
}
diff --git a/libguile/validate.h b/libguile/validate.h
index be4ed48..b0e502a 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -278,7 +278,7 @@
#define SCM_VALIDATE_SMOB(pos, obj, type) \
do { \
- SCM_ASSERT (SCM_TYP16_PREDICATE (scm_tc16_ ## type, obj), \
+ SCM_ASSERT (SCM_SMOB_PREDICATE (scm_tc16_ ## type, obj), \
obj, pos, FUNC_NAME); \
} while (0)
@@ -296,8 +296,6 @@
#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj,
MEMOIZED_P, "memoized code")
-#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj,
CLOSUREP, "closure")
-
#define SCM_VALIDATE_PROC(pos, proc) \
do { \
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
diff --git a/libguile/values.c b/libguile/values.c
index 71cdbe2..967fcd6 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -77,8 +77,7 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
void
scm_init_values (void)
{
- SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2,
- print_values);
+ SCM print = scm_c_define_gsubr ("%print-values", 2, 0, 0, print_values);
scm_values_vtable = scm_make_vtable (scm_from_locale_string ("pr"), print);
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 405ebb1..fddf0ce 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -637,8 +637,6 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM,
scm_make_vector);
void
scm_init_vectors ()
{
- scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
-
#include "libguile/vectors.x"
}
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 03993ec..2f3320c 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -23,13 +23,11 @@
#define VM_USE_CLOCK 0 /* Bogoclock */
#define VM_CHECK_OBJECT 1 /* Check object table */
#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
-#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator
debug stack */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
#define VM_USE_CLOCK 1
#define VM_CHECK_OBJECT 1
#define VM_CHECK_FREE_VARIABLES 1
-#define VM_PUSH_DEBUG_FRAMES 1
#else
#error unknown debug engine VM_ENGINE
#endif
@@ -66,12 +64,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
static void **jump_table = NULL;
#endif
-#if VM_PUSH_DEBUG_FRAMES
- scm_t_debug_frame debug;
- scm_t_debug_info debug_vect_body;
- debug.status = SCM_VOIDFRAME;
-#endif
-
#ifdef HAVE_LABELS_AS_VALUES
if (SCM_UNLIKELY (!jump_table))
{
@@ -95,15 +87,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* Boot program */
program = vm_make_boot_program (nargs);
-#if VM_PUSH_DEBUG_FRAMES
- debug.prev = scm_i_last_debug_frame ();
- debug.status = SCM_APPLYFRAME;
- debug.vect = &debug_vect_body;
- debug.vect[0].a.proc = program; /* the boot program */
- debug.vect[0].a.args = SCM_EOL;
- scm_i_set_last_debug_frame (&debug);
-#endif
-
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
@@ -147,9 +130,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
vm_done:
SYNC_ALL ();
-#if VM_PUSH_DEBUG_FRAMES
- scm_i_set_last_debug_frame (debug.prev);
-#endif
return finish_args;
/* Errors */
@@ -278,7 +258,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
#undef VM_USE_CLOCK
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE
-#undef VM_PUSH_DEBUG_FRAMES
/*
Local Variables:
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 6d32a6c..d7523cc 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -766,11 +766,6 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_call;
}
- else if (SCM_PROCEDURE_WITH_SETTER_P (x))
- {
- sp[-nargs] = SCM_PROCEDURE (x);
- goto vm_call;
- }
/*
* Other interpreted or compiled call
*/
@@ -850,12 +845,6 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1,
1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_goto_args;
}
- else if (SCM_PROCEDURE_WITH_SETTER_P (x))
- {
- sp[-nargs] = SCM_PROCEDURE (x);
- goto vm_goto_args;
- }
-
/*
* Other interpreted or compiled call
*/
@@ -943,11 +932,6 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_mv_call;
}
- else if (SCM_PROCEDURE_WITH_SETTER_P (x))
- {
- sp[-nargs] = SCM_PROCEDURE (x);
- goto vm_mv_call;
- }
/*
* Other interpreted or compiled call
*/
diff --git a/libguile/vm.c b/libguile/vm.c
index 247bb7d..0e511f6 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -159,7 +159,7 @@ vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM
hook_args)
scm_dynwind_begin (0);
/* FIXME, stack holder should be the vm */
- vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip,
0);
+ vp->trace_frame = scm_c_make_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
scm_c_run_hook (hook, hook_args);
@@ -212,7 +212,7 @@ vm_make_boot_program (long nargs)
{
int i;
for (i = 0; i < NUM_BOOT_PROGS; i++)
- programs[i] = scm_permanent_object (really_make_boot_program (i));
+ programs[i] = really_make_boot_program (i);
}
if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
@@ -265,104 +265,10 @@ resolve_variable (SCM what, SCM program_module)
static SCM
apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
{
- SCM arg1, arg2, arg3;
-
SCM_ASRTGO (SCM_NIMP (proc), badproc);
- /* Parse args. */
- switch (nargs)
- {
- case 0:
- arg1 = SCM_UNDEFINED; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
- break;
- case 1:
- arg1 = args[0]; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
- break;
- case 2:
- arg1 = args[0]; arg2 = args[1]; arg3 = SCM_UNDEFINED;
- break;
- default:
- arg1 = args[0]; arg2 = args[1]; arg3 = args[2];
- break;
- }
-
switch (SCM_TYP7 (proc))
{
- case scm_tcs_closures:
- /* FIXME: pre-boot closures should be smobs */
- {
- SCM arglist = SCM_EOL;
- while (nargs--)
- arglist = scm_cons (args[nargs], arglist);
- return scm_closure_apply (proc, arglist);
- }
- case scm_tc7_subr_2o:
- if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2);
- case scm_tc7_subr_2:
- if (nargs != 2) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2);
- case scm_tc7_subr_0:
- if (nargs != 0) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) ();
- case scm_tc7_subr_1:
- if (nargs != 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1);
- case scm_tc7_subr_1o:
- if (nargs > 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1);
- case scm_tc7_dsubr:
- if (nargs != 1) scm_wrong_num_args (proc);
- if (SCM_I_INUMP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM
(arg1)));
- else if (SCM_REALP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)));
- else if (SCM_BIGP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)));
- else if (SCM_FRACTIONP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double
(arg1)));
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
- case scm_tc7_cxr:
- if (nargs != 1) scm_wrong_num_args (proc);
- return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
- case scm_tc7_subr_3:
- if (nargs != 3) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2, arg3);
- case scm_tc7_lsubr:
- {
- SCM arglist = SCM_EOL;
- while (nargs--)
- arglist = scm_cons (args[nargs], arglist);
- return SCM_SUBRF (proc) (arglist);
- }
- case scm_tc7_lsubr_2:
- if (nargs < 2) scm_wrong_num_args (proc);
- {
- SCM arglist = SCM_EOL;
- while (nargs-- > 2)
- arglist = scm_cons (args[nargs], arglist);
- return SCM_SUBRF (proc) (arg1, arg2, arglist);
- }
- case scm_tc7_asubr:
- if (nargs < 2)
- return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
- {
- int idx = 1;
- while (nargs-- > 1)
- arg1 = SCM_SUBRF (proc) (arg1, args[idx++]);
- return arg1;
- }
- case scm_tc7_rpsubr:
- {
- int idx = 0;
- while (nargs-- > 1)
- { idx++;
- if (scm_is_false (SCM_SUBRF (proc) (args[idx-1], args[idx])))
- return SCM_BOOL_F;
- }
- return SCM_BOOL_T;
- }
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badproc;
@@ -371,15 +277,15 @@ apply_foreign (SCM proc, SCM *args, int nargs, int
headroom)
case 0:
return SCM_SMOB_APPLY_0 (proc);
case 1:
- return SCM_SMOB_APPLY_1 (proc, arg1);
+ return SCM_SMOB_APPLY_1 (proc, args[0]);
case 2:
- return SCM_SMOB_APPLY_2 (proc, arg1, arg2);
+ return SCM_SMOB_APPLY_2 (proc, args[0], args[1]);
default:
{
SCM arglist = SCM_EOL;
while (nargs-- > 2)
arglist = scm_cons (args[nargs], arglist);
- return SCM_SMOB_APPLY_3 (proc, arg1, arg2, arglist);
+ return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
}
}
case scm_tc7_gsubr:
@@ -531,6 +437,12 @@ scm_vm_apply (SCM vm, SCM program, SCM args)
}
#undef FUNC_NAME
+SCM
+scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
+{
+ return scm_c_vm_run (vm, thunk, NULL, 0);
+}
+
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
@@ -773,9 +685,9 @@ scm_bootstrap_vm (void)
scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
scm_load_compiled_with_vm));
- sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
- sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
- sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
+ sym_vm_run = scm_from_locale_symbol ("vm-run");
+ sym_vm_error = scm_from_locale_symbol ("vm-error");
+ sym_debug = scm_from_locale_symbol ("debug");
scm_c_register_extension ("libguile", "scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
diff --git a/libguile/vm.h b/libguile/vm.h
index eace1cb..9479ba7 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -65,6 +65,7 @@ SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
@@ -98,7 +99,7 @@ struct scm_vm_cont {
SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
SCM_API SCM scm_vm_capture_continuations (void);
SCM_API void scm_vm_reinstate_continuations (SCM conts);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index f4274f7..20da580 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -945,89 +945,6 @@
-;;; {Transcendental Functions}
-;;;
-;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Written by Jerry D. Hedden, (C) FSF.
-;;; See the file `COPYING' for terms applying to this program.
-;;;
-
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((and (exact? z2) (integer? z2))
- (integer-expt z1 z2))
- ((and (real? z2) (real? z1) (>= z1 0))
- ($expt z1 z2))
- (else
- (exp (* z2 (log z1))))))))
-
-(define (sinh z)
- (if (real? z) ($sinh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sinh x) ($cos y))
- (* ($cosh x) ($sin y))))))
-(define (cosh z)
- (if (real? z) ($cosh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cosh x) ($cos y))
- (* ($sinh x) ($sin y))))))
-(define (tanh z)
- (if (real? z) ($tanh z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cosh x) ($cos y))))
- (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
-
-(define (asinh z)
- (if (real? z) ($asinh z)
- (log (+ z (sqrt (+ (* z z) 1))))))
-
-(define (acosh z)
- (if (and (real? z) (>= z 1))
- ($acosh z)
- (log (+ z (sqrt (- (* z z) 1))))))
-
-(define (atanh z)
- (if (and (real? z) (> z -1) (< z 1))
- ($atanh z)
- (/ (log (/ (+ 1 z) (- 1 z))) 2)))
-
-(define (sin z)
- (if (real? z) ($sin z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sin x) ($cosh y))
- (* ($cos x) ($sinh y))))))
-(define (cos z)
- (if (real? z) ($cos z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cos x) ($cosh y))
- (- (* ($sin x) ($sinh y)))))))
-(define (tan z)
- (if (real? z) ($tan z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cos x) ($cosh y))))
- (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
-
-(define (asin z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($asin z)
- (* -i (asinh (* +i z)))))
-
-(define (acos z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($acos z)
- (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
-
-(define (atan z . y)
- (if (null? y)
- (if (real? z) ($atan z)
- (/ (log (/ (- +i z) (+ +i z))) +2i))
- ($atan2 z (car y))))
-
-
-
;;; {Reader Extensions}
;;;
;;; Reader code for various "#c" forms.
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index a48edb7..0d632b2 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -207,3 +207,24 @@
(issue-deprecation-warning
"`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
(apply unmemoize-expression args))
+
+(define ($asinh z) (asinh z))
+(define ($acosh z) (acosh z))
+(define ($atanh z) (atanh z))
+(define ($sqrt z) (sqrt z))
+(define ($abs z) (abs z))
+(define ($exp z) (exp z))
+(define ($log z) (log z))
+(define ($sin z) (sin z))
+(define ($cos z) (cos z))
+(define ($tan z) (tan z))
+(define ($asin z) (asin z))
+(define ($acos z) (acos z))
+(define ($atan z) (atan z))
+(define ($sinh z) (sinh z))
+(define ($cosh z) (cosh z))
+(define ($tanh z) (tanh z))
+(define (closure? x)
+ (issue-deprecation-warning
+ "`closure?' is deprecated. Use `procedure?' instead.")
+ (procedure? x))
diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm
index bbd6713..37c3bf7 100644
--- a/module/ice-9/documentation.scm
+++ b/module/ice-9/documentation.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 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
@@ -201,7 +201,6 @@ OBJECT can be a procedure, macro or any object that has its
(and (macro? object)
(object-documentation (macro-transformer object)))
(and (procedure? object)
- (not (closure? object))
(procedure-name object)
(let ((docstring (search-documentation-files
(procedure-name object))))
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 70708c3..f6cad46 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -163,10 +163,8 @@ You don't seem to have regular expressions installed.\n")
(cons (list module
name
(try-value-help name object)
- (cond ((closure? object)
+ (cond ((procedure? object)
"a procedure")
- ((procedure? object)
- "a primitive procedure")
(else
"an object")))
data))
@@ -498,17 +496,7 @@ It is an image under the mapping EXTRACT."
(= (car arity) 1)
(<= (cadr arity) 1))
(display " argument")
- (display " arguments"))
- (if (closure? obj)
- (let ((formals (cadr (procedure-source obj))))
- (cond
- ((pair? formals)
- (display ": ")
- (display-arg-list formals))
- (else
- (display " in `")
- (display formals)
- (display #\'))))))))
+ (display " arguments")))))
(display ".\n"))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index bf13e38..50d9828 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1161,20 +1161,15 @@
;;; compute-getters-n-setters
;;;
-;; FIXME!!!
-(define (make-thunk thunk)
- (lambda () (thunk)))
-
(define (compute-getters-n-setters class slots)
(define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s)))
(and thunk
- (cond ((not (thunk? thunk))
- (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
- name class thunk))
- ((closure? thunk) thunk)
- (else (make-thunk thunk)))))
+ (if (thunk? thunk)
+ thunk
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))))
(let ((init (slot-definition-init-value s)))
(and (not (unbound? init))
(lambda () init)))))
@@ -1187,18 +1182,11 @@
(else
(let ((get (car l))
(set (cadr l)))
- ;; note that we allow non-closures; we only check arity on
- ;; the closures, though, because we inline their dispatch
- ;; in %get-slot-value / %set-slot-value.
- (if (or (not (procedure? get))
- (and (closure? get)
- (not (= (car (procedure-property get 'arity)) 1))))
- (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? get))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
slot class get))
- (if (or (not (procedure? set))
- (and (closure? set)
- (not (= (car (procedure-property set 'arity)) 2))))
- (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ (if (not (procedure? set))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set))))))
(map (lambda (s)
@@ -1467,11 +1455,8 @@
(cond ((not proc))
((pair? proc)
(apply set-object-procedure! object proc))
- ((valid-object-procedure? proc)
- (set-object-procedure! object proc))
(else
- (set-object-procedure! object
- (lambda args (apply proc args)))))))
+ (set-object-procedure! object proc)))))
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
(next-method)
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index fa7bc46..86b2d2c 100644
--- a/module/oop/goops/describe.scm
+++ b/module/oop/goops/describe.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation,
Inc.
+;;;; Copyright (C) 1998, 1999, 2001, 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
@@ -67,10 +67,7 @@
(display x))
(display " is ")
(display (if name #\a "an anonymous"))
- (display (cond ((closure? x) " procedure")
- ((not (struct? x)) " primitive procedure")
- ((entity? x) " entity")
- (else " operator")))
+ (display " procedure")
(display " with ")
(arity x)))
diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm
index 590d223..7077f37 100644
--- a/module/system/repl/describe.scm
+++ b/module/system/repl/describe.scm
@@ -1,6 +1,6 @@
;;; Describe objects
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -200,17 +200,7 @@
(define-method (display-object (obj <procedure>))
(cond
- ((closure? obj)
- ;; Construct output from the source.
- (display "(")
- (display (procedure-name obj))
- (let ((args (cadr (procedure-source obj))))
- (cond ((null? args) (display ")"))
- ((pair? args)
- (let ((str (with-output-to-string (lambda () (display args)))))
- (format #t " ~a" (string-upcase! (substring str 1)))))
- (else
- (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ ;; FIXME: VM programs, ...
(else
;; Primitive procedure. Let's lookup the dictionary.
(and-let* ((entry (lookup-procedure obj)))
@@ -240,10 +230,8 @@
(define-method (display-type (obj <procedure>))
(cond
((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
- ((closure? obj) (display-class <procedure> "a procedure"))
((procedure-with-setter? obj)
(display-class <procedure-with-setter> "a procedure with setter"))
- ((not (struct? obj)) (display "a primitive procedure"))
(else (display-class <procedure> "a procedure")))
(display ".\n"))
@@ -252,9 +240,8 @@
(display-file (entry-file entry))))
(define-method (display-documentation (obj <procedure>))
- (cond ((cond ((closure? obj) (procedure-documentation obj))
- ((lookup-procedure obj) => entry-text)
- (else #f))
+ (cond ((or (procedure-documentation obj)
+ (and=> (lookup-procedure obj) entry-text))
=> format-documentation)
(else (next-method))))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 628a0ed..5aa5962 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -24,21 +24,19 @@
#:use-module (system vm instruction)
#:use-module (system vm objcode)
#:use-module ((srfi srfi-1) #:select (fold))
- #:export (vm-frame?
- vm-frame-program
- vm-frame-local-ref vm-frame-local-set!
- vm-frame-instruction-pointer
- vm-frame-return-address vm-frame-mv-return-address
- vm-frame-dynamic-link
- vm-frame-num-locals
+ #:export (frame-local-ref frame-local-set!
+ frame-instruction-pointer
+ frame-return-address frame-mv-return-address
+ frame-dynamic-link
+ frame-num-locals
- vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set!
- vm-frame-arguments
+ frame-bindings frame-binding-ref frame-binding-set!
+ ; frame-arguments
- vm-frame-number vm-frame-address
+ frame-number frame-address
make-frame-chain
print-frame print-frame-chain-as-backtrace
- frame-arguments frame-local-variables
+ frame-local-variables
frame-environment
frame-variable-exists? frame-variable-ref frame-variable-set!
frame-object-name
@@ -48,22 +46,22 @@
(load-extension "libguile" "scm_init_frames")
-(define (vm-frame-bindings frame)
+(define (frame-bindings frame)
(map (lambda (b)
(cons (binding:name b) (binding:index b)))
- (program-bindings-for-ip (vm-frame-program frame)
- (vm-frame-instruction-pointer frame))))
+ (program-bindings-for-ip (frame-procedure frame)
+ (frame-instruction-pointer frame))))
-(define (vm-frame-binding-set! frame var val)
- (let ((i (assq-ref (vm-frame-bindings frame) var)))
+(define (frame-binding-set! frame var val)
+ (let ((i (assq-ref (frame-bindings frame) var)))
(if i
- (vm-frame-local-set! frame i val)
+ (frame-local-set! frame i val)
(error "variable not bound in frame" var frame))))
-(define (vm-frame-binding-ref frame var)
- (let ((i (assq-ref (vm-frame-bindings frame) var)))
+(define (frame-binding-ref frame var)
+ (let ((i (assq-ref (frame-bindings frame) var)))
(if i
- (vm-frame-local-ref frame i)
+ (frame-local-ref frame i)
(error "variable not bound in frame" var frame))))
;; Basically there are two cases to deal with here:
@@ -80,37 +78,37 @@
;; number of arguments, or perhaps we're doing a typed dispatch and
;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack.
-(define (vm-frame-arguments frame)
+(define (frame-arguments frame)
(cond
- ((program-lambda-list (vm-frame-program frame)
- (vm-frame-instruction-pointer frame))
+ ((program-lambda-list (frame-procedure frame)
+ (frame-instruction-pointer frame))
;; case 1
=> (lambda (formals)
(let lp ((formals formals))
(pmatch formals
(() '())
((,x . ,rest) (guard (symbol? x))
- (cons (vm-frame-binding-ref frame x) (lp rest)))
+ (cons (frame-binding-ref frame x) (lp rest)))
((,x . ,rest)
;; could be a keyword
(cons x (lp rest)))
(,rest (guard (symbol? rest))
- (vm-frame-binding-ref frame rest))
+ (frame-binding-ref frame rest))
;; let's not error here, as we are called during
;; backtraces...
(else '???)))))
(else
;; case 2
(map (lambda (i)
- (vm-frame-local-ref frame i))
- (iota (vm-frame-num-locals frame))))))
+ (frame-local-ref frame i))
+ (iota (frame-num-locals frame))))))
;;;
;;; Frame chain
;;;
-(define vm-frame-number (make-object-property))
-(define vm-frame-address (make-object-property))
+(define frame-number (make-object-property))
+(define frame-address (make-object-property))
;; FIXME: the header.
(define (bootstrap-frame? frame)
@@ -201,17 +199,9 @@
prog (module-obarray (current-module))))))
-;;;
;;; Frames
;;;
-(define (frame-arguments frame)
- (let* ((prog (frame-program frame))
- (arity (program-arity prog)))
- (do ((n (+ (arity:nargs arity) -1) (1- n))
- (l '() (cons (frame-local-ref frame n) l)))
- ((< n 0) l))))
-
(define (frame-local-variables frame)
(let* ((prog (frame-program frame))
(arity (program-arity prog)))
@@ -219,26 +209,6 @@
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
-(define (frame-binding-ref frame binding)
- (let ((x (frame-local-ref frame (binding:index binding))))
- (if (and (binding:boxed? binding) (variable? x))
- (variable-ref x)
- x)))
-
-(define (frame-binding-set! frame binding val)
- (if (binding:boxed? binding)
- (let ((v (frame-local-ref frame binding)))
- (if (variable? v)
- (variable-set! v val)
- (frame-local-set! frame binding (make-variable val))))
- (frame-local-set! frame binding val)))
-
-;; FIXME handle #f program-bindings return
-(define (frame-bindings frame addr)
- (filter (lambda (b) (and (>= addr (binding:start b))
- (<= addr (binding:end b))))
- (program-bindings (frame-program frame))))
-
(define (frame-lookup-binding frame addr sym)
(assq sym (reverse (frame-bindings frame addr))))
diff --git a/test-suite/tests/continuations.test
b/test-suite/tests/continuations.test
index d96274e..f6db40e 100644
--- a/test-suite/tests/continuations.test
+++ b/test-suite/tests/continuations.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 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
@@ -87,9 +87,6 @@
(pass-if "get a continuation's stack ID"
(let ((id (call-with-current-continuation stack-id)))
- (or (boolean? id) (symbol? id))))
-
- (pass-if "get a continuation's innermost frame"
- (pair? (call-with-current-continuation last-stack-frame))))
+ (or (boolean? id) (symbol? id)))))
)
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 0391831..0c75d71 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1056,7 +1056,7 @@
(with-test-prefix "gcd"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? gcd))
(with-test-prefix "(n)"
@@ -1241,7 +1241,7 @@
(with-test-prefix "lcm"
;; FIXME: more tests?
;; (some of these are already in r4rs.test)
- (expect-fail (documented? lcm))
+ (pass-if (documented? lcm))
(pass-if (= (lcm) 1))
(pass-if (= (lcm 32 -36) 288))
(let ((big-n
115792089237316195423570985008687907853269984665640564039457584007913129639936)
; 2 ^ 256
@@ -1589,7 +1589,7 @@
;;;
(with-test-prefix "="
- (expect-fail (documented? =))
+ (pass-if (documented? =))
(pass-if (= 0 0))
(pass-if (= 7 7))
(pass-if (= -7 -7))
@@ -1673,7 +1673,7 @@
(with-test-prefix "<"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? <))
(with-test-prefix "(< 0 n)"
@@ -2339,7 +2339,7 @@
(big*4 (* fixnum-max 4))
(big*5 (* fixnum-max 5)))
- (expect-fail (documented? min))
+ (pass-if (documented? min))
(pass-if (= 1 (min 7 3 1 5)))
(pass-if (= 1 (min 1 7 3 5)))
(pass-if (= 1 (min 7 3 5 1)))
@@ -2435,7 +2435,7 @@
(with-test-prefix "+"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? +))
(with-test-prefix "wrong type argument"
@@ -2524,7 +2524,7 @@
(with-test-prefix "/"
- (expect-fail "documented?"
+ (pass-if "documented?"
(documented? /))
(with-test-prefix "division by zero"
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 948a778..e3a65ae 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -1,6 +1,6 @@
;;;; ramap.test --- test array mapping functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 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
@@ -65,7 +65,7 @@
(array-map! (make-array #f 5) number->string))
(pass-if-exception "dsubr" exception:wrong-num-args
- (array-map! (make-array #f 5) $sqrt))
+ (array-map! (make-array #f 5) sqrt))
(pass-if "rpsubr"
(let ((a (make-array 'foo 5)))
@@ -113,7 +113,7 @@
(pass-if "dsubr"
(let ((a (make-array #f 5)))
- (array-map! a $sqrt (make-array 16.0 5))
+ (array-map! a sqrt (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
(pass-if "rpsubr"
@@ -148,7 +148,7 @@
(make-array #f 5) (make-array #f 5))
(equal? a (make-array 'foo 5))))
- (pass-if-exception "subr_1" exception:wrong-type-arg
+ (pass-if-exception "subr_1" exception:wrong-num-args
(array-map! (make-array #f 5) length
(make-array #f 5) (make-array #f 5)))
@@ -164,9 +164,9 @@
(make-array 32 5) (make-array 16 5))
(equal? a (make-array "20" 5))))
- (pass-if "dsubr"
+ (pass-if-exception "dsubr" exception:wrong-num-args
(let ((a (make-array #f 5)))
- (array-map! a $sqrt
+ (array-map! a sqrt
(make-array 16.0 5) (make-array 16.0 5))
(equal? a (make-array 4.0 5))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9-5-129-g7230aaf,
Andy Wingo <=