1991-02-19 12:39:46 +00:00
|
|
|
/***********************************************************
|
1995-01-04 19:10:35 +00:00
|
|
|
Copyright 1991-1995 by Stichting Mathematisch Centrum, Amsterdam,
|
|
|
|
The Netherlands.
|
1991-02-19 12:39:46 +00:00
|
|
|
|
|
|
|
All Rights Reserved
|
|
|
|
|
|
|
|
Permission to use, copy, modify, and distribute this software and its
|
|
|
|
documentation for any purpose and without fee is hereby granted,
|
|
|
|
provided that the above copyright notice appear in all copies and that
|
|
|
|
both that copyright notice and this permission notice appear in
|
|
|
|
supporting documentation, and that the names of Stichting Mathematisch
|
|
|
|
Centrum or CWI not be used in advertising or publicity pertaining to
|
|
|
|
distribution of the software without specific, written prior permission.
|
|
|
|
|
|
|
|
STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
|
|
|
|
THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
|
|
|
FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
|
|
|
|
FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
|
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
|
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
|
|
|
|
OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
|
|
|
|
******************************************************************/
|
|
|
|
|
1990-10-14 12:07:46 +00:00
|
|
|
/* Math module -- standard C math library functions, pi and e */
|
|
|
|
|
1990-12-20 15:06:42 +00:00
|
|
|
#include "allobjects.h"
|
1990-10-14 12:07:46 +00:00
|
|
|
|
1990-12-20 23:09:14 +00:00
|
|
|
#include <errno.h>
|
|
|
|
|
1993-06-17 12:35:49 +00:00
|
|
|
#define getdoublearg(v, a) getargs(v, "d", a)
|
|
|
|
#define get2doublearg(v, a, b) getargs(v, "(dd)", a, b)
|
|
|
|
|
1990-12-20 15:06:42 +00:00
|
|
|
#include <math.h>
|
|
|
|
|
1992-01-14 18:37:27 +00:00
|
|
|
#ifndef __STDC__
|
1992-03-27 17:29:44 +00:00
|
|
|
extern double fmod PROTO((double, double));
|
1995-01-12 11:28:16 +00:00
|
|
|
extern double frexp PROTO((double, int *));
|
|
|
|
extern double ldexp PROTO((double, int));
|
|
|
|
extern double modf PROTO((double, double *));
|
1992-01-14 18:37:27 +00:00
|
|
|
#endif
|
1995-01-12 11:28:16 +00:00
|
|
|
|
|
|
|
#ifdef HAVE_HYPOT
|
|
|
|
extern double hypot PROTO((double, double));
|
|
|
|
#endif
|
|
|
|
|
|
|
|
#ifdef i860
|
|
|
|
/* Cray APP has bogus definition of HUGE_VAL in <math.h> */
|
|
|
|
#undef HUGE_VAL
|
1994-08-01 11:34:53 +00:00
|
|
|
#endif
|
1992-01-14 18:37:27 +00:00
|
|
|
|
1991-12-16 15:44:24 +00:00
|
|
|
#ifdef HUGE_VAL
|
|
|
|
#define CHECK(x) if (errno != 0) ; \
|
|
|
|
else if (-HUGE_VAL <= (x) && (x) <= HUGE_VAL) ; \
|
|
|
|
else errno = ERANGE
|
|
|
|
#else
|
|
|
|
#define CHECK(x) /* Don't know how to check */
|
|
|
|
#endif
|
|
|
|
|
|
|
|
static object *
|
|
|
|
math_error()
|
|
|
|
{
|
|
|
|
if (errno == EDOM)
|
|
|
|
err_setstr(ValueError, "math domain error");
|
|
|
|
else if (errno == ERANGE)
|
|
|
|
err_setstr(OverflowError, "math range error");
|
|
|
|
else
|
1992-02-26 15:26:56 +00:00
|
|
|
err_errno(ValueError); /* Unexpected math error */
|
1991-12-16 15:44:24 +00:00
|
|
|
return NULL;
|
|
|
|
}
|
|
|
|
|
1990-10-14 12:07:46 +00:00
|
|
|
static object *
|
|
|
|
math_1(args, func)
|
|
|
|
object *args;
|
|
|
|
double (*func) FPROTO((double));
|
|
|
|
{
|
|
|
|
double x;
|
|
|
|
if (!getdoublearg(args, &x))
|
|
|
|
return NULL;
|
|
|
|
errno = 0;
|
|
|
|
x = (*func)(x);
|
1991-12-16 15:44:24 +00:00
|
|
|
CHECK(x);
|
1990-10-14 12:07:46 +00:00
|
|
|
if (errno != 0)
|
1991-12-16 15:44:24 +00:00
|
|
|
return math_error();
|
1990-10-14 12:07:46 +00:00
|
|
|
else
|
|
|
|
return newfloatobject(x);
|
|
|
|
}
|
|
|
|
|
|
|
|
static object *
|
|
|
|
math_2(args, func)
|
|
|
|
object *args;
|
|
|
|
double (*func) FPROTO((double, double));
|
|
|
|
{
|
|
|
|
double x, y;
|
|
|
|
if (!get2doublearg(args, &x, &y))
|
|
|
|
return NULL;
|
|
|
|
errno = 0;
|
|
|
|
x = (*func)(x, y);
|
1991-12-16 15:44:24 +00:00
|
|
|
CHECK(x);
|
1990-10-14 12:07:46 +00:00
|
|
|
if (errno != 0)
|
1991-12-16 15:44:24 +00:00
|
|
|
return math_error();
|
1990-10-14 12:07:46 +00:00
|
|
|
else
|
|
|
|
return newfloatobject(x);
|
|
|
|
}
|
|
|
|
|
|
|
|
#define FUNC1(stubname, func) \
|
|
|
|
static object * stubname(self, args) object *self, *args; { \
|
|
|
|
return math_1(args, func); \
|
|
|
|
}
|
|
|
|
|
|
|
|
#define FUNC2(stubname, func) \
|
|
|
|
static object * stubname(self, args) object *self, *args; { \
|
|
|
|
return math_2(args, func); \
|
|
|
|
}
|
|
|
|
|
|
|
|
FUNC1(math_acos, acos)
|
|
|
|
FUNC1(math_asin, asin)
|
|
|
|
FUNC1(math_atan, atan)
|
|
|
|
FUNC2(math_atan2, atan2)
|
|
|
|
FUNC1(math_ceil, ceil)
|
|
|
|
FUNC1(math_cos, cos)
|
|
|
|
FUNC1(math_cosh, cosh)
|
|
|
|
FUNC1(math_exp, exp)
|
|
|
|
FUNC1(math_fabs, fabs)
|
|
|
|
FUNC1(math_floor, floor)
|
|
|
|
FUNC2(math_fmod, fmod)
|
1995-01-02 19:30:30 +00:00
|
|
|
#ifdef HAVE_HYPOT
|
1994-10-20 22:00:28 +00:00
|
|
|
FUNC2(math_hypot, hypot)
|
1995-01-02 19:30:30 +00:00
|
|
|
#endif
|
1990-10-14 12:07:46 +00:00
|
|
|
FUNC1(math_log, log)
|
|
|
|
FUNC1(math_log10, log10)
|
1991-07-27 21:38:43 +00:00
|
|
|
#ifdef MPW_3_1 /* This hack is needed for MPW 3.1 but not for 3.2 ... */
|
1991-06-24 22:23:10 +00:00
|
|
|
FUNC2(math_pow, power)
|
|
|
|
#else
|
1990-10-14 12:07:46 +00:00
|
|
|
FUNC2(math_pow, pow)
|
1991-06-24 22:23:10 +00:00
|
|
|
#endif
|
1990-10-14 12:07:46 +00:00
|
|
|
FUNC1(math_sin, sin)
|
|
|
|
FUNC1(math_sinh, sinh)
|
|
|
|
FUNC1(math_sqrt, sqrt)
|
|
|
|
FUNC1(math_tan, tan)
|
|
|
|
FUNC1(math_tanh, tanh)
|
|
|
|
|
1994-08-01 11:34:53 +00:00
|
|
|
|
1991-10-24 14:57:21 +00:00
|
|
|
static object *
|
|
|
|
math_frexp(self, args)
|
|
|
|
object *self;
|
|
|
|
object *args;
|
|
|
|
{
|
|
|
|
double x;
|
|
|
|
int i;
|
|
|
|
if (!getdoublearg(args, &x))
|
|
|
|
return NULL;
|
|
|
|
errno = 0;
|
|
|
|
x = frexp(x, &i);
|
1991-12-16 15:44:24 +00:00
|
|
|
CHECK(x);
|
1991-10-24 14:57:21 +00:00
|
|
|
if (errno != 0)
|
1991-12-16 15:44:24 +00:00
|
|
|
return math_error();
|
1993-03-16 12:15:04 +00:00
|
|
|
return mkvalue("(di)", x, i);
|
1991-10-24 14:57:21 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
static object *
|
|
|
|
math_ldexp(self, args)
|
|
|
|
object *self;
|
|
|
|
object *args;
|
|
|
|
{
|
|
|
|
double x, y;
|
|
|
|
/* Cheat -- allow float as second argument */
|
|
|
|
if (!get2doublearg(args, &x, &y))
|
|
|
|
return NULL;
|
|
|
|
errno = 0;
|
|
|
|
x = ldexp(x, (int)y);
|
1991-12-16 15:44:24 +00:00
|
|
|
CHECK(x);
|
1991-10-24 14:57:21 +00:00
|
|
|
if (errno != 0)
|
1991-12-16 15:44:24 +00:00
|
|
|
return math_error();
|
1991-10-24 14:57:21 +00:00
|
|
|
else
|
|
|
|
return newfloatobject(x);
|
|
|
|
}
|
|
|
|
|
|
|
|
static object *
|
|
|
|
math_modf(self, args)
|
|
|
|
object *self;
|
|
|
|
object *args;
|
|
|
|
{
|
|
|
|
double x, y;
|
|
|
|
if (!getdoublearg(args, &x))
|
|
|
|
return NULL;
|
|
|
|
errno = 0;
|
1994-08-01 11:34:53 +00:00
|
|
|
#ifdef MPW /* MPW C modf expects pointer to extended as second argument */
|
|
|
|
{
|
|
|
|
extended e;
|
|
|
|
x = modf(x, &e);
|
|
|
|
y = e;
|
|
|
|
}
|
|
|
|
#else
|
1991-10-24 14:57:21 +00:00
|
|
|
x = modf(x, &y);
|
1994-08-01 11:34:53 +00:00
|
|
|
#endif
|
1991-12-16 15:44:24 +00:00
|
|
|
CHECK(x);
|
1991-10-24 14:57:21 +00:00
|
|
|
if (errno != 0)
|
1991-12-16 15:44:24 +00:00
|
|
|
return math_error();
|
1993-03-16 12:15:04 +00:00
|
|
|
return mkvalue("(dd)", x, y);
|
1991-10-24 14:57:21 +00:00
|
|
|
}
|
1990-10-14 12:07:46 +00:00
|
|
|
|
|
|
|
static struct methodlist math_methods[] = {
|
|
|
|
{"acos", math_acos},
|
|
|
|
{"asin", math_asin},
|
|
|
|
{"atan", math_atan},
|
|
|
|
{"atan2", math_atan2},
|
|
|
|
{"ceil", math_ceil},
|
|
|
|
{"cos", math_cos},
|
|
|
|
{"cosh", math_cosh},
|
|
|
|
{"exp", math_exp},
|
|
|
|
{"fabs", math_fabs},
|
|
|
|
{"floor", math_floor},
|
|
|
|
{"fmod", math_fmod},
|
1991-10-24 14:57:21 +00:00
|
|
|
{"frexp", math_frexp},
|
1995-01-02 19:30:30 +00:00
|
|
|
#ifdef HAVE_HYPOT
|
1994-10-20 22:00:28 +00:00
|
|
|
{"hypot", math_hypot},
|
1995-01-02 19:30:30 +00:00
|
|
|
#endif
|
1991-10-24 14:57:21 +00:00
|
|
|
{"ldexp", math_ldexp},
|
1990-10-14 12:07:46 +00:00
|
|
|
{"log", math_log},
|
|
|
|
{"log10", math_log10},
|
|
|
|
{"modf", math_modf},
|
|
|
|
{"pow", math_pow},
|
|
|
|
{"sin", math_sin},
|
|
|
|
{"sinh", math_sinh},
|
|
|
|
{"sqrt", math_sqrt},
|
|
|
|
{"tan", math_tan},
|
|
|
|
{"tanh", math_tanh},
|
|
|
|
{NULL, NULL} /* sentinel */
|
|
|
|
};
|
|
|
|
|
|
|
|
void
|
|
|
|
initmath()
|
|
|
|
{
|
|
|
|
object *m, *d, *v;
|
1990-10-26 14:59:30 +00:00
|
|
|
|
|
|
|
m = initmodule("math", math_methods);
|
1990-10-14 12:07:46 +00:00
|
|
|
d = getmoduledict(m);
|
1990-11-18 17:36:45 +00:00
|
|
|
dictinsert(d, "pi", v = newfloatobject(atan(1.0) * 4.0));
|
|
|
|
DECREF(v);
|
|
|
|
dictinsert(d, "e", v = newfloatobject(exp(1.0)));
|
|
|
|
DECREF(v);
|
1990-10-14 12:07:46 +00:00
|
|
|
}
|