Modules/mathmodule.c

   1 /***********************************************************
   2 Copyright 1991-1995 by Stichting Mathematisch Centrum, Amsterdam,
   3 The Netherlands.
   4
   5                         All Rights Reserved
   6
   7 Permission to use, copy, modify, and distribute this software and its
   8 documentation for any purpose and without fee is hereby granted,
   9 provided that the above copyright notice appear in all copies and that
  10 both that copyright notice and this permission notice appear in
  11 supporting documentation, and that the names of Stichting Mathematisch
  12 Centrum or CWI not be used in advertising or publicity pertaining to
  13 distribution of the software without specific, written prior permission.
  14
  15 STICHTING MATHEMATISCH CENTRUM DISCLAIMS ALL WARRANTIES WITH REGARD TO
  16 THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
  17 FITNESS, IN NO EVENT SHALL STICHTING MATHEMATISCH CENTRUM BE LIABLE
  18 FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  19 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  20 ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  21 OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  22
  23 ******************************************************************/
  24
  25 /* Math module -- standard C math library functions, pi and e */
  26
  27 #include "allobjects.h"
  28
  29 #include <errno.h>
  30
  31 #define getdoublearg(v, a) getargs(v, "d", a)
  32 #define get2doublearg(v, a, b) getargs(v, "(dd)", a, b)
  33
  34 #include "mymath.h"
  35
  36 #ifndef __STDC__
  37 extern double fmod PROTO((double, double));
  38 extern double frexp PROTO((double, int *));
  39 extern double ldexp PROTO((double, int));
  40 extern double modf PROTO((double, double *));
  41 #endif
  42
  43 #ifdef HAVE_HYPOT
  44 extern double hypot PROTO((double, double));
  45 #endif
  46
  47 #ifdef i860
  48 /* Cray APP has bogus definition of HUGE_VAL in <math.h> */
  49 #undef HUGE_VAL
  50 #endif
  51
  52 #ifdef HUGE_VAL
  53 #define CHECK(x) if (errno != 0) ; \
  54         else if (-HUGE_VAL <= (x) && (x) <= HUGE_VAL) ; \
  55         else errno = ERANGE
  56 #else
  57 #define CHECK(x) /* Don't know how to check */
  58 #endif
  59
  60 static object *
  61 math_error()
  62 {
  63         if (errno == EDOM)
  64                 err_setstr(ValueError, "math domain error");
  65         else if (errno == ERANGE)
  66                 err_setstr(OverflowError, "math range error");
  67         else
  68                 err_errno(ValueError); /* Unexpected math error */
  69         return NULL;
  70 }
  71
  72 static object *
  73 math_1(args, func)
  74         object *args;
  75         double (*func) FPROTO((double));
  76 {
  77         double x;
  78         if (!getdoublearg(args, &x))
  79                 return NULL;
  80         errno = 0;
  81         x = (*func)(x);
  82         CHECK(x);
  83         if (errno != 0)
  84                 return math_error();
  85         else
  86                 return newfloatobject(x);
  87 }
  88
  89 static object *
  90 math_2(args, func)
  91         object *args;
  92         double (*func) FPROTO((double, double));
  93 {
  94         double x, y;
  95         if (!get2doublearg(args, &x, &y))
  96                 return NULL;
  97         errno = 0;
  98         x = (*func)(x, y);
  99         CHECK(x);
 100         if (errno != 0)
 101                 return math_error();
 102         else
 103                 return newfloatobject(x);
 104 }
 105
 106 #define FUNC1(stubname, func) \
 107         static object * stubname(self, args) object *self, *args; { \
 108                 return math_1(args, func); \
 109         }
 110
 111 #define FUNC2(stubname, func) \
 112         static object * stubname(self, args) object *self, *args; { \
 113                 return math_2(args, func); \
 114         }
 115
 116 FUNC1(math_acos, acos)
 117 FUNC1(math_asin, asin)
 118 FUNC1(math_atan, atan)
 119 FUNC2(math_atan2, atan2)
 120 FUNC1(math_ceil, ceil)
 121 FUNC1(math_cos, cos)
 122 FUNC1(math_cosh, cosh)
 123 FUNC1(math_exp, exp)
 124 FUNC1(math_fabs, fabs)
 125 FUNC1(math_floor, floor)
 126 FUNC2(math_fmod, fmod)
 127 #ifdef HAVE_HYPOT
 128 FUNC2(math_hypot, hypot)
 129 #endif
 130 FUNC1(math_log, log)
 131 FUNC1(math_log10, log10)
 132 #ifdef MPW_3_1 /* This hack is needed for MPW 3.1 but not for 3.2 ... */
 133 FUNC2(math_pow, power)
 134 #else
 135 FUNC2(math_pow, pow)
 136 #endif
 137 FUNC1(math_sin, sin)
 138 FUNC1(math_sinh, sinh)
 139 FUNC1(math_sqrt, sqrt)
 140 FUNC1(math_tan, tan)
 141 FUNC1(math_tanh, tanh)
 142
 143
 144 static object *
 145 math_frexp(self, args)
 146         object *self;
 147         object *args;
 148 {
 149         double x;
 150         int i;
 151         if (!getdoublearg(args, &x))
 152                 return NULL;
 153         errno = 0;
 154         x = frexp(x, &i);
 155         CHECK(x);
 156         if (errno != 0)
 157                 return math_error();
 158         return mkvalue("(di)", x, i);
 159 }
 160
 161 static object *
 162 math_ldexp(self, args)
 163         object *self;
 164         object *args;
 165 {
 166         double x, y;
 167         /* Cheat -- allow float as second argument */
 168         if (!get2doublearg(args, &x, &y))
 169                 return NULL;
 170         errno = 0;
 171         x = ldexp(x, (int)y);
 172         CHECK(x);
 173         if (errno != 0)
 174                 return math_error();
 175         else
 176                 return newfloatobject(x);
 177 }
 178
 179 static object *
 180 math_modf(self, args)
 181         object *self;
 182         object *args;
 183 {
 184         double x, y;
 185         if (!getdoublearg(args, &x))
 186                 return NULL;
 187         errno = 0;
 188 #ifdef MPW /* MPW C modf expects pointer to extended as second argument */
 189 {
 190         extended e;
 191         x = modf(x, &e);
 192         y = e;
 193 }
 194 #else
 195         x = modf(x, &y);
 196 #endif
 197         CHECK(x);
 198         if (errno != 0)
 199                 return math_error();
 200         return mkvalue("(dd)", x, y);
 201 }
 202
 203 static struct methodlist math_methods[] = {
 204         {"acos", math_acos},
 205         {"asin", math_asin},
 206         {"atan", math_atan},
 207         {"atan2", math_atan2},
 208         {"ceil", math_ceil},
 209         {"cos", math_cos},
 210         {"cosh", math_cosh},
 211         {"exp", math_exp},
 212         {"fabs", math_fabs},
 213         {"floor", math_floor},
 214         {"fmod", math_fmod},
 215         {"frexp", math_frexp},
 216 #ifdef HAVE_HYPOT
 217         {"hypot", math_hypot},
 218 #endif
 219         {"ldexp", math_ldexp},
 220         {"log", math_log},
 221         {"log10", math_log10},
 222         {"modf", math_modf},
 223         {"pow", math_pow},
 224         {"sin", math_sin},
 225         {"sinh", math_sinh},
 226         {"sqrt", math_sqrt},
 227         {"tan", math_tan},
 228         {"tanh", math_tanh},
 229         {NULL,          NULL}           /* sentinel */
 230 };
 231
 232 void
 233 initmath()
 234 {
 235         object *m, *d, *v;
 236
 237         m = initmodule("math", math_methods);
 238         d = getmoduledict(m);
 239         dictinsert(d, "pi", v = newfloatobject(atan(1.0) * 4.0));
 240         DECREF(v);
 241         dictinsert(d, "e", v = newfloatobject(exp(1.0)));
 242         DECREF(v);
 243 }