2005-12-23 17:07:08 +01:00
|
|
|
|
/******************************************************************************
|
|
|
|
|
Copyright (c) 1992, 1995, 1996 Xerox Corporation. All rights reserved.
|
|
|
|
|
Portions of this code were written by Stephen White, aka ghond.
|
|
|
|
|
Use and copying of this software and preparation of derivative works based
|
|
|
|
|
upon this software are permitted. Any distribution of this software or
|
|
|
|
|
derivative works must comply with all applicable United States export
|
|
|
|
|
control laws. This software is made available AS IS, and Xerox Corporation
|
|
|
|
|
makes no warranty about the software, its performance or its conformity to
|
|
|
|
|
any specification. Any person obtaining a copy of this software is requested
|
|
|
|
|
to send their name and post office or electronic mail address to:
|
|
|
|
|
Pavel Curtis
|
|
|
|
|
Xerox PARC
|
|
|
|
|
3333 Coyote Hill Rd.
|
|
|
|
|
Palo Alto, CA 94304
|
|
|
|
|
Pavel@Xerox.Com
|
|
|
|
|
*****************************************************************************/
|
|
|
|
|
|
|
|
|
|
#include <limits.h>
|
|
|
|
|
#include <errno.h>
|
|
|
|
|
#include <float.h>
|
|
|
|
|
#include <math.h>
|
|
|
|
|
#include <stdlib.h>
|
|
|
|
|
#include <string.h>
|
|
|
|
|
#include <time.h>
|
|
|
|
|
|
2006-01-10 01:39:53 +01:00
|
|
|
|
#include "pconfig.h"
|
2005-12-23 17:07:08 +01:00
|
|
|
|
#include "functions.h"
|
|
|
|
|
#include "storage.h"
|
|
|
|
|
#include "structures.h"
|
|
|
|
|
#include "utils.h"
|
|
|
|
|
|
|
|
|
|
static int
|
|
|
|
|
parse_number(const char *str, int *result, int try_floating_point)
|
|
|
|
|
{
|
|
|
|
|
char *p;
|
|
|
|
|
|
|
|
|
|
*result = strtol(str, &p, 10);
|
|
|
|
|
if (try_floating_point &&
|
|
|
|
|
(p == str || *p == '.' || *p == 'e' || *p == 'E'))
|
|
|
|
|
*result = (int) strtod(str, &p);
|
|
|
|
|
if (p == str)
|
|
|
|
|
return 0;
|
|
|
|
|
while (*p) {
|
|
|
|
|
if (*p != ' ')
|
|
|
|
|
return 0;
|
|
|
|
|
p++;
|
|
|
|
|
}
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
static int
|
|
|
|
|
parse_object(const char *str, Objid * result)
|
|
|
|
|
{
|
|
|
|
|
int number;
|
|
|
|
|
|
|
|
|
|
while (*str && *str == ' ')
|
|
|
|
|
str++;
|
|
|
|
|
if (*str == '#')
|
|
|
|
|
str++;
|
|
|
|
|
if (parse_number(str, &number, 0)) {
|
|
|
|
|
*result = number;
|
|
|
|
|
return 1;
|
|
|
|
|
} else
|
|
|
|
|
return 0;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
static int
|
|
|
|
|
parse_float(const char *str, double *result)
|
|
|
|
|
{
|
|
|
|
|
char *p;
|
|
|
|
|
int negative = 0;
|
|
|
|
|
|
|
|
|
|
while (*str && *str == ' ')
|
|
|
|
|
str++;
|
|
|
|
|
if (*str == '-') {
|
|
|
|
|
str++;
|
|
|
|
|
negative = 1;
|
|
|
|
|
}
|
|
|
|
|
*result = strtod(str, &p);
|
|
|
|
|
if (p == str)
|
|
|
|
|
return 0;
|
|
|
|
|
while (*p) {
|
|
|
|
|
if (*p != ' ')
|
|
|
|
|
return 0;
|
|
|
|
|
p++;
|
|
|
|
|
}
|
|
|
|
|
if (negative)
|
|
|
|
|
*result = -*result;
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
enum error
|
|
|
|
|
become_integer(Var in, int *ret, int called_from_tonum)
|
|
|
|
|
{
|
|
|
|
|
switch (in.type) {
|
|
|
|
|
case TYPE_INT:
|
|
|
|
|
*ret = in.v.num;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_STR:
|
|
|
|
|
if (!(called_from_tonum
|
|
|
|
|
? parse_number(in.v.str, ret, 1)
|
|
|
|
|
: parse_object(in.v.str, ret)))
|
|
|
|
|
*ret = 0;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_OBJ:
|
|
|
|
|
*ret = in.v.obj;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_ERR:
|
|
|
|
|
*ret = in.v.err;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_FLOAT:
|
|
|
|
|
if (*in.v.fnum < (double) INT_MIN || *in.v.fnum > (double) INT_MAX)
|
|
|
|
|
return E_FLOAT;
|
|
|
|
|
*ret = (int) *in.v.fnum;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_LIST:
|
|
|
|
|
return E_TYPE;
|
|
|
|
|
}
|
|
|
|
|
return E_NONE;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
static enum error
|
|
|
|
|
become_float(Var in, double *ret)
|
|
|
|
|
{
|
|
|
|
|
switch (in.type) {
|
|
|
|
|
case TYPE_INT:
|
|
|
|
|
*ret = (double) in.v.num;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_STR:
|
|
|
|
|
if (!parse_float(in.v.str, ret) || !IS_REAL(*ret))
|
|
|
|
|
return E_INVARG;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_OBJ:
|
|
|
|
|
*ret = (double) in.v.obj;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_ERR:
|
|
|
|
|
*ret = (double) in.v.err;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_FLOAT:
|
|
|
|
|
*ret = *in.v.fnum;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_LIST:
|
|
|
|
|
return E_TYPE;
|
|
|
|
|
}
|
|
|
|
|
return E_NONE;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
Var
|
|
|
|
|
new_float(double d)
|
|
|
|
|
{
|
|
|
|
|
Var v;
|
|
|
|
|
|
|
|
|
|
v.type = TYPE_FLOAT;
|
|
|
|
|
v.v.fnum = mymalloc(sizeof(double), M_FLOAT);
|
|
|
|
|
*v.v.fnum = d;
|
|
|
|
|
|
|
|
|
|
return v;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#if COERCION_IS_EVER_IMPLEMENTED_AND_DESIRED
|
|
|
|
|
static int
|
|
|
|
|
to_float(Var v, double *dp)
|
|
|
|
|
{
|
|
|
|
|
switch (v.type) {
|
|
|
|
|
case TYPE_INT:
|
|
|
|
|
*dp = (double) v.v.num;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_FLOAT:
|
|
|
|
|
*dp = *v.v.fnum;
|
|
|
|
|
break;
|
|
|
|
|
default:
|
|
|
|
|
return 0;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
#if defined(HAVE_MATHERR) && defined(DOMAIN) && defined(SING) && defined(OVERFLOW) && defined(UNDERFLOW)
|
|
|
|
|
/* Required in order to properly handle FP exceptions on SVID3 systems */
|
|
|
|
|
int
|
|
|
|
|
matherr(struct exception *x)
|
|
|
|
|
{
|
|
|
|
|
switch (x->type) {
|
|
|
|
|
case DOMAIN:
|
|
|
|
|
case SING:
|
|
|
|
|
errno = EDOM;
|
|
|
|
|
/* fall thru to... */
|
|
|
|
|
case OVERFLOW:
|
|
|
|
|
x->retval = HUGE_VAL;
|
|
|
|
|
return 1;
|
|
|
|
|
case UNDERFLOW:
|
|
|
|
|
x->retval = 0.0;
|
|
|
|
|
return 1;
|
|
|
|
|
default:
|
|
|
|
|
return 0; /* Take default action */
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
/**** opcode implementations ****/
|
|
|
|
|
|
|
|
|
|
/*
|
|
|
|
|
* All of the following implementations are strict, not performing any
|
|
|
|
|
* coercions between integer and floating-point operands.
|
|
|
|
|
*/
|
|
|
|
|
|
|
|
|
|
int
|
|
|
|
|
do_equals(Var lhs, Var rhs)
|
|
|
|
|
{ /* LHS == RHS */
|
|
|
|
|
/* At least one of LHS and RHS is TYPE_FLOAT */
|
|
|
|
|
|
|
|
|
|
if (lhs.type != rhs.type)
|
|
|
|
|
return 0;
|
|
|
|
|
else
|
|
|
|
|
return *lhs.v.fnum == *rhs.v.fnum;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
int
|
|
|
|
|
compare_integers(int a, int b)
|
|
|
|
|
{
|
|
|
|
|
if (a < b)
|
|
|
|
|
return -1;
|
|
|
|
|
else if (a == b)
|
|
|
|
|
return 0;
|
|
|
|
|
else
|
|
|
|
|
return 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
Var
|
|
|
|
|
compare_numbers(Var a, Var b)
|
|
|
|
|
{
|
|
|
|
|
Var ans;
|
|
|
|
|
|
|
|
|
|
if (a.type != b.type) {
|
|
|
|
|
ans.type = TYPE_ERR;
|
|
|
|
|
ans.v.err = E_TYPE;
|
|
|
|
|
} else if (a.type == TYPE_INT) {
|
|
|
|
|
ans.type = TYPE_INT;
|
|
|
|
|
ans.v.num = compare_integers(a.v.num, b.v.num);
|
|
|
|
|
} else {
|
|
|
|
|
double aa = *a.v.fnum, bb = *b.v.fnum;
|
|
|
|
|
|
|
|
|
|
ans.type = TYPE_INT;
|
|
|
|
|
if (aa < bb)
|
|
|
|
|
ans.v.num = -1;
|
|
|
|
|
else if (aa == bb)
|
|
|
|
|
ans.v.num = 0;
|
|
|
|
|
else
|
|
|
|
|
ans.v.num = 1;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
return ans;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#define SIMPLE_BINARY(name, op) \
|
|
|
|
|
Var \
|
|
|
|
|
do_ ## name(Var a, Var b) \
|
|
|
|
|
{ \
|
|
|
|
|
Var ans; \
|
|
|
|
|
\
|
|
|
|
|
if (a.type != b.type) { \
|
|
|
|
|
ans.type = TYPE_ERR; \
|
|
|
|
|
ans.v.err = E_TYPE; \
|
|
|
|
|
} else if (a.type == TYPE_INT) { \
|
|
|
|
|
ans.type = TYPE_INT; \
|
|
|
|
|
ans.v.num = a.v.num op b.v.num; \
|
|
|
|
|
} else { \
|
|
|
|
|
double d = *a.v.fnum op *b.v.fnum; \
|
|
|
|
|
\
|
|
|
|
|
if (!IS_REAL(d)) { \
|
|
|
|
|
ans.type = TYPE_ERR; \
|
|
|
|
|
ans.v.err = E_FLOAT; \
|
|
|
|
|
} else \
|
|
|
|
|
ans = new_float(d); \
|
|
|
|
|
} \
|
|
|
|
|
\
|
|
|
|
|
return ans; \
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
SIMPLE_BINARY(add, +)
|
|
|
|
|
SIMPLE_BINARY(subtract, -)
|
|
|
|
|
SIMPLE_BINARY(multiply, *)
|
|
|
|
|
#define DIVISION_OP(name, iop, fexpr) \
|
|
|
|
|
Var \
|
|
|
|
|
do_ ## name(Var a, Var b) \
|
|
|
|
|
{ \
|
|
|
|
|
Var ans; \
|
|
|
|
|
\
|
|
|
|
|
if (a.type != b.type) { \
|
|
|
|
|
ans.type = TYPE_ERR; \
|
|
|
|
|
ans.v.err = E_TYPE; \
|
|
|
|
|
} else if (a.type == TYPE_INT \
|
|
|
|
|
&& b.v.num != 0) { \
|
|
|
|
|
ans.type = TYPE_INT; \
|
|
|
|
|
ans.v.num = a.v.num iop b.v.num; \
|
|
|
|
|
} else if (a.type == TYPE_FLOAT \
|
|
|
|
|
&& *b.v.fnum != 0.0) { \
|
|
|
|
|
double d = fexpr; \
|
|
|
|
|
\
|
|
|
|
|
if (!IS_REAL(d)) { \
|
|
|
|
|
ans.type = TYPE_ERR; \
|
|
|
|
|
ans.v.err = E_FLOAT; \
|
|
|
|
|
} else \
|
|
|
|
|
ans = new_float(d); \
|
|
|
|
|
} else { \
|
|
|
|
|
ans.type = TYPE_ERR; \
|
|
|
|
|
ans.v.err = E_DIV; \
|
|
|
|
|
} \
|
|
|
|
|
\
|
|
|
|
|
return ans; \
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
DIVISION_OP(divide, /, *a.v.fnum / *b.v.fnum)
|
|
|
|
|
DIVISION_OP(modulus, %, fmod(*a.v.fnum, *b.v.fnum))
|
|
|
|
|
Var
|
|
|
|
|
do_power(Var lhs, Var rhs)
|
|
|
|
|
{ /* LHS ^ RHS */
|
|
|
|
|
Var ans;
|
|
|
|
|
|
|
|
|
|
if (lhs.type == TYPE_INT) { /* integer exponentiation */
|
|
|
|
|
int a = lhs.v.num, b, r;
|
|
|
|
|
|
|
|
|
|
if (rhs.type != TYPE_INT)
|
|
|
|
|
goto type_error;
|
|
|
|
|
|
|
|
|
|
b = rhs.v.num;
|
|
|
|
|
ans.type = TYPE_INT;
|
|
|
|
|
if (b < 0)
|
|
|
|
|
switch (a) {
|
|
|
|
|
case -1:
|
|
|
|
|
ans.v.num = (b % 2 == 0 ? 1 : -1);
|
|
|
|
|
break;
|
|
|
|
|
case 0:
|
|
|
|
|
ans.type = TYPE_ERR;
|
|
|
|
|
ans.v.err = E_DIV;
|
|
|
|
|
break;
|
|
|
|
|
case 1:
|
|
|
|
|
ans.v.num = 1;
|
|
|
|
|
break;
|
|
|
|
|
default:
|
|
|
|
|
ans.v.num = 0;
|
|
|
|
|
} else {
|
|
|
|
|
r = 1;
|
|
|
|
|
while (b != 0) {
|
|
|
|
|
if (b % 2 != 0)
|
|
|
|
|
r *= a;
|
|
|
|
|
a *= a;
|
|
|
|
|
b >>= 1;
|
|
|
|
|
}
|
|
|
|
|
ans.v.num = r;
|
|
|
|
|
}
|
|
|
|
|
} else if (lhs.type == TYPE_FLOAT) { /* floating-point exponentiation */
|
|
|
|
|
double d;
|
|
|
|
|
|
|
|
|
|
switch (rhs.type) {
|
|
|
|
|
case TYPE_INT:
|
|
|
|
|
d = (double) rhs.v.num;
|
|
|
|
|
break;
|
|
|
|
|
case TYPE_FLOAT:
|
|
|
|
|
d = *rhs.v.fnum;
|
|
|
|
|
break;
|
|
|
|
|
default:
|
|
|
|
|
goto type_error;
|
|
|
|
|
}
|
|
|
|
|
errno = 0;
|
|
|
|
|
d = pow(*lhs.v.fnum, d);
|
|
|
|
|
if (errno != 0 || !IS_REAL(d)) {
|
|
|
|
|
ans.type = TYPE_ERR;
|
|
|
|
|
ans.v.err = E_FLOAT;
|
|
|
|
|
} else
|
|
|
|
|
ans = new_float(d);
|
|
|
|
|
} else
|
|
|
|
|
goto type_error;
|
|
|
|
|
|
|
|
|
|
return ans;
|
|
|
|
|
|
|
|
|
|
type_error:
|
|
|
|
|
ans.type = TYPE_ERR;
|
|
|
|
|
ans.v.err = E_TYPE;
|
|
|
|
|
return ans;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
char rcsid_numbers[] = "$Id: numbers.c,v 1.1.1.1 2004/02/26 13:13:58 jesse Exp $";
|
|
|
|
|
|
|
|
|
|
/*
|
|
|
|
|
* $Log: numbers.c,v $
|
|
|
|
|
* Revision 1.1.1.1 2004/02/26 13:13:58 jesse
|
|
|
|
|
* Initial import into CVS
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.4 1998/12/14 13:18:37 nop
|
|
|
|
|
* Merge UNSAFE_OPTS (ref fixups); fix Log tag placement to fit CVS whims
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.3 1997/03/08 06:25:42 nop
|
|
|
|
|
* 1.8.0p6 merge by hand.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.2 1997/03/03 04:19:11 nop
|
|
|
|
|
* GNU Indent normalization
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.1.1.1 1997/03/03 03:45:00 nop
|
|
|
|
|
* LambdaMOO 1.8.0p5
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.6 1997/03/04 04:34:06 eostrom
|
|
|
|
|
* parse_number() now trusts strtol() and strtod() more instead of
|
|
|
|
|
* parsing for "-" itself, since a bug in that led to inputs like "--5"
|
|
|
|
|
* and "-+5" being treated as valid.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.5 1996/03/19 07:15:27 pavel
|
|
|
|
|
* Fixed floatstr() to allow DBL_DIG + 4 digits. Release 1.8.0p2.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.4 1996/03/10 01:06:49 pavel
|
|
|
|
|
* Increased the maximum precision acceptable to floatstr() by two digits.
|
|
|
|
|
* Release 1.8.0.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.3 1996/02/18 23:16:22 pavel
|
|
|
|
|
* Made toint() accept floating-point strings. Made floatstr() reject a
|
|
|
|
|
* negative precision argument. Release 1.8.0beta3.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.2 1996/02/11 00:43:00 pavel
|
|
|
|
|
* Added optional implementation of matherr(), to improve floating-point
|
|
|
|
|
* exception handling on SVID3 systems. Added `trunc()' built-in function.
|
|
|
|
|
* Release 1.8.0beta2.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.1 1996/02/08 06:58:01 pavel
|
|
|
|
|
* Added support for floating-point numbers and arithmetic and for the
|
|
|
|
|
* standard math functions. Renamed TYPE_NUM to TYPE_INT, become_number()
|
|
|
|
|
* to become_integer(). Updated copyright notice for 1996. Release
|
|
|
|
|
* 1.8.0beta1.
|
|
|
|
|
*
|
|
|
|
|
* Revision 2.0 1995/11/30 04:28:59 pavel
|
|
|
|
|
* New baseline version, corresponding to release 1.8.0alpha1.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.9 1992/10/23 23:03:47 pavel
|
|
|
|
|
* Added copyright notice.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.8 1992/10/21 03:02:35 pavel
|
|
|
|
|
* Converted to use new automatic configuration system.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.7 1992/10/17 20:47:26 pavel
|
|
|
|
|
* Global rename of strdup->str_dup, strref->str_ref, vardup->var_dup, and
|
|
|
|
|
* varref->var_ref.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.6 1992/09/26 18:02:49 pavel
|
|
|
|
|
* Fixed bug whereby passing negative numbers to random() failed to evoke
|
|
|
|
|
* E_INVARG.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.5 1992/09/14 17:31:52 pjames
|
|
|
|
|
* Updated #includes.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.4 1992/09/08 22:01:42 pjames
|
|
|
|
|
* Renamed bf_num.c to numbers.c. Added `become_number()' from bf_type.c
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.3 1992/08/10 17:36:26 pjames
|
|
|
|
|
* Updated #includes. Used new regisration method. Add bf_sqrt();
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.2 1992/07/20 23:51:47 pavel
|
|
|
|
|
* Added rcsid_<filename-root> declaration to hold the RCS ident. string.
|
|
|
|
|
*
|
|
|
|
|
* Revision 1.1 1992/07/20 23:23:12 pavel
|
|
|
|
|
* Initial RCS-controlled version.
|
|
|
|
|
*/
|