/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/*****************************************************************************\
* *
* KlO: Number *
* BODY *
* *
\*****************************************************************************/
/* Numbers: for an easier subclassing and avoiding exponential combinations
* the principe for multi-methods (coerce, equal, operations) is to order by
* precedence the types:
* -> Number (Integer actually) >> Real >> Unsigned >> Long
* The super class (Integer) delegates to the lower ones the operations
* it doesnt know how to handle. Lower classes thus have the obligation
* to treat all cases, and adding a new numeric type will *require* to code
* these operation (meaning there are no default for these methods)
*/
#include "EXTERN.h"
#if defined(__NUTC__)
#include <limits.h>
#endif
#include "klone.h"
#include "kl_atom.h"
#include "kl_string.h"
#include "kl_list.h"
#include "INTERN.h"
#include "kl_number.h"
KlNumber KlNumberRawMake();
/*
* Constructor: KlNumberMake
* argument 1: The Int (int of size char *) which is to be our number.
*/
KlNumber
KlNumberMake(i)
Int i; /* just the Int value of the integer */
{
KlNumber object;
if (i <= MAX_BUILT_IN_NUMBER && i >= MIN_BUILT_IN_NUMBER)
return KlBuiltInNumbers[i - MIN_BUILT_IN_NUMBER];
object = (KlNumber) KlOMake(KlNumberType);
object->number = i;
return object;
}
KlNumber
KlNumberRawMake(i)
long i; /* just the LONG value of the integer */
{
KlNumber object = (KlNumber) KlOMake(KlNumberType);
object->number = i;
return object;
}
/*
* KlNumberPrint:
* a number prints as a long.
*/
KlO
KlNumberPrint(obj, stream)
KlNumber obj;
KlO stream;
{
KlSPrintf(stream, "%ld", obj->number);
return (KlO) obj;
}
/*
* KlNumberFree:
* The structure is just freed.
*/
KlO
KlNumberFree(obj)
KlNumber obj;
{
Free(obj);
return (KlO) obj;
}
/* default case: wrapper around compare */
KlO
KlNumberEqual(n1, n2)
KlNumber n1, n2;
{
if (KlIsANumber(n2)) {
return KlCompare(n1, n2) == 0 ? (KlO) n1 : NIL;
} else {
return NIL;
}
}
/* specialized case for integers. let do compare do the non-trivial work */
KlO
KlIntegerEqual(n1, n2)
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) { /* shortcut for common case */
return n1->number == n2->number ? (KlO) n1 : NIL;
} else if (KlIsANumber(n2)) {
return KlCompare(n1, n2) == 0 ? (KlO) n1 : NIL;
} else {
return NIL;
}
}
/* KlNumberCoerce
* string ==> does a scanf (atoi)
*/
/*ARGSUSED*/
KlO
KlNumberCoerce(totype, obj)
KlType totype;
KlString obj;
{
if (KlIsAString(obj)) {
long n = 0;
if ((obj->string[0] == '0'
&& (obj->string[1] == 'x' || obj->string[1] == 'X')
&& sscanf(obj->string + 2, "%lx", &n))
||
sscanf(obj->string, "%ld", &n)) {
return (KlO) KlNumberMake(n); /* Ok */
} else {
return 0;
}
} else if (KlIsAReal(obj)) {
return (KlO) KlNumberMake(((KlNumber) obj)->number);
} else if (KlIsANumber(obj)) {
if (KlIsAnInteger(obj))
return (KlO) obj;
else
return (KlO) KlNumberMake(((KlNumber) obj)->number);
}
return 0;
}
KlO
KlNumberHash(obj)
KlNumber obj;
{
return (KlO) obj->number;
}
/* (N obj) ==> (getn obj N)
* (N obj val) ==> (put obj N val)
*/
KlO
KlNumberExecuteOrApply(num, list, eval)
KlNumber num;
KlList list;
int eval; /* eval args? */
{
KlO obj = list->list[1];
if (list->size == 2) { /* get */
if (eval)
obj = KlSend_eval(obj);
return KlSend_nth(obj, num->number, 0);
} else if (list->size == 3) { /* put */
KlO val = list->list[2];
if (eval) {
obj = KlSend_eval(obj);
val = KlSend_eval(val);
}
return KlSend_nth(obj, num->number, val);
} else {
return CFAPPLY((KlSelectorUndefmethod(eval ? KlSelExecute : KlSelApply)),
(num, list));
}
}
KlO
KlNumberExecute(num, list)
KlNumber num;
KlList list;
{
return KlNumberExecuteOrApply(num, list, 1);
}
KlO
KlNumberApply(num, list)
KlNumber num;
KlList list;
{
return KlNumberExecuteOrApply(num, list, 0);
}
int
KlNumberCompare(o1, o2)
KlNumber o1, o2;
{
if (KlIsAnInteger(o2))
return o1->number - o2->number;
if (KlIsANumber(o2)) {
return -KlSend_compare(o2, o1); /* let the subclasses do the work */
} else {
return (int) KlBadArgument(o2, 1, KlTypeCName(KlNumberType));
}
}
int
KlGenericNumberCompare(o1, o2)
KlNumber o1, o2;
{
if (KlIsAnInteger(o2))
return o1->number - o2->number;
if (KlIsANumber(o2)) {
/* let the subclasses do the work */
return -KlSend_compare(KlNumberMake(o2), o1);
} else {
return (int) KlBadArgument(o2, 1, KlTypeCName(KlNumberType));
}
}
/*****************************************************************************\
* Arithmetic OO subsystem *
\*****************************************************************************/
/* To cope with the compelxity of managing lots of numeric subtypes:
* (int, reals, unsigned, longs...), we implement here a sub-OO system to
* provide multi-method functionnality for the arithmetic operators, without
* impacting the main OO system. The + operator being n-ary is especially
* complex
*
* If you declare a simple type derived from Number and dont want to define
* specific arithmetic semantics, you MUST call KlDeclareGenericNumber(newtype)
*/
typedef struct _KlNumberOpMethod {
KlMethod op_plus;
KlMethod op_mult;
KlMethod op_div;
} *KlNumberOpMethod;
KlNumberOpMethod KlNumberOpMethods;/* array of Op methods */
int KlNumberOpSize = 0;
/* set up operator tables */
void
KlNumberDeclareOp(type, add, mul, div)
KlType type;
KlMethod add, mul, div;
{
KlNumberOpMethod ops;
KlTypeNumOpSet(type, KlNumberOpSize);
if (!(KlNumberOpSize++)) { /* init, first type sets the base */
KlNumberOpMethods = (KlNumberOpMethod)
Malloc(sizeof(struct _KlNumberOpMethod));
} else {
KlNumberOpMethods = (KlNumberOpMethod)
Realloc(KlNumberOpMethods, sizeof(struct _KlNumberOpMethod)
* KlNumberOpSize);
}
ops = KlNumberOpMethods + (KlNumberOpSize - 1);
ops->op_plus = add;
ops->op_mult = mul;
ops->op_div = div;
}
void
KlDeclareGenericNumber(type)
KlType type;
{
KlNumberDeclareOp(type, KlGenericNumberAdd1,
KlGenericNumberMult, KlGenericNumberDiv);
KlDeclareMethod1(type, KlSelCompare, (KlMethod) KlGenericNumberCompare);
}
KlO
KlNumberAdd1(n1, n2)
KlNumber n1;
KlNumber n2;
{
KlMethod func = KlNumberOpMethods[KlTypeNumOpGet(n1->type)].op_plus;
if (func)
return (*func)(n1, n2);
else
return (KlO) KlBadArgument(n1, 1, KlTypeCName(KlNumbersType));
}
KlO
KlNumberMult(n1, n2)
KlNumber n1;
KlNumber n2;
{
KlMethod func = KlNumberOpMethods[KlTypeNumOpGet(n1->type)].op_mult;
if (func)
return (*func)(n1, n2);
else
return (KlO) KlBadArgument(n1, 1, KlTypeCName(KlNumbersType));
}
KlO
KlNumberDiv(invert, n1, n2)
int invert;
KlNumber n1;
KlNumber n2;
{
KlMethod func = KlNumberOpMethods[KlTypeNumOpGet(n1->type)].op_div;
if (func)
return (*func)(invert, n1, n2);
else
return (KlO) KlBadArgument(n1, 1, KlTypeCName(KlNumbersType));
}
/*****************************************************************************\
* Arithmetic functions *
\*****************************************************************************/
KlO
KlDivide(n1, n2)
KlNumber n1, n2;
{
KlO result;
KlMustBeNumber(n1, 0);
KlMustBeNumber(n2, 1);
if (result = KlNumberDiv(0, n1, n2)) return result;
return (KlO) KlError1(KlE_DIVIDE_BY_ZERO, n1);
}
KlO
KlModulo(n1, n2)
KlNumber n1, n2;
{
Int tmp = n2->number ? n1->number % n2->number : 0;
KlMustBeNumber(n1, 0);
KlMustBeNumber(n2, 1);
if (tmp < 0)
tmp = tmp + n2->number;
return (KlO) KlNumberMake(tmp);
}
KlO
KlMultiply(n1, n2)
KlNumber n1, n2;
{
KlO result;
KlMustBeNumber(n1, 0);
if (result = KlNumberMult(n1, n2)) return result;
return (KlO) KlBadArgument(n2, 1, KlTraitName(KlTrait_number));
}
KlO
KlMinus(argc, argv)
int argc;
KlNumber argv[];
{
KlNumber n1, n2;
switch (argc) {
case 1: {
n1 = argv[0];
if (KlIsAnInteger(n1))
return (KlO) KlNumberMake(- (n1->number));
else if (KlIsAReal(n1))
return (KlO) KlRealMake(-((KlReal) n1)->real);
else
return (KlO) KlBadArgument(n1, 0, KlTraitName(KlTrait_number));
}
case 2:
n1 = argv[0];
n2 = argv[1];
/* optimise common case */
if (KlIsAnInteger(n1) && KlIsAnInteger(n2))
return (KlO) KlNumberMake(n1->number - n2->number);
else if (KlIsANumber(n1))
return (KlO) KlNumberAdd1(n1, KlMinus(1, &n2));
else
return (KlO) KlBadArgument(n1, 0, KlTraitName(KlTrait_number));
case 0:
return KlBadNumberOfArguments((char *) argc);
default:{ /* (- a (+ b c d...)) */
KlNumber argv2[2];
argv2[0] = argv[0];
argv2[1] = (KlNumber) KlAdd(argc - 1, argv + 1);
return (KlO) KlMinus(2, argv2);
}
}
}
/* absolute value */
KlO
KlAbsKl(n)
KlNumber n;
{
KlMustBeNumber(n, 0);
if (KlIsAReal(n)) {
if (((KlReal) n)->real >= 0) return (KlO) n;
else
return (KlO) KlRealMake(-((KlReal) n)->real);
} else if (KlIsAnInteger(n)) {
if (n->number >= 0)
return (KlO) n;
else
return (KlO) KlNumberMake(-n->number);
}
return (KlO) KlBadArgument(n, 0, KlTypeCName(KlNumbersType));
}
/* KlNumberAdd is a more complex generic function (n-ary), recursively
* calling the relevant methods
*/
KlO
KlNumberAdd(argc, argv)
int argc;
KlNumber *argv;
{
int iresult;
KlNumber *end = argv + argc, *argvo = argv;
KlO klresult;
if (KlIsAnInteger(*argv)) {
iresult = (*argv++)->number;
} else {
klresult = (KlO) *argv++;
goto generic;
}
/* optimized loop as long as no non-Int has been detected */
while (argv < end) {
if (KlIsAnInteger(*argv)) {
iresult += (*argv++)->number;
} else if (KlTrueP(*argv)) {
/* optimize for common case: 2 args, 1rst Int */
klresult = KlNumberAdd1(*argv, (argc == 2) ? *(argv - 1)
: KlNumberMake(iresult));
if (!klresult) goto error;
argv++;
goto generic;
} else { /* silently skip () */
argv++;
}
}
return (KlO) KlNumberMake(iresult);
generic: /* call the specialized methods */
while (argv < end) {
if (KlTrueP(*argv)) {
klresult = (KlO) KlNumberAdd1(klresult, *argv);
if (!klresult) goto error;
}
argv++;
}
return klresult;
error: /* meaningful error */
return (KlO) KlBadArgument(*(argv-1), argv - argvo,
KlTraitName(KlTrait_number));
}
/***************** per-subtype adding function: add only one value to object */
KlO
KlIntegerAdd1(n1, n2)
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
return (KlO) KlNumberMake(n1->number + n2->number);
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberAdd1(n2, n1);
return 0;
}
KlO
KlGenericNumberAdd1(n1, n2)
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
return (KlO) KlNumberMake(n1->number + n2->number);
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberAdd1(n2, KlNumberMake(n1->number));
return 0;
}
KlO
KlRealAdd1(n1, n2)
KlReal n1, n2;
{
if (KlIsAReal(n2))
return (KlO) KlRealMake(n1->real + n2->real);
if (KlIsAnInteger(n2))
return (KlO) KlRealMake(n1->real + n2->number);
if (KlIsANumber(n2))
return KlNumberAdd1(n2, n1);
return 0;
}
/********************************************* per-subtype multiply function */
/* 0 means type error */
KlO
KlIntegerMult(n1, n2)
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
return (KlO) KlNumberMake(n1->number * n2->number);
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberMult(n2, n1);
return 0;
}
KlO
KlGenericNumberMult(n1, n2)
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
return (KlO) KlNumberMake(n1->number * n2->number);
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberMult(n2, KlNumberMake(n1));
return 0;
}
KlO
KlRealMult(n1, n2)
KlReal n1, n2;
{
if (KlIsAReal(n2))
return (KlO) KlRealMake(n1->real * n2->real);
if (KlIsAnInteger(n2))
return (KlO) KlRealMake(n1->real * n2->number);
if (KlIsANumber(n2))
return KlNumberMult(n2, n1);
return 0;
}
/*********************************************** per-subtype divide function */
/* 0 means divide by 0 error */
/* first arg true for n1 / n2, null for n2 / n1
*/
KlO
KlIntegerDiv(invert, n1, n2)
int invert;
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
if (invert)
return n1->number ? (KlO)KlNumberMake(n2->number / n1->number) : 0;
else
return n2->number ? (KlO)KlNumberMake(n1->number / n2->number) : 0;
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberDiv(!invert, n2, n1);
return 0;
}
KlO
KlGenericNumberDiv(invert, n1, n2)
int invert;
KlNumber n1, n2;
{
if (KlIsAnInteger(n2)) /* shortcut for common case */
if (invert)
return n1->number ? (KlO)KlNumberMake(n2->number / n1->number) : 0;
else
return n2->number ? (KlO)KlNumberMake(n1->number / n2->number) : 0;
if (KlIsANumber(n2))
/* dont duplicate work, let the subclasses do the job */
return KlNumberDiv(!invert, n2, KlNumberMake(n1));
return 0;
}
KlO
KlRealDiv(invert, n1, n2)
int invert;
KlReal n1, n2;
{
if (KlIsAReal(n2))
if (invert)
return (n1->real != 0.0) ?
(KlO) KlRealMake(n2->real / n1->real) : 0;
else
return (n2->real != 0.0) ?
(KlO) KlRealMake(n1->real / n2->real) : 0;
if (KlIsAnInteger(n2))
if (invert)
return (n1->real != 0.0) ?
(KlO) KlRealMake(n2->number / n1->real) : 0;
else
return n2->number ?
(KlO) KlRealMake(n1->real / n2->number) : 0;
if (KlIsANumber(n2))
return KlNumberDiv(!invert, n2, n1);
return 0;
}
/* needed from parser */
KlO
KlUnsignedMakeFromString(s)
char *s;
{
Int n;
sscanf(s+2, "%lu", &n);
return (KlO) KlNumberMake(n);
}
/* needed from parser */
KlO
KlLongMakeFromString(s)
char *s;
{
Int n;
sscanf(s+2, "%d", &n);
return (KlO) KlNumberMake(n);
}
/*****************************************************************************\
* Real numbers *
\*****************************************************************************/
KlReal
KlRealMake(x)
double x;
{
KlReal obj = (KlReal) KlOMake(KlRealType);
obj->real = x;
KlRealFix(obj);
return obj;
}
/* print of a real
* in natural format, but always with a dot if we print readably
*/
#define KlMAXREALPRECISION 20
#define KlMAXREALPRECISIONFORMAT "%.20g"
KlO
KlRealPrint(obj, stream)
KlReal obj;
KlO stream;
{
char s[KlMAXREALPRECISION+12];
if (KlPrintReadably || KlRealPrecision >= KlMAXREALPRECISION) {
sprintf(s, KlMAXREALPRECISIONFORMAT, obj->real);
} else if (KlRealPrecision < 0) {
sprintf(s, "%lg", obj->real);
} else {
char format[10];
sprintf(format, "%%.%dlg", KlRealPrecision);
sprintf(s, format, obj->real);
}
if (!strchr(s, '.') && !strchr(s, 'e')) { /* prints as an integer */
strcat(s, ".0"); /* adds a dot to show it is a real */
}
KlSPuts(s, stream);
return (KlO) obj;
}
/* KlRealCoerce
* string ==> does a scanf (atoi)
*/
/*ARGSUSED*/
KlO
KlRealCoerce(totype, obj)
KlType totype;
KlString obj;
{
if (KlIsAString(obj)) {
double x;
long n;
if (obj->string[0] == '0'
&& (obj->string[1] == 'x' || obj->string[1] == 'X')
&& sscanf(obj->string + 2, "%lx", &n)) {
return (KlO) KlRealMake((double) n);
} else if (sscanf(obj->string, "%lf", &x)) {
return (KlO) KlRealMake(x); /* Ok */
} else {
return 0;
}
} else if (KlIsAReal(obj)) {
return (KlO) obj;
} else if (KlIsANumber(obj)) {
return (KlO) KlRealMake((double) (((KlNumber) obj)->number));
}
return 0;
}
KlO
KlNumbersCoerce(totype, obj)
KlType totype;
KlString obj;
{
char *s = obj->string;
if (KlIsAString(obj) && *s) {
if (strchr(s, '.') || strchr(s, 'e')) { /* prints as an integer */
return KlRealCoerce(totype, obj);
}
}
/* else just like an int */
return KlNumberCoerce(totype, obj);
}
KlO
KlRealHash(obj)
KlReal obj;
{
unsigned int result = obj->real + obj->real * 1000000;
return (KlO) result;
}
int
KlRealCompare(o1, o2)
KlReal o1, o2;
{
if (KlIsAReal(o2)) {
return (o1->real == o2->real ? 0 : (o1->real > o2->real ? 1 : -1));
} else if (KlIsAnInteger(o2)) {
double r2 = (double) ((KlNumber) o2)->number;
return (o1->real == r2 ? 0 : (o1->real > r2 ? 1 : -1));
} else if (KlIsANumber(o2)) {
return -KlSend_compare(o2, o1); /* let the subclasses do the work */
} else {
return (int) KlBadArgument(o2, 1, KlTypeCName(KlNumbersType));
}
}
/* elevation to integral powers: **
*/
KlO
KlPower(x, n)
KlReal x;
KlNumber n;
{
int elevation;
KlMustBeInteger(n, 1);
if (n->number >= 0)
elevation = n->number;
else
elevation = - n->number;
if (KlIsAReal(x)) {
double val = 1.0;
while (elevation--)
val *= x->real;
if (n->number < 0)
val = 1 / val;
return (KlO) KlRealMake(val);
} else if (KlIsAnInteger(x)) {
int val = 1;
while (elevation--)
val *= x->number;
if (n->number < 0) {
double result = 1 / ((double) val);
return (KlO) KlRealMake(result);
} else {
return (KlO) KlNumberMake(val);
}
}
KlMustBeNumber(x, 0);
/* NOTREACHED */
return (KlO) x;
}
/* (incf var value)
* increments variable by value
*/
KlO
KlIncf(argc, argv)
int argc;
KlO *argv;
{
KlO values[2];
KlO newval;
if (argc == 0 || argc > 2)
return KlBadNumberOfArguments((char *) argc);
values[0] = KlSend_eval(argv[0]);
if (argc == 2)
values[1] = KlSend_eval(argv[1]);
else
values[1] = (KlO) KlBuiltInNumbers[1 - MIN_BUILT_IN_NUMBER];
newval = KlSendNary(KlSelAdd, 2, values);
return KlSend_setq(argv[0], newval);
}
/*****************************************************************************\
* TYPE INIT *
\*****************************************************************************/
KlNumberInit()
{
KlDeclareType(&KlMagnitudeType, "Magnitude", 0);
KlDeclareType(&KlNumbersType, "Number", 0);
KlTypeFatherSet(KlNumbersType, KlMagnitudeType);
KlDeclareIsTrait(KlNumbersType, KlTrait_number);
KlDeclareMethod1(KlNumbersType, KlSelEqual, KlNumberEqual);
KlDeclareMethod1(KlNumbersType, KlSelAdd, KlNumberAdd);
KlDeclareSubType(&KlNumberType, "Int", KlNumbersType,
sizeof(struct _KlNumber));
KlA_Int = KlTypeName(KlNumberType);
KlDeclareMethod1(KlNumberType, KlSelPrint, KlNumberPrint);
KlDeclareMethod1(KlNumberType, KlSelEqual, KlIntegerEqual);
KlDeclareMethod1(KlNumberType, KlSelHash, KlNumberHash);
KlDeclareMethod1(KlNumberType, KlSelCompare, (KlMethod) KlNumberCompare);
KlDeclareMethod1(KlNumberType, KlSelExecute, KlNumberExecute);
KlDeclareMethod1(KlNumberType, KlSelApply, KlNumberApply);
KlDeclareSubType(&KlRealType, "Real", KlNumbersType,
sizeof(struct _KlReal));
KlDeclareMethod1(KlRealType, KlSelPrint, KlRealPrint);
KlDeclareMethod1(KlRealType, KlSelHash, KlRealHash);
KlDeclareMethod1(KlRealType, KlSelCompare, (KlMethod) KlRealCompare);
KlDeclareSubr(KlPower, "**", 2);
KlDeclareFSubr(KlIncf, "incf", NARY);
KlDeclareSubr(KlMultiply, "*", 2);
KlDeclareSubr(KlDivide, "/", 2);
KlDeclareSubr(KlModulo, "mod", 2);
KlDeclareSubr(KlMinus, "-", NARY);
KlDeclareSubr(KlAbsKl, "abs", 1);
/* arithmetic operator setup */
KlNumberDeclareOp(KlNumberType, KlIntegerAdd1, KlIntegerMult,
KlIntegerDiv);
KlNumberDeclareOp(KlRealType, KlRealAdd1, KlRealMult,
KlRealDiv);
{
/* pre-calculate "low" numbers (most used ones) */
long i;
KlNumber *p = KlBuiltInNumbers;
for (i = MIN_BUILT_IN_NUMBER; i <= MAX_BUILT_IN_NUMBER; i++, p++)
KlIncRef((*p) = KlNumberRawMake(i));
}
}
syntax highlighted by Code2HTML, v. 0.9.1