-/* Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
#include "_scm.h"
#include "genio.h"
#include "unif.h"
+#include "feature.h"
+#include "smob.h"
#include "numbers.h"
\f
#define IS_INF(x) ((x) == (x) / 2)
#endif
+/* Return true if X is not infinite and is not a NaN
+ */
+#ifndef isfinite
+#define isfinite(x) (!IS_INF (x) && (x) == (x))
+#endif
+
/* MAXEXP is the maximum double precision expontent
* FLTMAX is less than or scm_equal the largest single precision float
*/
return (4 & (int) n) ? SCM_BOOL_F : SCM_BOOL_T;
}
-SCM_PROC (s_abs, "abs", 1, 0, 0, scm_abs);
+SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
SCM
scm_abs (x)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_abs);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x), g_abs, x, SCM_ARG1, s_abs);
if (SCM_TYP16 (x) == scm_tc16_bigpos)
return x;
return scm_copybig (x, 0);
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_abs);
+ SCM_GASSERT1 (SCM_INUMP (x), g_abs, x, SCM_ARG1, s_abs);
#endif
if (SCM_INUM (x) >= 0)
return x;
return SCM_MAKINUM (x);
}
-SCM_PROC (s_quotient, "quotient", 2, 0, 0, scm_quotient);
+SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
SCM
scm_quotient (x, y)
if (SCM_NINUMP (x))
{
long w;
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_quotient);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_quotient, x, y, SCM_ARG1, s_quotient);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_quotient);
+ SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
}
-#endif
return SCM_INUM0;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_quotient);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_quotient);
+ SCM_GASSERT2 (SCM_INUMP (x), g_quotient, x, y, SCM_ARG1, s_quotient);
+ SCM_GASSERT2 (SCM_INUMP (y), g_quotient, x, y, SCM_ARG2, s_quotient);
#endif
if ((z = SCM_INUM (y)) == 0)
{
return SCM_MAKINUM (z);
}
-SCM_PROC (s_remainder, "remainder", 2, 0, 0, scm_remainder);
+SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
SCM
scm_remainder (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_remainder);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_remainder, x, y, SCM_ARG1, s_remainder);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_remainder);
+ SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
}
-#endif
return x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_remainder);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_remainder);
+ SCM_GASSERT2 (SCM_INUMP (x), g_remainder, x, y, SCM_ARG1, s_remainder);
+ SCM_GASSERT2 (SCM_INUMP (y), g_remainder, x, y, SCM_ARG2, s_remainder);
#endif
if (!(z = SCM_INUM (y)))
{
return SCM_MAKINUM (z);
}
-SCM_PROC (s_modulo, "modulo", 2, 0, 0, scm_modulo);
+SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
SCM
scm_modulo (x, y)
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_modulo);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_modulo, x, y, SCM_ARG1, s_modulo);
if (SCM_NINUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_modulo);
+ SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
}
-#endif
return (SCM_BIGSIGN (y) ? (x > 0) : (x < 0)) ? scm_sum (x, y) : x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_modulo);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_modulo);
+ SCM_GASSERT1 (SCM_INUMP (x), g_modulo, x, y, SCM_ARG1, s_modulo);
+ SCM_GASSERT2 (SCM_INUMP (y), g_modulo, x, y, SCM_ARG2, s_modulo);
#endif
if (!(yy = SCM_INUM (y)))
{
return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z);
}
-SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd);
+SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
SCM
scm_gcd (x, y)
if (SCM_NINUMP (x))
{
big_gcd:
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_gcd);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_gcd, x, y, SCM_ARG1, s_gcd);
if (SCM_BIGSIGN (x))
x = scm_copybig (x, 0);
newy:
if (SCM_NINUMP (y))
{
- SCM_ASSERT (SCM_NIMP (y) && SCM_BIGP (y), y, SCM_ARG2, s_gcd);
+ SCM_GASSERT2 (SCM_NIMP (y) && SCM_BIGP (y),
+ g_gcd, x, y, SCM_ARGn, s_gcd);
if (SCM_BIGSIGN (y))
y = scm_copybig (y, 0);
switch (scm_bigcomp (x, y))
goto big_gcd;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_gcd);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_gcd);
+ SCM_GASSERT2 (SCM_INUMP (x), g_gcd, x, y, SCM_ARG1, s_gcd);
+ SCM_GASSERT2 (SCM_INUMP (y), g_gcd, x, y, SCM_ARGn, s_gcd);
#endif
u = SCM_INUM (x);
if (u < 0)
return SCM_MAKINUM (u);
}
-SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm);
+SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
SCM
scm_lcm (n1, n2)
SCM n2;
{
SCM d;
+#ifndef SCM_BIGDIG
+ SCM_GASSERT2 (SCM_INUMP (n1) || SCM_UNBNDP (n1),
+ g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ SCM_GASSERT2 (SCM_INUMP (n2) || SCM_UNBNDP (n2),
+ g_lcm, n1, n2, SCM_ARGn, s_lcm);
+#else
+ SCM_GASSERT2 (SCM_INUMP (n1)
+ || SCM_UNBNDP (n1)
+ || (SCM_NIMP (n1) && SCM_BIGP (n1)),
+ g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ SCM_GASSERT2 (SCM_INUMP (n2)
+ || SCM_UNBNDP (n2)
+ || (SCM_NIMP (n2) && SCM_BIGP (n2)),
+ g_lcm, n1, n2, SCM_ARGn, s_lcm);
+#endif
if (SCM_UNBNDP (n2))
{
n2 = SCM_MAKINUM (1L);
if (SCM_UNBNDP (n1))
return n2;
}
+
d = scm_gcd (n1, n2);
if (SCM_INUM0 == d)
return d;
return SCM_MAKINUM ((SCM_INUM (n) >> start) & ((1L << (end - start)) - 1));
}
-char scm_logtab[] = { 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4 };
+static const char scm_logtab[] = {
+ 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
+};
SCM_PROC (s_logcount, "logcount", 1, 0, 0, scm_logcount);
SCM
return SCM_MAKINUM (c);
}
-char scm_ilentab[] = { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4 };
+static const char scm_ilentab[] = {
+ 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
+};
SCM_PROC (s_integer_length, "integer-length", 1, 0, 0, scm_integer_length);
SCM
#ifdef SCM_BIGDIG
-char scm_s_bignum[] = "bignum";
+static const char s_bignum[] = "bignum";
SCM
scm_mkbig (nlen, sign)
SCM v = nlen;
/* Cast to SCM to avoid signed/unsigned comparison warnings. */
if (((v << 16) >> 16) != (SCM) nlen)
- scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, scm_s_bignum);
+ scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
SCM_NEWCELL (v);
SCM_DEFER_INTS;
SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)),
- scm_s_bignum));
+ s_bignum));
SCM_SETNUMDIGS (v, nlen, sign ? scm_tc16_bigneg : scm_tc16_bigpos);
SCM_ALLOW_INTS;
return v;
}
-char s_adjbig[] = "scm_adjbig";
+static const char s_adjbig[] = "scm_adjbig";
SCM
scm_adjbig (b, nlen)
/*** NUMBERS -> STRINGS ***/
#ifdef SCM_FLOATS
int scm_dblprec;
-static double fx[] =
+static const double fx[] =
{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
if (SCM_UNBNDP (radix))
radix = SCM_MAKINUM (10L);
else
- SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_number_to_string);
+ {
+ SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_number_to_string);
+ SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE,
+ s_number_to_string);
+ }
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
{ /* polar input for complex number */
/* get a `real' for scm_angle */
second = scm_istr2flo (&str[i], (long) (len - i), radix);
- if (!(SCM_INEXP (second)))
+ if (!(SCM_NIMP (second) && SCM_INEXP (second)))
return SCM_BOOL_F; /* not `real' */
if (SCM_CPLXP (second))
return SCM_BOOL_F; /* not `real' */
return scm_makdbl (res, lead_sgn);
/* get a `ureal' for complex part */
second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix);
- if (!(SCM_INEXP (second)))
+ if (! (SCM_NIMP (second) && SCM_INEXP (second)))
return SCM_BOOL_F; /* not `ureal' */
if (SCM_CPLXP (second))
return SCM_BOOL_F; /* not `ureal' */
if (SCM_UNBNDP (radix))
radix = SCM_MAKINUM (10L);
else
- SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_string_to_number);
+ {
+ SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_string_to_number);
+ SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE,
+ s_number_to_string);
+ }
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
str, SCM_ARG1, s_string_to_number);
answer = scm_istring2number (SCM_ROCHARS (str),
SCM z;
if ((y == 0.0) && (x == 0.0))
return scm_flo0;
- SCM_NEWCELL (z);
SCM_DEFER_INTS;
if (y == 0.0)
{
if ((-FLTMAX < x) && (x < FLTMAX) && (fx == x))
#endif
{
- SCM_SETCAR (z, scm_tc_flo);
+ SCM_NEWSMOB(z,scm_tc_flo,NULL);
SCM_FLO (z) = x;
SCM_ALLOW_INTS;
return z;
}
#endif /* def SCM_SINGLES */
- SCM_SETCDR (z, (SCM) scm_must_malloc (1L * sizeof (double), "real"));
- SCM_SETCAR (z, scm_tc_dblr);
+ SCM_NEWSMOB(z,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
}
else
{
- SCM_SETCDR (z, (SCM) scm_must_malloc (2L * sizeof (double), "complex"));
- SCM_SETCAR (z, scm_tc_dblc);
+ SCM_NEWSMOB(z,scm_tc_dblc,scm_must_malloc (2L * sizeof (double), "comkplex"));
SCM_IMAG (z) = y;
}
SCM_REAL (z) = x;
-SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p);
+SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
SCM
scm_num_eq_p (x, y)
if (SCM_NINUMP (x))
{
#ifdef SCM_BIGDIG
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
}
-#endif
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
}
SCM_ASRTGO (SCM_INEXP (x), badx);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_INEXP (x), x, SCM_ARG1, s_eq_p);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_INEXP (x),
+ g_eq_p, x, y, SCM_ARG1, s_eq_p);
#endif
if (SCM_INUMP (y))
{
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
return SCM_BOOL_F;
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
}
-#endif
#endif
realint:
return ((SCM_REALP (y) && (((double) SCM_INUM (x)) == SCM_REALPART (y)))
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_eq_p);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_eq_p, x, y, SCM_ARG1, s_eq_p);
if (SCM_INUMP (y))
return SCM_BOOL_F;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_eq_p);
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
}
-#endif
return SCM_BOOL_F;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_eq_p);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_eq_p);
+ SCM_GASSERT2 (SCM_INUMP (x), g_eq_p, x, y, SCM_ARG1, s_eq_p);
+ SCM_GASSERT2 (SCM_INUMP (y), g_eq_p, x, y, SCM_ARGn, s_eq_p);
#endif
#endif
return ((long) x == (long) y) ? SCM_BOOL_T : SCM_BOOL_F;
-SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p);
+SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
SCM
scm_less_p (x, y)
if (SCM_NINUMP (x))
{
#ifdef SCM_BIGDIG
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
}
-#endif
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
}
SCM_ASRTGO (SCM_REALP (x), badx);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_less_p);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
+ g_less_p, x, y, SCM_ARG1, s_less_p);
#endif
if (SCM_INUMP (y))
return ((SCM_REALPART (x) < ((double) SCM_INUM (y)))
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
return SCM_BIGSIGN (y) ? SCM_BOOL_F : SCM_BOOL_T;
-#ifndef SCM_RECKLESS
if (!(SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
}
-#endif
#endif
return ((((double) SCM_INUM (x)) < SCM_REALPART (y))
? SCM_BOOL_T
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_less_p);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_less_p, x, y, SCM_ARG1, s_less_p);
if (SCM_INUMP (y))
return SCM_BIGSIGN (x) ? SCM_BOOL_T : SCM_BOOL_F;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_less_p);
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
}
-#endif
return SCM_BIGSIGN (y) ? SCM_BOOL_F : SCM_BOOL_T;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_less_p);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_less_p);
+ SCM_GASSERT2 (SCM_INUMP (x), g_less_p, x, y, SCM_ARG1, s_less_p);
+ SCM_GASSERT2 (SCM_INUMP (y), g_less_p, x, y, SCM_ARGn, s_less_p);
#endif
#endif
return ((long) x < (long) y) ? SCM_BOOL_T : SCM_BOOL_F;
-SCM_PROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p);
+SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
SCM
scm_zero_p (z)
SCM_ASRTGO (SCM_NIMP (z), badz);
if (SCM_BIGP (z))
return SCM_BOOL_F;
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_zero_p);
+ SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_zero_p);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
+ g_zero_p, z, SCM_ARG1, s_zero_p);
#endif
return (z == scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F;
}
#ifdef SCM_BIGDIG
if (SCM_NINUMP (z))
{
- SCM_ASSERT (SCM_NIMP (z) && SCM_BIGP (z), z, SCM_ARG1, s_zero_p);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_BIGP (z),
+ g_zero_p, z, SCM_ARG1, s_zero_p);
return SCM_BOOL_F;
}
#else
- SCM_ASSERT (SCM_INUMP (z), z, SCM_ARG1, s_zero_p);
+ SCM_GASSERT1 (SCM_INUMP (z), g_zero_p, z, SCM_ARG1, s_zero_p);
#endif
#endif
return (z == SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
-SCM_PROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p);
+SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
SCM
scm_positive_p (x)
SCM_ASRTGO (SCM_NIMP (x), badx);
if (SCM_BIGP (x))
return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
-#ifndef SCM_RECKLESS
if (!(SCM_REALP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_positive_p);
+ SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_positive_p);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
+ g_positive_p, x, SCM_ARG1, s_positive_p);
#endif
return (SCM_REALPART (x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
}
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_positive_p);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_positive_p, x, SCM_ARG1, s_positive_p);
return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_positive_p);
+ SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
#endif
#endif
return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
-SCM_PROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p);
+SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
SCM
scm_negative_p (x)
SCM_ASRTGO (SCM_NIMP (x), badx);
if (SCM_BIGP (x))
return SCM_TYP16 (x) == scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T;
-#ifndef SCM_RECKLESS
if (!(SCM_REALP (x)))
{
badx:
- scm_wta (x, (char *) SCM_ARG1, s_negative_p);
+ SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_negative_p);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
+ g_negative_p, x, SCM_ARG1, s_negative_p);
#endif
return (SCM_REALPART (x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
}
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_negative_p);
+ SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_negative_p, x, SCM_ARG1, s_negative_p);
return (SCM_TYP16 (x) == scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_negative_p);
+ SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
#endif
#endif
return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
}
-SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
+SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
SCM
scm_max (x, y)
#endif
if (SCM_UNBNDP (y))
{
-#ifndef SCM_RECKLESS
- if (!(SCM_NUMBERP (x)))
- {
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_max);
- }
-#endif
+ SCM_GASSERT0 (!SCM_UNBNDP (x),
+ g_max, scm_makfrom0str (s_max), SCM_WNA, 0);
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_max, x, SCM_ARG1, s_max);
return x;
}
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
#ifdef SCM_BIGDIG
- SCM_ASRTGO (SCM_NIMP (x), badx);
+ if (!SCM_NIMP (x))
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+ }
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
z = scm_big2dbl (x);
return (z < SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
}
- SCM_ASRTGO (SCM_REALP (x), badx);
+ SCM_ASRTGO (SCM_REALP (x), badx2);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
+ g_max, x, y, SCM_ARG1, s_max);
#endif
if (SCM_INUMP (y))
return ((SCM_REALPART (x) < (z = SCM_INUM (y)))
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
return SCM_BIGSIGN (y) ? x : y;
-#ifndef SCM_RECKLESS
if (!(SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
-#endif
#endif
return (((z = SCM_INUM (x)) < SCM_REALPART (y))
? y
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_max, x, y, SCM_ARG1, s_max);
if (SCM_INUMP (y))
return SCM_BIGSIGN (x) ? y : x;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_max);
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
}
-#endif
return SCM_BIGSIGN (y) ? x : y;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_max);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_max);
+ SCM_GASSERT2 (SCM_INUMP (x), g_max, x, y, SCM_ARG1, s_max);
+ SCM_GASSERT2 (SCM_INUMP (y), g_max, x, y, SCM_ARGn, s_max);
#endif
#endif
return ((long) x < (long) y) ? y : x;
-SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
+SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
SCM
scm_min (x, y)
#endif
if (SCM_UNBNDP (y))
{
-#ifndef SCM_RECKLESS
- if (!(SCM_NUMBERP (x)))
- {
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_min);
- }
-#endif
+ SCM_GASSERT0 (!SCM_UNBNDP (x),
+ g_min, scm_makfrom0str (s_min), SCM_WNA, 0);
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_min, x, SCM_ARG1, s_min);
return x;
}
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
#ifdef SCM_BIGDIG
- SCM_ASRTGO (SCM_NIMP (x), badx);
+ if (!(SCM_NIMP (x)))
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
+ }
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
z = scm_big2dbl (x);
return (z > SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
}
- SCM_ASRTGO (SCM_REALP (x), badx);
+ SCM_ASRTGO (SCM_REALP (x), badx2);
#else
- SCM_ASSERT (SCM_NIMP (x) && SCM_REALP (x), x, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
+ g_min, x, y, SCM_ARG1, s_min);
#endif
if (SCM_INUMP (y))
return ((SCM_REALPART (x) > (z = SCM_INUM (y)))
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
return SCM_BIGSIGN (y) ? y : x;
-#ifndef SCM_RECKLESS
if (!(SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_REALP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
-#endif
#endif
return (((z = SCM_INUM (x)) > SCM_REALPART (y))
? y
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_min, x, y, SCM_ARG1, s_min);
if (SCM_INUMP (y))
return SCM_BIGSIGN (x) ? x : y;
SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_min);
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
}
-#endif
return SCM_BIGSIGN (y) ? y : x;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_min);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_min);
+ SCM_GASSERT2 (SCM_INUMP (x), g_min, x, y, SCM_ARG1, s_min);
+ SCM_GASSERT2 (SCM_INUMP (y), g_min, x, y, SCM_ARGn, s_min);
#endif
#endif
return ((long) x > (long) y) ? y : x;
-SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
+SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
SCM
scm_sum (x, y)
{
if (SCM_UNBNDP (x))
return SCM_INUM0;
-#ifndef SCM_RECKLESS
- if (!(SCM_NUMBERP (x)))
- {
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_sum);
- }
-#endif
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_sum, x, SCM_ARG1, s_sum);
return x;
}
#ifdef SCM_FLOATS
{
SCM t;
#ifdef SCM_BIGDIG
- SCM_ASRTGO (SCM_NIMP (x), badx);
+ if (!SCM_NIMP (x))
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+ }
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
}
- SCM_ASRTGO (SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_INEXP (x), badx2);
#else
- SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
#endif
if (SCM_INUMP (y))
{
y = t;
goto bigreal;
}
-#ifndef SCM_RECKLESS
else if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
-#endif
#endif
{
double i = 0.0;
if (SCM_NINUMP (x))
{
SCM t;
- SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx);
+ SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
if (SCM_INUMP (y))
{
t = x;
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_sum);
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
-#endif
intbig:
{
#ifndef SCM_DIGSTOOBIG
}
}
#else
- SCM_ASRTGO (SCM_INUMP (x), badx);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_sum);
+ SCM_ASRTGO (SCM_INUMP (x), badx2);
+ SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
#endif
#endif
x = SCM_INUM (x) + SCM_INUM (y);
-SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
+SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
SCM
scm_difference (x, y)
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (x)))
{
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_difference);
+ if (SCM_UNBNDP (y))
+ {
+ SCM_GASSERT0 (!SCM_UNBNDP (x), g_difference,
+ scm_makfrom0str (s_difference), SCM_WNA, 0);
+ badx:
+ SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ }
+ else
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+ }
}
-#endif
if (SCM_UNBNDP (y))
{
#ifdef SCM_BIGDIG
return scm_makdbl (scm_big2dbl (x) - SCM_REALPART (y),
SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
}
- SCM_ASRTGO (SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_INEXP (x), badx2);
if (SCM_BIGP (y))
return scm_makdbl (SCM_REALPART (x) - scm_big2dbl (y),
SCM_CPLXP (x) ? SCM_IMAG (x) : 0.0);
SCM_ASRTGO (SCM_INEXP (y), bady);
#else
- SCM_ASRTGO (SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_INEXP (x), badx2);
SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
#endif
if (SCM_CPLXP (x))
y, 0x0100);
#endif
}
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
-#endif
#endif
return scm_makdbl (SCM_INUM (x) - SCM_REALPART (y),
SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_difference);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y))
{
x = scm_copybig (x, !SCM_BIGSIGN (x));
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_difference);
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
-#endif
{
#ifndef SCM_DIGSTOOBIG
long z = scm_pseudolong (SCM_INUM (x));
}
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_difference);
+ SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y))
{
x = -SCM_INUM (x);
goto checkx;
}
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_difference);
+ SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
#endif
#endif
x = SCM_INUM (x) - SCM_INUM (y);
-SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
+SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
SCM
scm_product (x, y)
{
if (SCM_UNBNDP (x))
return SCM_MAKINUM (1L);
-#ifndef SCM_RECKLESS
- if (!(SCM_NUMBERP (x)))
- {
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_product);
- }
-#endif
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_product, x, SCM_ARG1, s_product);
return x;
}
#ifdef SCM_FLOATS
{
SCM t;
#ifdef SCM_BIGDIG
- SCM_ASRTGO (SCM_NIMP (x), badx);
+ if (!SCM_NIMP (x))
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+ }
if (SCM_BIGP (x))
{
if (SCM_INUMP (y))
SCM_CPLXP (y) ? bg * SCM_IMAG (y) : 0.0);
}
}
- SCM_ASRTGO (SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_INEXP (x), badx2);
#else
- SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
#endif
if (SCM_INUMP (y))
{
y = t;
goto bigreal;
}
-#ifndef SCM_RECKLESS
else if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
-#endif
#endif
if (SCM_CPLXP (x))
{
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx);
+ SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
if (SCM_INUMP (y))
{
SCM t = x;
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_product);
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
}
-#endif
intbig:
if (SCM_INUM0 == x)
return x;
}
}
#else
- SCM_ASRTGO (SCM_INUMP (x), badx);
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_product);
+ SCM_ASRTGO (SCM_INUMP (x), badx2);
+ SCM_GASSERT (SCM_INUMP (y), g_product, x, y, SCM_ARGn, s_product);
#endif
#endif
{
}
-SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
+SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
SCM
scm_divide (x, y)
double d, r, i, a;
if (SCM_NINUMP (x))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (x)))
{
- badx:
- scm_wta (x, (char *) SCM_ARG1, s_divide);
+ if (SCM_UNBNDP (y))
+ {
+ SCM_GASSERT0 (!SCM_UNBNDP (x),
+ g_divide, scm_makfrom0str (s_divide), SCM_WNA, 0);
+ badx:
+ SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ }
+ else
+ {
+ badx2:
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+ }
}
-#endif
if (SCM_UNBNDP (y))
{
#ifdef SCM_BIGDIG
goto complex_div;
}
#endif
- SCM_ASRTGO (SCM_INEXP (x), badx);
+ SCM_ASRTGO (SCM_INEXP (x), badx2);
if (SCM_INUMP (y))
{
d = SCM_INUM (y);
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
return scm_makdbl (SCM_INUM (x) / scm_big2dbl (y), 0.0);
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
-#endif
#else
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_INEXP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
-#endif
#endif
if (SCM_REALP (y))
return scm_makdbl (SCM_INUM (x) / SCM_REALPART (y), 0.0);
if (SCM_NINUMP (x))
{
SCM z;
- SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_divide);
+ SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
+ g_divide, x, y, SCM_ARG1, s_divide);
if (SCM_UNBNDP (y))
goto ov;
if (SCM_INUMP (y))
}
if (SCM_NINUMP (y))
{
-#ifndef SCM_RECKLESS
if (!(SCM_NIMP (y) && SCM_BIGP (y)))
{
bady:
- scm_wta (y, (char *) SCM_ARG2, s_divide);
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
-#endif
goto ov;
}
#else
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_divide);
+ SCM_GASSERT2 (SCM_INUMP (x), g_divide, x, y, SCM_ARG1, s_divide);
if (SCM_UNBNDP (y))
{
if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
return x;
goto ov;
}
- SCM_ASSERT (SCM_INUMP (y), y, SCM_ARG2, s_divide);
+ SCM_GASSERT2 (SCM_INUMP (y), g_divide, x, y, SCM_ARGn, s_divide);
#endif
#endif
{
#ifdef SCM_FLOATS
-SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
+SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
double
scm_asinh (x)
-SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
+SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
double
scm_acosh (x)
-SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
+SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
double
scm_atanh (x)
-SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
+SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
double
scm_truncate (x)
-SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
+SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
double
scm_round (x)
-SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
+SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
double
scm_exact_to_inexact (z)
}
-SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor);
-SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil);
-SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt);
-SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs);
-SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp);
-SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log);
-SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin);
-SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos);
-SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan);
-SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin);
-SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos);
-SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan);
-SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh);
-SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh);
-SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh);
+SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
+SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
+SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
+SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
+SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
+SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
+SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
+SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
+SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
+SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
+SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
+SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
+SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
+SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
+SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
struct dpair
{
-SCM_PROC (s_real_part, "real-part", 1, 0, 0, scm_real_part);
+SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
SCM
scm_real_part (z)
SCM_ASRTGO (SCM_NIMP (z), badz);
if (SCM_BIGP (z))
return z;
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_real_part);
+ SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_real_part);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
+ g_real_part, z, SCM_ARG1, s_real_part);
#endif
if (SCM_CPLXP (z))
return scm_makdbl (SCM_REAL (z), 0.0);
-SCM_PROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part);
+SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
SCM
scm_imag_part (z)
SCM_ASRTGO (SCM_NIMP (z), badz);
if (SCM_BIGP (z))
return SCM_INUM0;
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_imag_part);
+ SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_imag_part);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
+ g_imag_part, z, SCM_ARG1, s_imag_part);
#endif
if (SCM_CPLXP (z))
return scm_makdbl (SCM_IMAG (z), 0.0);
-SCM_PROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
+SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
SCM
scm_magnitude (z)
SCM_ASRTGO (SCM_NIMP (z), badz);
if (SCM_BIGP (z))
return scm_abs (z);
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_magnitude);
+ SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_magnitude);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
+ g_magnitude, z, SCM_ARG1, s_magnitude);
#endif
if (SCM_CPLXP (z))
{
-SCM_PROC (s_angle, "angle", 1, 0, 0, scm_angle);
+SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
SCM
scm_angle (z)
x = (SCM_TYP16 (z) == scm_tc16_bigpos) ? 1.0 : -1.0;
goto do_angle;
}
-#ifndef SCM_RECKLESS
if (!(SCM_INEXP (z)))
{
badz:
- scm_wta (z, (char *) SCM_ARG1, s_angle);
+ SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
}
-#endif
#else
- SCM_ASSERT (SCM_NIMP (z) && SCM_INEXP (z), z, SCM_ARG1, s_angle);
+ SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z), g_angle, z, SCM_ARG1, s_angle);
#endif
if (SCM_REALP (z))
{
if (SCM_INUM (ans) == (long) u)
return ans;
}
- SCM_ASRTGO (!IS_INF (u), badz); /* problem? */
+ SCM_ASRTGO (isfinite (u), badz); /* problem? */
return scm_dbl2big (u);
}
#else
#else /* ~SCM_FLOATS */
-SCM_PROC (s_trunc, "truncate", 1, 0, 0, scm_trunc);
+SCM_GPROC (s_trunc, "truncate", 1, 0, 0, scm_trunc, g_trunc);
SCM
scm_trunc (x)
SCM x;
{
- SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_truncate);
+ SCM_GASSERT2 (SCM_INUMP (x), g_trunc, x, y, SCM_ARG1, s_truncate);
return x;
}
void
scm_init_numbers ()
{
+ scm_add_feature("complex");
#ifdef SCM_FLOATS
- SCM_NEWCELL (scm_flo0);
+ scm_add_feature("inexact");
#ifdef SCM_SINGLES
- SCM_SETCAR (scm_flo0, scm_tc_flo);
- SCM_FLO (scm_flo0) = 0.0;
+ SCM_NEWSMOB(scm_flo0,scm_tc_flo,NULL);
#else
- SCM_SETCDR (scm_flo0, (SCM) scm_must_malloc (1L * sizeof (double), "real"));
+ SCM_NEWSMOB(scm_flo0,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
SCM_REAL (scm_flo0) = 0.0;
- SCM_SETCAR (scm_flo0, scm_tc_dblr);
#endif
#ifdef DBL_DIG
scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
HCoop / bpt / guile.git / blobdiff