[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-90-gbf5
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-90-gbf5a05f |
|
Date: |
Thu, 03 Dec 2009 15:02:02 +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=bf5a05f2a01fee23f5622d1429dc32f4850f98b5
The branch, master has been updated
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)
from aa3f69519f1af3fcf31cf36be33776db3fedf65a (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 ---------
libguile/array-map.c | 63 +----
libguile/deprecated.c | 53 ++++
libguile/deprecated.h | 8 +
libguile/eval.c | 40 +--
libguile/gc.c | 3 +-
libguile/goops.c | 11 +-
libguile/gsubr.c | 103 ++-----
libguile/macros.c | 2 +-
libguile/memoize.c | 2 +-
libguile/numbers.c | 682 +++++++++++++++++++++++++++++------------
libguile/numbers.h | 31 ++-
libguile/procprop.c | 19 --
libguile/procs.c | 3 -
libguile/procs.h | 35 +--
libguile/tags.h | 27 +-
libguile/values.c | 3 +-
libguile/vm.c | 79 +-----
module/ice-9/boot-9.scm | 83 -----
module/ice-9/deprecated.scm | 17 +
module/oop/goops.scm | 5 +-
test-suite/tests/numbers.test | 10 +-
test-suite/tests/ramap.test | 12 +-
23 files changed, 667 insertions(+), 769 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/libguile/array-map.c b/libguile/array-map.c
index eaac54a..7200998 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -698,27 +698,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));
@@ -742,26 +721,6 @@ ramap_rp (SCM ra0, SCM proc, SCM ras)
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);
@@ -835,27 +794,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
{
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);
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED;
case scm_tc7_rpsubr:
{
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 8b1fce8..9364a69 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>
@@ -1215,6 +1216,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)
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index f20e47c..3643a80 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -400,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.
diff --git a/libguile/eval.c b/libguile/eval.c
index d540595..b68c0ca 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -543,56 +543,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
@@ -941,7 +919,7 @@ scm_init_eval ()
scm_listofnull = scm_list_1 (SCM_EOL);
- f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
+ f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
scm_permanent_object (f_apply);
primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
diff --git a/libguile/gc.c b/libguile/gc.c
index 96e3c30..a0715f0 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -820,8 +820,7 @@ scm_init_gc ()
scm_after_gc_hook = scm_permanent_object (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/goops.c b/libguile/goops.c
index dcb1b7d..7ce5b31 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -226,22 +226,13 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
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:
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/macros.c b/libguile/macros.c
index 970a41d..d7c054e 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -312,7 +312,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..7dd5cd8 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -295,7 +295,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 */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 15c49c0..6583103 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -126,6 +126,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 +1026,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 +1140,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 +1255,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 +1345,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 +1433,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 +1443,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;
@@ -3717,9 +3797,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 +3943,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 +4082,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 +4296,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 +4556,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 +4790,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 +5204,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 +5372,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_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_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_wrong_type_arg (sstring, SCM_ARG2, y);
+ 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_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+}
+#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_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_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
{
- 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))
+ 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_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
+ (SCM z),
+ "Compute the arc sine of @var{z}.")
+#define FUNC_NAME s_scm_asin
+{
+ 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_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_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_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 +5676,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 +5708,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
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/procprop.c b/libguile/procprop.c
index cce800f..a92d31c 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -53,26 +53,11 @@ scm_i_procedure_arity (SCM proc)
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:
@@ -80,10 +65,6 @@ scm_i_procedure_arity (SCM proc)
break;
else
return SCM_BOOL_F;
- case scm_tc7_lsubr_2:
- a += 2;
- r = 1;
- break;
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
{
diff --git a/libguile/procs.c b/libguile/procs.c
index 898a371..6fda200 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -135,9 +135,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
{
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;
diff --git a/libguile/procs.h b/libguile/procs.h
index dc764ed..369d9e1 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,39 +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)))
+ (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
diff --git a/libguile/tags.h b/libguile/tags.h
index 92d0bb8..2a9fc4b 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -425,20 +425,20 @@ typedef scm_t_uintptr scm_t_bits;
#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_program 79
-#define scm_tc7_subr_0 85
-#define scm_tc7_subr_1 87
+#define scm_tc7_unused_9 85
+#define scm_tc7_unused_10 87
#define scm_tc7_cxr 93
-#define scm_tc7_subr_3 95
-#define scm_tc7_subr_2 101
+#define scm_tc7_unused_11 95
+#define scm_tc7_unused_12 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_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
@@ -676,17 +676,8 @@ enum scm_tc8_tags
*/
#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/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/vm.c b/libguile/vm.c
index 51426a5..fdfae00 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -265,27 +265,8 @@ 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:
@@ -296,62 +277,18 @@ apply_foreign (SCM proc, SCM *args, int nargs, int
headroom)
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);
- }
+ return scm_i_chase_pairs (args[0], (scm_t_bits) SCM_SUBRF (proc));
case scm_tc7_asubr:
if (nargs < 2)
- return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+ return SCM_SUBRF (proc) (args[0], SCM_UNDEFINED);
{
+ SCM x = args[0];
int idx = 1;
while (nargs-- > 1)
- arg1 = SCM_SUBRF (proc) (arg1, args[idx++]);
- return arg1;
+ x = SCM_SUBRF (proc) (x, args[idx++]);
+ return x;
}
case scm_tc7_rpsubr:
{
@@ -371,15 +308,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:
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..3176ebc 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -207,3 +207,20 @@
(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))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index bf13e38..0195036 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1467,11 +1467,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/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 0391831..e4cec16 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
@@ -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, master, updated. release_1-9-5-90-gbf5a05f,
Andy Wingo <=