drygdryg/calc
1
0
Fork 0
mirror of https://github.com/lcn2/calc.git synced 2025-08-16 01:03:29 +03:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
calc/value.c

3103 lines
96 KiB
C
Raw Permalink Blame History

/*
* value - generic value manipulation routines
*
* Copyright (C) 1999-2007,2014,2017,2021-2023 David I. Bell
*
* Calc is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* Calc is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* Under source code control: 1990/02/15 01:48:25
* File existed as early as: before 1990
*
* Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/
*/
#include <stdio.h>
#include <sys/types.h>
#include "value.h"
#include "opcodes.h"
#include "func.h"
#include "symbol.h"
#include "str.h"
#include "zrand.h"
#include "zrandom.h"
#include "cmath.h"
#include "nametype.h"
#include "file.h"
#include "config.h"
#include "errtbl.h"
#include "banned.h" /* include after system header <> includes */
#define LINELEN 80 /* length of a typical tty line */
/*
* Free a value and set its type to undefined.
*
* given:
* vp value to be freed
*/
void
freevalue(VALUE *vp)
{
int type; /* type of value being freed */
type = vp->v_type;
vp->v_type = V_NULL;
vp->v_subtype = V_NOSUBTYPE;
if (type <= 0)
return;
switch (type) {
case V_ADDR:
case V_OCTET:
case V_NBLOCK:
case V_FILE:
case V_VPTR:
case V_OPTR:
case V_SPTR:
case V_NPTR:
/* nothing to free */
break;
case V_STR:
sfree(vp->v_str);
break;
case V_NUM:
qfree(vp->v_num);
break;
case V_COM:
comfree(vp->v_com);
break;
case V_MAT:
matfree(vp->v_mat);
break;
case V_LIST:
listfree(vp->v_list);
break;
case V_ASSOC:
assocfree(vp->v_assoc);
break;
case V_OBJ:
objfree(vp->v_obj);
break;
case V_RAND:
randfree(vp->v_rand);
break;
case V_RANDOM:
randomfree(vp->v_random);
break;
case V_CONFIG:
config_free(vp->v_config);
break;
case V_HASH:
hash_free(vp->v_hash);
break;
case V_BLOCK:
blk_free(vp->v_block);
break;
default:
math_error("Freeing unknown value type");
not_reached();
}
}
/*
* Set protection status for a value and all of its components
*/
void
protecttodepth(VALUE *vp, int sts, int depth)
{
VALUE *vq;
int i;
LISTELEM *ep;
ASSOC *ap;
if (vp->v_type == V_NBLOCK) {
if (sts > 0)
vp->v_nblock->subtype |= sts;
else if (sts < 0)
vp->v_nblock->subtype &= ~(-sts);
else vp->v_nblock->subtype = 0;
return;
}
if (sts > 0)
vp->v_subtype |= sts;
else if (sts < 0)
vp->v_subtype &= ~(-sts);
else
vp->v_subtype = 0;
if (depth > 0) {
switch(vp->v_type) {
case V_MAT:
vq = vp->v_mat->m_table;
i = vp->v_mat->m_size;
while (i-- > 0)
protecttodepth(vq++, sts, depth - 1);
break;
case V_LIST:
for (ep = vp->v_list->l_first; ep; ep = ep->e_next)
protecttodepth(&ep->e_value, sts, depth - 1);
break;
case V_OBJ:
vq = vp->v_obj->o_table;
i = vp->v_obj->o_actions->oa_count;
while (i-- > 0)
protecttodepth(vq++, sts, depth - 1);
break;
case V_ASSOC:
ap = vp->v_assoc;
for (i = 0; i < ap->a_count; i++)
protecttodepth(assocfindex(ap, i), sts, depth - 1);
}
}
}
/*
* Copy a value from one location to another.
* This overwrites the specified new value without checking it.
*
* given:
* oldvp value to be copied from
* newvp value to be copied into
*/
void
copyvalue(VALUE *oldvp, VALUE *newvp)
{
/* firewall */
if (oldvp == NULL)
return;
newvp->v_type = oldvp->v_type;
if (oldvp->v_type >= 0) {
switch (oldvp->v_type) {
case V_NULL:
case V_ADDR:
case V_VPTR:
case V_OPTR:
case V_SPTR:
case V_NPTR:
*newvp = *oldvp;
break;
case V_FILE:
newvp->v_file = oldvp->v_file;
break;
case V_NUM:
newvp->v_num = qlink(oldvp->v_num);
break;
case V_COM:
newvp->v_com = clink(oldvp->v_com);
break;
case V_STR:
newvp->v_str = slink(oldvp->v_str);
break;
case V_MAT:
newvp->v_mat = matcopy(oldvp->v_mat);
break;
case V_LIST:
newvp->v_list = listcopy(oldvp->v_list);
break;
case V_ASSOC:
newvp->v_assoc = assoccopy(oldvp->v_assoc);
break;
case V_OBJ:
newvp->v_obj = objcopy(oldvp->v_obj);
break;
case V_RAND:
newvp->v_rand = randcopy(oldvp->v_rand);
break;
case V_RANDOM:
newvp->v_random = randomcopy(oldvp->v_random);
break;
case V_CONFIG:
newvp->v_config = config_copy(oldvp->v_config);
break;
case V_HASH:
newvp->v_hash = hash_copy(oldvp->v_hash);
break;
case V_BLOCK:
newvp->v_block = blk_copy(oldvp->v_block);
break;
case V_OCTET:
newvp->v_type = V_NUM;
newvp->v_num = itoq((long) *oldvp->v_octet);
break;
case V_NBLOCK:
newvp->v_nblock = oldvp->v_nblock;
break;
default:
math_error("Copying unknown value type");
not_reached();
}
}
newvp->v_subtype = oldvp->v_subtype;
}
/*
* copy the low order 8 bits of a value to an octet
*/
void
copy2octet(VALUE *vp, OCTET *op)
{
USB8 oval; /* low order 8 bits to store into OCTET */
NUMBER *q;
HALF h;
if (vp->v_type == V_ADDR)
vp = vp->v_addr;
oval = 0;
/*
* we can (at the moment) only store certain types
* values into an OCTET, so get the low order 8 bits
* of these particular value types
*/
h = 0;
switch(vp->v_type) {
case V_NULL:
/* nothing to store ... so do nothing */
return;
case V_INT:
oval = (USB8)(vp->v_int & 0xff);
break;
case V_NUM:
if (qisint(vp->v_num)) {
/* use low order 8 bits of integer value */
h = vp->v_num->num.v[0];
} else {
/* use low order 8 bits of int(value) */
q = qint(vp->v_num);
h = q->num.v[0];
qfree(q);
}
if (qisneg(vp->v_num))
h = -h;
oval = (USB8) h;
break;
case V_COM:
if (cisint(vp->v_com)) {
/* use low order 8 bits of integer value */
h = vp->v_com->real->num.v[0];
} else {
/* use low order 8 bits of int(value) */
q = qint(vp->v_com->real);
h = q->num.v[0];
qfree(q);
}
if (qisneg(vp->v_com->real))
h = -h;
oval = (USB8) h;
break;
case V_STR:
oval = (USB8) vp->v_str->s_str[0];
break;
case V_BLOCK:
oval = (USB8) vp->v_block->data[0];
break;
case V_OCTET:
oval = *vp->v_octet;
break;
case V_NBLOCK:
if (vp->v_nblock->blk->data == NULL)
return;
oval = (USB8) vp->v_nblock->blk->data[0];
break;
default:
math_error("invalid assignment into an OCTET");
break;
}
*op = oval;
}
/*
* Negate an arbitrary value.
* Result is placed in the indicated location.
*/
void
negvalue(VALUE *vp, VALUE *vres)
{
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qneg(vp->v_num);
return;
case V_COM:
vres->v_com = c_neg(vp->v_com);
return;
case V_MAT:
vres->v_mat = matneg(vp->v_mat);
return;
case V_STR:
vres->v_str = stringneg(vp->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRNEG);
return;
case V_OCTET:
vres->v_type = V_NUM;
vres->v_subtype = V_NOSUBTYPE;
vres->v_num = itoq(- (long) *vp->v_octet);
return;
case V_OBJ:
*vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type <= 0)
return;
*vres = error_value(E_NEG);
return;
}
}
/*
* Add two arbitrary values together.
* Result is placed in the indicated location.
*/
void
addvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
COMPLEX *c;
VALUE tmp;
NUMBER *q;
long i;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type == V_LIST) {
tmp.v_type = V_NULL;
addlistitems(v1->v_list, &tmp);
addvalue(&tmp, v2, vres);
return;
}
if (v2->v_type == V_LIST) {
copyvalue(v1, vres);
addlistitems(v2->v_list, vres);
return;
}
if (v1->v_type == V_NULL) {
copyvalue(v2, vres);
return;
}
if (v2->v_type == V_NULL) {
copyvalue(v1, vres);
return;
}
vres->v_type = v1->v_type;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qqadd(v1->v_num, v2->v_num);
return;
case TWOVAL(V_COM, V_NUM):
vres->v_com = c_addq(v1->v_com, v2->v_num);
return;
case TWOVAL(V_NUM, V_COM):
vres->v_com = c_addq(v2->v_com, v1->v_num);
vres->v_type = V_COM;
return;
case TWOVAL(V_COM, V_COM):
vres->v_com = c_add(v1->v_com, v2->v_com);
c = vres->v_com;
if (!cisreal(c))
return;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
return;
case TWOVAL(V_MAT, V_MAT):
vres->v_mat = matadd(v1->v_mat, v2->v_mat);
return;
case TWOVAL(V_STR, V_STR):
vres->v_str = stringadd(v1->v_str, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRADD);
return;
case TWOVAL(V_VPTR, V_NUM):
#if defined(PERMIT_DANGEROUS_ADDRESS_ARITHMETIC)
/* NOTE: Defining PERMIT_DANGEROUS_ADDRESS_ARITHMETIC is NOT supported! */
q = v2->v_num;
if (qisfrac(q)) {
math_error("Adding non-integer to address");
not_reached();
}
i = qtoi(q);
vres->v_addr = v1->v_addr + i;
vres->v_type = V_VPTR;
#else /* Disable arithmetic on addresses */
*vres = error_value(E_INVALID_ADDR_OP);
#endif /* Disable arithmetic on addresses */
return;
case TWOVAL(V_VPTR, V_VPTR):
*vres = error_value(E_INVALID_ADDR_OP);
return;
case TWOVAL(V_OPTR, V_NUM):
q = v2->v_num;
if (qisfrac(q)) {
math_error("Adding non-integer to address");
not_reached();
}
i = qtoi(q);
vres->v_octet = v1->v_octet + i;
vres->v_type = V_OPTR;
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
if (v1->v_type < 0)
return;
if (v2->v_type > 0)
*vres = error_value(E_ADD);
else
vres->v_type = v2->v_type;
return;
}
*vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
return;
}
}
/*
* Subtract one arbitrary value from another one.
* Result is placed in the indicated location.
*/
void
subvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
COMPLEX *c;
NUMBER *q;
int i;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qsub(v1->v_num, v2->v_num);
return;
case TWOVAL(V_COM, V_NUM):
vres->v_com = c_subq(v1->v_com, v2->v_num);
return;
case TWOVAL(V_NUM, V_COM):
c = c_subq(v2->v_com, v1->v_num);
vres->v_type = V_COM;
vres->v_com = c_neg(c);
comfree(c);
return;
case TWOVAL(V_COM, V_COM):
vres->v_com = c_sub(v1->v_com, v2->v_com);
c = vres->v_com;
if (!cisreal(c))
return;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
return;
case TWOVAL(V_MAT, V_MAT):
vres->v_mat = matsub(v1->v_mat, v2->v_mat);
return;
case TWOVAL(V_STR, V_STR):
vres->v_str = stringsub(v1->v_str, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRSUB);
return;
case TWOVAL(V_VPTR, V_NUM):
#if defined(PERMIT_DANGEROUS_ADDRESS_ARITHMETIC)
/* NOTE: Defining PERMIT_DANGEROUS_ADDRESS_ARITHMETIC is NOT supported! */
q = v2->v_num;
if (qisfrac(q)) {
math_error("Subtracting non-integer from address");
not_reached();
}
i = qtoi(q);
vres->v_addr = v1->v_addr - i;
vres->v_type = V_VPTR;
#else /* Disable arithmetic on addresses */
*vres = error_value(E_INVALID_ADDR_OP);
#endif /* Disable arithmetic on addresses */
return;
case TWOVAL(V_OPTR, V_NUM):
q = v2->v_num;
if (qisfrac(q)) {
math_error("Adding non-integer to address");
not_reached();
}
i = qtoi(q);
vres->v_octet = v1->v_octet - i;
vres->v_type = V_OPTR;
return;
case TWOVAL(V_VPTR, V_VPTR):
vres->v_type = V_NUM;
vres->v_num = itoq(v1->v_addr - v2->v_addr);
return;
case TWOVAL(V_OPTR, V_OPTR):
vres->v_type = V_NUM;
vres->v_num = itoq(v1->v_octet - v2->v_octet);
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
if (v1->v_type <= 0)
return;
if (v2->v_type <= 0) {
vres->v_type = v2->v_type;
return;
}
*vres = error_value(E_SUB);
return;
}
*vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
return;
}
}
/*
* Multiply two arbitrary values together.
* Result is placed in the indicated location.
*/
void
mulvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
COMPLEX *c;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qmul(v1->v_num, v2->v_num);
return;
case TWOVAL(V_COM, V_NUM):
vres->v_com = c_mulq(v1->v_com, v2->v_num);
break;
case TWOVAL(V_NUM, V_COM):
vres->v_com = c_mulq(v2->v_com, v1->v_num);
vres->v_type = V_COM;
break;
case TWOVAL(V_COM, V_COM):
vres->v_com = c_mul(v1->v_com, v2->v_com);
break;
case TWOVAL(V_MAT, V_MAT):
vres->v_mat = matmul(v1->v_mat, v2->v_mat);
return;
case TWOVAL(V_MAT, V_NUM):
case TWOVAL(V_MAT, V_COM):
vres->v_mat = matmulval(v1->v_mat, v2);
return;
case TWOVAL(V_NUM, V_MAT):
case TWOVAL(V_COM, V_MAT):
vres->v_mat = matmulval(v2->v_mat, v1);
vres->v_type = V_MAT;
return;
case TWOVAL(V_NUM, V_STR):
vres->v_type = V_STR;
vres->v_str = stringmul(v1->v_num, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRMUL);
return;
case TWOVAL(V_STR, V_NUM):
vres->v_str= stringmul(v2->v_num, v1->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRMUL);
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
if (v1->v_type <= 0)
return;
if (v2->v_type <= 0) {
vres->v_type = v2->v_type;
return;
}
*vres = error_value(E_MUL);
return;
}
*vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
return;
}
c = vres->v_com;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
}
/*
* Square an arbitrary value.
* Result is placed in the indicated location.
*/
void
squarevalue(VALUE *vp, VALUE *vres)
{
COMPLEX *c;
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qsquare(vp->v_num);
return;
case V_COM:
vres->v_com = c_square(vp->v_com);
c = vres->v_com;
if (!cisreal(c))
return;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
return;
case V_MAT:
vres->v_mat = matsquare(vp->v_mat);
return;
case V_OBJ:
*vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type <= 0) {
vres->v_type = vp->v_type;
return;
}
*vres = error_value(E_SQUARE);
return;
}
}
/*
* Invert an arbitrary value.
* Result is placed in the indicated location.
*/
void
invertvalue(VALUE *vp, VALUE *vres)
{
NUMBER *q1, *q2;
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
if (qiszero(vp->v_num))
*vres = error_value(E_DIVBYZERO);
else
vres->v_num = qinv(vp->v_num);
return;
case V_COM:
vres->v_com = c_inv(vp->v_com);
return;
case V_MAT:
vres->v_mat = matinv(vp->v_mat);
return;
case V_OCTET:
if (*vp->v_octet == 0) {
*vres = error_value(E_DIVBYZERO);
return;
}
q1 = itoq((long) *vp->v_octet);
q2 = qinv(q1);
qfree(q1);
vres->v_num = q2;
vres->v_type = V_NUM;
return;
case V_OBJ:
*vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type == -E_DIVBYZERO) {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
return;
}
if (vp->v_type <= 0)
return;
*vres = error_value(E_INV);
return;
}
}
/*
* "AND" two arbitrary values together.
* Result is placed in the indicated location.
*/
void
andvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type == V_NULL) {
copyvalue(v2, vres);
return;
}
if (v2->v_type == V_NULL) {
copyvalue(v1, vres);
return;
}
vres->v_type = v1->v_type;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qand(v1->v_num, v2->v_num);
return;
case TWOVAL(V_STR, V_STR):
vres->v_str = stringand(v1->v_str, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRAND);
return;
case TWOVAL(V_OCTET, V_OCTET):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet & *v2->v_octet);
return;
case TWOVAL(V_STR, V_OCTET):
vres->v_str = charstring(*v1->v_str->s_str &
*v2->v_octet);
return;
case TWOVAL(V_OCTET, V_STR):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet &
*v2->v_str->s_str);
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
if (v1->v_type < 0)
return;
if (v2->v_type < 0) {
vres->v_type = v2->v_type;
return;
}
*vres = error_value(E_AND);
return;
}
*vres = objcall(OBJ_AND, v1, v2, NULL_VALUE);
return;
}
}
/*
* "OR" two arbitrary values together.
* Result is placed in the indicated location.
*/
void
orvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
if (v1->v_type == V_NULL) {
copyvalue(v2, vres);
return;
}
if (v2->v_type == V_NULL) {
copyvalue(v1, vres);
return;
}
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qor(v1->v_num, v2->v_num);
return;
case TWOVAL(V_STR, V_STR):
vres->v_str = stringor(v1->v_str, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STROR);
return;
case TWOVAL(V_OCTET, V_OCTET):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet | *v2->v_octet);
return;
case TWOVAL(V_STR, V_OCTET):
vres->v_str = charstring(*v1->v_str->s_str |
*v2->v_octet);
return;
case TWOVAL(V_OCTET, V_STR):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet |
*v2->v_str->s_str);
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
if (v1->v_type < 0)
return;
if (v2->v_type < 0) {
vres->v_type = v2->v_type;
return;
}
*vres = error_value(E_OR);
return;
}
*vres = objcall(OBJ_OR, v1, v2, NULL_VALUE);
return;
}
}
/*
* "~" two values, returns the "symmetric difference" bitwise xor(v1, v2) for
* strings, octets and real numbers, and a user-defined function if at least
* one of v1 and v2 is an object.
*/
void
xorvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case (TWOVAL(V_NUM, V_NUM)):
vres->v_num = qxor(v1->v_num, v2->v_num);
return;
case (TWOVAL(V_STR, V_STR)):
vres->v_str = stringxor(v1->v_str, v2->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRDIFF);
return;
case (TWOVAL(V_STR, V_OCTET)):
if (v1->v_str->s_len) {
vres->v_str = stringcopy(v1->v_str);
*vres->v_str->s_str ^= *v2->v_octet;
} else {
vres->v_str = charstring(*v2->v_octet);
}
return;
case (TWOVAL(V_OCTET, V_STR)):
if (v2->v_str->s_len) {
vres->v_str = stringcopy(v2->v_str);
*vres->v_str->s_str ^= *v1->v_octet;
} else {
vres->v_str = charstring(*v1->v_octet);
}
return;
case (TWOVAL(V_OCTET, V_OCTET)):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet ^ *v2->v_octet);
return;
default:
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
*vres = objcall(OBJ_XOR, v1, v2, NULL_VALUE);
else
*vres = error_value(E_XOR);
}
}
/*
* "#" two values - abs(v1-v2) for numbers, user-defined for objects
*/
void
hashopvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
NUMBER *q;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
q = qsub(v1->v_num, v2->v_num);
vres->v_num = qqabs(q);
qfree(q);
return;
default:
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
*vres = objcall(OBJ_HASHOP, v1, v2, NULL_VALUE);
else
*vres = error_value(E_HASHOP);
}
}
void
compvalue(VALUE *vp, VALUE *vres)
{
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qcomp(vp->v_num);
return;
case V_STR:
vres->v_str = stringcomp(vp->v_str);
if (vres->v_str == NULL)
*vres = error_value(E_STRCOMP);
return;
case V_OCTET:
vres->v_type = V_STR;
vres->v_str = charstring(~*vp->v_octet);
return;
case V_OBJ:
*vres = objcall(OBJ_COMP, vp, NULL_VALUE, NULL_VALUE);
return;
default:
*vres = error_value(E_COMP);
}
}
/*
* "\" a value, user-defined only
*/
void
backslashvalue(VALUE *vp, VALUE *vres)
{
if (vp->v_type == V_OBJ)
*vres = objcall(OBJ_BACKSLASH, vp, NULL_VALUE, NULL_VALUE);
else
*vres = error_value(E_BACKSLASH);
}
/*
* "\" two values, for strings performs bitwise "AND-NOT" operation
* User defined for objects
*/
void
setminusvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qandnot(v1->v_num, v2->v_num);
return;
case TWOVAL(V_STR, V_STR):
vres->v_str = stringdiff(v1->v_str, v2->v_str);
return;
case TWOVAL(V_STR, V_OCTET):
vres->v_str = charstring(*v1->v_str->s_str &
~*v2->v_octet);
return;
case TWOVAL(V_OCTET, V_STR):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet &
~*v2->v_str->s_str);
return;
case TWOVAL(V_OCTET, V_OCTET):
vres->v_type = V_STR;
vres->v_str = charstring(*v1->v_octet &
~*v2->v_octet);
return;
default:
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
*vres = objcall(OBJ_SETMINUS, v1, v2,
NULL_VALUE);
else
*vres = error_value(E_SETMINUS);
}
}
/*
* "#" a value, for strings and octets returns the number of nonzero bits
* in the value; user-defined for an object
*/
void
contentvalue(VALUE *vp, VALUE *vres)
{
long count;
unsigned char u;
vres->v_type = V_NUM;
vres->v_subtype = V_NOSUBTYPE;
count = 0;
switch (vp->v_type) {
case V_STR:
count = stringcontent(vp->v_str);
break;
case V_OCTET:
for (u = *vp->v_octet; u; u >>= 1)
count += (u & 1);
break;
case V_NUM:
count = zpopcnt(vp->v_num->num, 1);
break;
case V_OBJ:
*vres = objcall(OBJ_CONTENT, vp, NULL_VALUE,
NULL_VALUE);
return;
default:
*vres = error_value(E_CONTENT);
return;
}
vres->v_num = itoq(count);
}
/*
* Approximate numbers by multiples of v2 using rounding criterion v3.
* Result is placed in the indicated location.
*/
void
apprvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
NUMBER *e;
long R = 0;
NUMBER *q1, *q2;
COMPLEX *c;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0)
return;
e = NULL;
switch(v2->v_type) {
case V_NUM: e = v2->v_num;
break;
case V_NULL: e = conf->epsilon;
break;
default:
*vres = error_value(E_APPR_2);
return;
}
switch(v3->v_type) {
case V_NUM: if (qisfrac(v3->v_num)) {
*vres = error_value(E_APPR_3);
return;
}
R = qtoi(v3->v_num);
break;
case V_NULL: R = conf->appr;
break;
default:
*vres = error_value(E_APPR_3);
return;
}
if (qiszero(e)) {
copyvalue(v1, vres);
return;
}
switch (v1->v_type) {
case V_NUM:
vres->v_num = qmappr(v1->v_num, e, R);
return;
case V_MAT:
vres->v_mat = matappr(v1->v_mat, v2, v3);
return;
case V_LIST:
vres->v_list = listappr(v1->v_list, v2, v3);
return;
case V_COM:
q1 = qmappr(v1->v_com->real, e, R);
q2 = qmappr(v1->v_com->imag, e, R);
if (qiszero(q2)) {
vres->v_type = V_NUM;
vres->v_num = q1;
qfree(q2);
return;
}
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = q1;
c->imag = q2;
vres->v_com = c;
return;
default:
*vres = error_value(E_APPR_1);
return;
}
}
/*
* Round numbers to number of decimals specified by v2, type of rounding
* specified by v3. Result placed in location vres.
*/
void
roundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
NUMBER *q1, *q2;
COMPLEX *c;
long places, rnd;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type == V_MAT) {
vres->v_mat = matround(v1->v_mat, v2, v3);
return;
}
if (v1->v_type == V_LIST) {
vres->v_list = listround(v1->v_list, v2, v3);
return;
}
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_ROUND, v1, v2, v3);
return;
}
places = 0;
switch (v2->v_type) {
case V_NUM:
if (qisfrac(v2->v_num)) {
*vres = error_value(E_ROUND_2);
return;
}
places = qtoi(v2->v_num);
break;
case V_NULL:
break;
default:
*vres = error_value(E_ROUND_2);
return;
}
rnd = 0;
switch (v3->v_type) {
case V_NUM:
if (qisfrac(v3->v_num)) {
*vres = error_value(E_ROUND_3);
return;
}
rnd = qtoi(v3->v_num);
break;
case V_NULL:
rnd = conf->round;
break;
default:
*vres = error_value(E_ROUND_3);
return;
}
switch(v1->v_type) {
case V_NUM:
vres->v_num = qround(v1->v_num, places, rnd);
return;
case V_COM:
q1 = qround(v1->v_com->real, places, rnd);
q2 = qround(v1->v_com->imag, places, rnd);
if (qiszero(q2)) {
vres->v_type = V_NUM;
vres->v_num = q1;
qfree(q2);
return;
}
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = q1;
c->imag = q2;
vres->v_com = c;
return;
default:
if (v1->v_type <= 0)
return;
*vres = error_value(E_ROUND_1);
return;
}
}
/*
* Round numbers to number of binary digits specified by v2, type of rounding
* specified by v3. Result placed in location vres.
*/
void
broundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
NUMBER *q1, *q2;
COMPLEX *c;
long places, rnd;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type == V_MAT) {
vres->v_mat = matbround(v1->v_mat, v2, v3);
return;
}
if (v1->v_type == V_LIST) {
vres->v_list = listbround(v1->v_list, v2, v3);
return;
}
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_BROUND, v1, v2, v3);
return;
}
places = 0;
switch (v2->v_type) {
case V_NUM:
if (qisfrac(v2->v_num)) {
*vres = error_value(E_BROUND_2);
return;
}
places = qtoi(v2->v_num);
break;
case V_NULL:
break;
default:
*vres = error_value(E_BROUND_2);
return;
}
rnd = 0;
switch (v3->v_type) {
case V_NUM:
if (qisfrac(v3->v_num)) {
*vres = error_value(E_BROUND_3);
return;
}
rnd = qtoi(v3->v_num);
break;
case V_NULL:
rnd = conf->round;
break;
default:
*vres = error_value(E_BROUND_3);
return;
}
switch(v1->v_type) {
case V_NUM:
vres->v_num = qbround(v1->v_num, places, rnd);
return;
case V_COM:
q1 = qbround(v1->v_com->real, places, rnd);
q2 = qbround(v1->v_com->imag, places, rnd);
if (qiszero(q2)) {
vres->v_type = V_NUM;
vres->v_num = q1;
qfree(q2);
return;
}
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = q1;
c->imag = q2;
vres->v_com = c;
return;
default:
if (v1->v_type <= 0)
return;
*vres = error_value(E_BROUND_1);
return;
}
}
/*
* Take the integer part of an arbitrary value.
* Result is placed in the indicated location.
*/
void
intvalue(VALUE *vp, VALUE *vres)
{
COMPLEX *c;
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
if (qisint(vp->v_num))
vres->v_num = qlink(vp->v_num);
else
vres->v_num = qint(vp->v_num);
return;
case V_COM:
if (cisint(vp->v_com)) {
vres->v_com = clink(vp->v_com);
return;
}
vres->v_com = c_int(vp->v_com);
c = vres->v_com;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
return;
case V_MAT:
vres->v_mat = matint(vp->v_mat);
return;
case V_OBJ:
*vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type <= 0)
return;
*vres = error_value(E_INT);
return;
}
}
/*
* Take the fractional part of an arbitrary value.
* Result is placed in the indicated location.
*/
void
fracvalue(VALUE *vp, VALUE *vres)
{
COMPLEX *c;
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
if (qisint(vp->v_num))
vres->v_num = qlink(&_qzero_);
else
vres->v_num = qfrac(vp->v_num);
return;
case V_COM:
if (cisint(vp->v_com)) {
vres->v_num = clink(&_qzero_);
vres->v_type = V_NUM;
return;
}
vres->v_com = c_frac(vp->v_com);
c = vres->v_com;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
return;
case V_MAT:
vres->v_mat = matfrac(vp->v_mat);
return;
case V_OBJ:
*vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type < 0)
return;
*vres = error_value(E_FRAC);
return;
}
}
/*
* Increment an arbitrary value by one.
* Result is placed in the indicated location.
*/
void
incvalue(VALUE *vp, VALUE *vres)
{
vres->v_type = vp->v_type;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qinc(vp->v_num);
break;
case V_COM:
vres->v_com = c_addq(vp->v_com, &_qone_);
break;
case V_OBJ:
*vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
break;
case V_OCTET:
*vres->v_octet = *vp->v_octet + 1;
break;
case V_OPTR:
vres->v_octet = vp->v_octet + 1;
break;
case V_VPTR:
#if defined(PERMIT_DANGEROUS_ADDRESS_ARITHMETIC)
/* NOTE: Defining PERMIT_DANGEROUS_ADDRESS_ARITHMETIC is NOT supported! */
vres->v_addr = vp->v_addr + 1;
#else /* Disable arithmetic on addresses */
*vres = error_value(E_INVALID_ADDR_OP);
#endif /* Disable arithmetic on addresses */
break;
default:
if (vp->v_type > 0)
*vres = error_value(E_INCV);
break;
}
vres->v_subtype = vp->v_subtype;
}
/*
* Decrement an arbitrary value by one.
* Result is placed in the indicated location.
*/
void
decvalue(VALUE *vp, VALUE *vres)
{
vres->v_type = vp->v_type;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qdec(vp->v_num);
break;
case V_COM:
vres->v_com = c_addq(vp->v_com, &_qnegone_);
break;
case V_OBJ:
*vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
break;
case V_OCTET:
*vres->v_octet = *vp->v_octet - 1;
break;
case V_OPTR:
vres->v_octet = vp->v_octet - 1;
break;
case V_VPTR:
#if defined(PERMIT_DANGEROUS_ADDRESS_ARITHMETIC)
/* NOTE: Defining PERMIT_DANGEROUS_ADDRESS_ARITHMETIC is NOT supported! */
vres->v_addr = vp->v_addr - 1;
#else /* Disable arithmetic on addresses */
*vres = error_value(E_INVALID_ADDR_OP);
#endif /* Disable arithmetic on addresses */
break;
default:
if (vp->v_type >= 0)
*vres = error_value(E_DECV);
break;
}
vres->v_subtype = vp->v_subtype;
}
/*
* Produce the 'conjugate' of an arbitrary value.
* Result is placed in the indicated location.
* (Example: complex conjugate.)
*/
void
conjvalue(VALUE *vp, VALUE *vres)
{
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qlink(vp->v_num);
return;
case V_COM:
vres->v_com = comalloc();
qfree(vres->v_com->real);
qfree(vres->v_com->imag)
vres->v_com->real = qlink(vp->v_com->real);
vres->v_com->imag = qneg(vp->v_com->imag);
return;
case V_MAT:
vres->v_mat = matconj(vp->v_mat);
return;
case V_OBJ:
*vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type <= 0) {
vres->v_type = vp->v_type;
return;
}
*vres = error_value(E_CONJ);
return;
}
}
/*
* Take the square root of an arbitrary value within the specified error.
* Result is placed in the indicated location.
*/
void
sqrtvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
NUMBER *q, *tmp;
COMPLEX *c;
long R;
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_SQRT, v1, v2, v3);
return;
}
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
if (v2->v_type == V_NULL) {
q = conf->epsilon;
} else {
if (v2->v_type != V_NUM || qiszero(v2->v_num)) {
*vres = error_value(E_SQRT_2);
return;
}
q = v2->v_num;
}
if (v3->v_type == V_NULL) {
R = conf->sqrt;
} else {
if (v3->v_type != V_NUM || qisfrac(v3->v_num)) {
*vres = error_value(E_SQRT_3);
return;
}
R = qtoi(v3->v_num);
}
switch (v1->v_type) {
case V_NUM:
if (!qisneg(v1->v_num)) {
vres->v_num = qsqrt(v1->v_num, q, R);
return;
}
tmp = qneg(v1->v_num);
c = comalloc();
qfree(c->imag);
c->imag = qsqrt(tmp, q, R);
qfree(tmp);
vres->v_com = c;
vres->v_type = V_COM;
break;
case V_COM:
vres->v_com = c_sqrt(v1->v_com, q, R);
break;
default:
*vres = error_value(E_SQRT_1);
return;
}
c = vres->v_com;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
}
/*
* Take the Nth root of an arbitrary value within the specified error.
* Result is placed in the indicated location.
*
* given:
* v1 value to take root of
* v2 value specifying root to take
* v3 value specifying error
* vres result
*/
void
rootvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
NUMBER *q2, *q3;
COMPLEX ctmp;
COMPLEX *c;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
if (v2->v_type != V_NUM) {
*vres = error_value(E_ROOT_2);
return;
}
q2 = v2->v_num;
if (qisneg(q2) || qiszero(q2) || qisfrac(q2)) {
*vres = error_value(E_ROOT_2);
return;
}
if (v3->v_type != V_NUM || qiszero(v3->v_num)) {
*vres = error_value(E_ROOT_3);
return;
}
q3 = v3->v_num;
switch (v1->v_type) {
case V_NUM:
if (!qisneg(v1->v_num)) {
vres->v_num = qroot(v1->v_num, q2, q3);
if (vres->v_num == NULL)
*vres = error_value(E_ROOT_4);
vres->v_type = V_NUM;
return;
}
ctmp.real = v1->v_num;
ctmp.imag = &_qzero_;
ctmp.links = 1;
c = c_root(&ctmp, q2, q3);
break;
case V_COM:
c = c_root(v1->v_com, q2, q3);
break;
case V_OBJ:
*vres = objcall(OBJ_ROOT, v1, v2, v3);
return;
default:
*vres = error_value(E_ROOT_1);
return;
}
if (c == NULL) {
*vres = error_value(E_ROOT_4);
return;
}
vres->v_com = c;
vres->v_type = V_COM;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
}
/*
* Take the absolute value of an arbitrary value within the specified error.
* Result is placed in the indicated location.
*/
void
absvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
STATIC NUMBER *q;
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
return;
}
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
switch (v1->v_type) {
case V_NUM:
if (qisneg(v1->v_num))
q = qneg(v1->v_num);
else
q = qlink(v1->v_num);
break;
case V_COM:
if (v2->v_type != V_NUM || qiszero(v2->v_num)) {
*vres = error_value(E_ABS_2);
return;
}
q = qhypot(v1->v_com->real, v1->v_com->imag, v2->v_num);
break;
default:
*vres = error_value(E_ABS_1);
return;
}
vres->v_num = q;
vres->v_type = V_NUM;
}
/*
* Calculate the norm of an arbitrary value.
* Result is placed in the indicated location.
* The norm is the square of the absolute value.
*/
void
normvalue(VALUE *vp, VALUE *vres)
{
NUMBER *q1, *q2;
vres->v_type = vp->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (vp->v_type <= 0) {
vres->v_type = vp->v_type;
return;
}
switch (vp->v_type) {
case V_NUM:
vres->v_num = qsquare(vp->v_num);
return;
case V_COM:
q1 = qsquare(vp->v_com->real);
q2 = qsquare(vp->v_com->imag);
vres->v_num = qqadd(q1, q2);
vres->v_type = V_NUM;
qfree(q1);
qfree(q2);
return;
case V_OBJ:
*vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
return;
default:
*vres = error_value(E_NORM);
return;
}
}
/*
* Shift a value left or right by the specified number of bits.
* Negative shift value means shift the direction opposite the selected dir.
* Right shifts are defined to lose bits off the low end of the number.
* Result is placed in the indicated location.
*
* given:
* v1 value to shift
* v2 shift amount
* rightshift true if shift right instead of left
* vres result
*/
void
shiftvalue(VALUE *v1, VALUE *v2, bool rightshift, VALUE *vres)
{
COMPLEX *c;
long n = 0;
unsigned int ch;
VALUE tmp;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
if ((v2->v_type != V_NUM) || (qisfrac(v2->v_num))) {
*vres = error_value(E_SHIFT_2);
return;
}
if (v1->v_type != V_OBJ) {
if (zge31b(v2->v_num->num)) {
*vres = error_value(E_SHIFT_2);
return;
}
n = qtoi(v2->v_num);
}
if (rightshift)
n = -n;
vres->v_type = v1->v_type;
switch (v1->v_type) {
case V_NUM:
if (qisfrac(v1->v_num)) {
*vres = error_value(E_SHIFT_1);
return;
}
vres->v_num = qshift(v1->v_num, n);
return;
case V_COM:
if (qisfrac(v1->v_com->real) ||
qisfrac(v1->v_com->imag)) {
*vres = error_value(E_SHIFT_1);
return;
}
c = c_shift(v1->v_com, n);
if (!cisreal(c)) {
vres->v_com = c;
return;
}
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
return;
case V_MAT:
vres->v_mat = matshift(v1->v_mat, n);
return;
case V_STR:
vres->v_str = stringshift(v1->v_str, n);
if (vres->v_str == NULL)
*vres = error_value(E_STRSHIFT);
return;
case V_OCTET:
vres->v_type = V_STR;
if (n >= 8 || n <= -8)
ch = 0;
else if (n >= 0)
ch = (unsigned int) *v1->v_octet << n;
else
ch = (unsigned int) *v1->v_octet >> -n;
vres->v_str = charstring(ch);
return;
case V_OBJ:
if (!rightshift) {
*vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
return;
}
tmp.v_num = qneg(v2->v_num);
tmp.v_type = V_NUM;
*vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
qfree(tmp.v_num);
return;
default:
*vres = error_value(E_SHIFT_1);
return;
}
}
/*
* Scale a value by a power of two.
* Result is placed in the indicated location.
*/
void
scalevalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
long n = 0;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) {
*vres = error_value(E_SCALE_2);
return;
}
if (v1->v_type != V_OBJ) {
if (zge31b(v2->v_num->num)) {
*vres = error_value(E_SCALE_2);
return;
}
n = qtoi(v2->v_num);
}
vres->v_type = v1->v_type;
switch (v1->v_type) {
case V_NUM:
vres->v_num = qscale(v1->v_num, n);
return;
case V_COM:
vres->v_com = c_scale(v1->v_com, n);
return;
case V_MAT:
vres->v_mat = matscale(v1->v_mat, n);
return;
case V_OBJ:
*vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
return;
default:
*vres = error_value(E_SCALE_1);
return;
}
}
/*
* Raise a value to an power.
* Result is placed in the indicated location.
*/
void
powvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
NUMBER *real_v2; /* real part of v2 */
COMPLEX *c;
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
return;
}
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0 && v1->v_type != -E_DIVBYZERO)
return;
if (v2->v_type <= 0) {
vres->v_type = v2->v_type;
return;
}
real_v2 = v2->v_num;
/* case: raising to a real power */
switch (v2->v_type) {
case V_NUM:
/* deal with the division by 0 value */
if (v1->v_type == -E_DIVBYZERO) {
if (qisneg(real_v2)) {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
} else {
vres->v_type = -E_DIVBYZERO;
}
break;
}
/* raise something with a real exponent */
switch (v1->v_type) {
case V_NUM:
if (qiszero(v1->v_num)) {
if (qisneg(real_v2)) {
*vres = error_value(E_DIVBYZERO);
break;
}
vres->v_type = V_NUM;
if (qiszero(v2->v_num)) {
/* 0 ^ 0 is 1 */
vres->v_num = qlink(&_qone_);
} else {
/* 0 ^ (exp>0) is 0 */
vres->v_num = qlink(&_qzero_);
}
} else if (qisint(real_v2)) {
vres->v_num = qpowi(v1->v_num, real_v2);
} else {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
powervalue(v1, v2, NULL, vres);
}
break;
case V_COM:
if (qisint(real_v2)) {
vres->v_com = c_powi(v1->v_com, real_v2);
} else {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
powervalue(v1, v2, NULL, vres);
}
if (vres->v_type == V_COM) {
c = vres->v_com;
if (!cisreal(c))
break;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
break;
case V_MAT:
vres->v_mat = matpowi(v1->v_mat, real_v2);
break;
default:
*vres = error_value(E_POWI_1);
break;
}
break;
case V_COM:
/* deal with the division by 0 value */
if (v1->v_type == -E_DIVBYZERO) {
if (cisreal(v2->v_com) && qisneg(real_v2)) {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
} else {
vres->v_type = -E_DIVBYZERO;
}
break;
}
/* raise something with a real exponent */
switch (v1->v_type) {
case V_NUM:
if (qiszero(v1->v_num)) {
if (cisreal(v2->v_com) && qisneg(real_v2)) {
*vres = error_value(E_DIVBYZERO);
break;
}
/*
* 0 ^ real non-neg is zero
* 0 ^ complex is zero
*/
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
}
if (cisreal(v2->v_com) && qisint(real_v2)) {
vres->v_num = qpowi(v1->v_num, real_v2);
} else {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
powervalue(v1, v2, NULL, vres);
}
if (vres->v_type == V_COM) {
c = vres->v_com;
if (!cisreal(c))
break;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
break;
case V_COM:
if (cisreal(v2->v_com) && qisint(real_v2)) {
vres->v_com = c_powi(v1->v_com, real_v2);
} else {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
powervalue(v1, v2, NULL, vres);
}
if (vres->v_type == V_COM) {
c = vres->v_com;
if (!cisreal(c))
break;
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
break;
default:
*vres = error_value(E_POWI_1);
break;
}
break;
/* unsupported exponent type */
default:
*vres = error_value(E_POWI_2);
break;
}
return;
}
/*
* Raise one value to another value's power, within the specified error.
* Result is placed in the indicated location. If v3 is NULL, the
* value conf->epsilon is used.
*/
void
powervalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
NUMBER *epsilon;
COMPLEX *c, ctmp1, ctmp2;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0) {
vres->v_type = v1->v_type;
return;
}
if (v1->v_type != V_NUM && v1->v_type != V_COM) {
*vres = error_value(E_POWER_1);
return;
}
if (v2->v_type != V_NUM && v2->v_type != V_COM) {
*vres = error_value(E_POWER_2);
return;
}
/* NULL epsilon means use built-in epsilon value */
if (v3 == NULL) {
epsilon = conf->epsilon;
} else {
if (v3->v_type != V_NUM || qiszero(v3->v_num)) {
*vres = error_value(E_POWER_3);
return;
}
epsilon = v3->v_num;
}
if (qiszero(epsilon)) {
*vres = error_value(E_POWER_3);
return;
}
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
if (qisneg(v1->v_num)) {
ctmp1.real = v1->v_num;
ctmp1.imag = &_qzero_;
ctmp1.links = 1;
ctmp2.real = v2->v_num;
ctmp2.imag = &_qzero_;
ctmp2.links = 1;
c = c_power(&ctmp1, &ctmp2, epsilon);
break;
}
vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
vres->v_type = V_NUM;
if (vres->v_num == NULL)
*vres = error_value(E_POWER_4);
return;
case TWOVAL(V_NUM, V_COM):
ctmp1.real = v1->v_num;
ctmp1.imag = &_qzero_;
ctmp1.links = 1;
c = c_power(&ctmp1, v2->v_com, epsilon);
break;
case TWOVAL(V_COM, V_NUM):
ctmp2.real = v2->v_num;
ctmp2.imag = &_qzero_;
ctmp2.links = 1;
c = c_power(v1->v_com, &ctmp2, epsilon);
break;
case TWOVAL(V_COM, V_COM):
c = c_power(v1->v_com, v2->v_com, epsilon);
break;
default:
*vres = error_value(E_POWER_1);
return;
}
/*
* Here for any complex result.
*/
vres->v_type = V_COM;
vres->v_com = c;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
}
/*
* Divide one arbitrary value by another one.
* Result is placed in the indicated location.
*/
void
divvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
unsigned int twoval_as_uint; /* TWOVAL(a,b) or TWOVAL_INVALID */
COMPLEX *c;
COMPLEX ctmp;
NUMBER *q;
VALUE tmpval;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0)
return;
if (v2->v_type <= 0) {
if (testvalue(v1) && v2->v_type == -E_DIVBYZERO) {
vres->v_type = V_NUM;
vres->v_num = qlink(&_qzero_);
}
else
vres->v_type = v2->v_type;
return;
}
if (!testvalue(v2)) {
if (testvalue(v1))
*vres = error_value(E_DIVBYZERO);
else
*vres = error_value(E_ZERODIVZERO);
return;
}
vres->v_type = v1->v_type;
twoval_as_uint = TWOVAL_AS_UINT(v1->v_type, v2->v_type);
switch (twoval_as_uint) {
case TWOVAL(V_NUM, V_NUM):
vres->v_num = qqdiv(v1->v_num, v2->v_num);
return;
case TWOVAL(V_COM, V_NUM):
vres->v_com = c_divq(v1->v_com, v2->v_num);
return;
case TWOVAL(V_NUM, V_COM):
if (qiszero(v1->v_num)) {
vres->v_num = qlink(&_qzero_);
return;
}
ctmp.real = v1->v_num;
ctmp.imag = &_qzero_;
ctmp.links = 1;
vres->v_com = c_div(&ctmp, v2->v_com);
vres->v_type = V_COM;
return;
case TWOVAL(V_COM, V_COM):
vres->v_com = c_div(v1->v_com, v2->v_com);
c = vres->v_com;
if (cisreal(c)) {
vres->v_num = qlink(c->real);
vres->v_type = V_NUM;
comfree(c);
}
return;
case TWOVAL(V_MAT, V_NUM):
case TWOVAL(V_MAT, V_COM):
invertvalue(v2, &tmpval);
vres->v_mat = matmulval(v1->v_mat, &tmpval);
freevalue(&tmpval);
return;
case TWOVAL(V_STR, V_NUM):
q = qinv(v2->v_num);
vres->v_str = stringmul(q, v1->v_str);
qfree(q);
if (vres->v_str == NULL)
*vres = error_value(E_DIV);
return;
default:
if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
*vres = error_value(E_DIV);
return;
}
*vres = objcall(OBJ_DIV, v1, v2, NULL_VALUE);
return;
}
}
/*
* Divide one arbitrary value by another one keeping only the integer part.
* Result is placed in the indicated location.
*/
void
quovalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
COMPLEX *c;
NUMBER *q1, *q2;
long rnd;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0)
return;
if (v1->v_type == V_MAT) {
vres->v_mat = matquoval(v1->v_mat, v2, v3);
return;
}
if (v1->v_type == V_LIST) {
vres->v_list = listquo(v1->v_list, v2, v3);
return;
}
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_QUO, v1, v2, v3);
return;
}
if (v2->v_type <= 0) {
vres->v_type = v2->v_type;
return;
}
if (v2->v_type != V_NUM) {
*vres = error_value(E_QUO_2);
return;
}
rnd = 0;
switch (v3->v_type) {
case V_NUM:
if (qisfrac(v3->v_num)) {
*vres = error_value(E_QUO_3);
return;
}
rnd = qtoi(v3->v_num);
break;
case V_NULL:
rnd = conf->quo;
break;
default:
*vres = error_value(E_QUO_3);
return;
}
switch (v1->v_type) {
case V_NUM:
vres->v_num = qquo(v1->v_num, v2->v_num, rnd);
return;
case V_COM:
q1 = qquo(v1->v_com->real, v2->v_num, rnd);
q2 = qquo(v1->v_com->imag, v2->v_num, rnd);
if (qiszero(q2)) {
qfree(q2);
vres->v_type = V_NUM;
vres->v_num = q1;
return;
}
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = q1;
c->imag = q2;
vres->v_com = c;
return;
default:
*vres = error_value(E_QUO_1);
return;
}
}
/*
* Divide one arbitrary value by another one keeping only the remainder.
* Result is placed in the indicated location.
*/
void
modvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
{
COMPLEX *c;
NUMBER *q1, *q2;
long rnd;
vres->v_type = v1->v_type;
vres->v_subtype = V_NOSUBTYPE;
if (v1->v_type <= 0)
return;
if (v1->v_type == V_MAT) {
vres->v_mat = matmodval(v1->v_mat, v2, v3);
return;
}
if (v1->v_type == V_LIST) {
vres->v_list = listmod(v1->v_list, v2, v3);
return;
}
if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
*vres = objcall(OBJ_MOD, v1, v2, v3);
return;
}
if (v2->v_type <= 0) {
vres->v_type = v2->v_type;
return;
}
if (v2->v_type != V_NUM) {
*vres = error_value(E_MOD_2);
return;
}
rnd = 0;
switch (v3->v_type) {
case V_NUM:
if (qisfrac(v3->v_num)) {
*vres = error_value(E_MOD_3);
return;
}
rnd = qtoi(v3->v_num);
break;
case V_NULL:
rnd = conf->mod;
break;
default:
*vres = error_value(E_MOD_3);
return;
}
switch (v1->v_type) {
case V_NUM:
vres->v_num = qmod(v1->v_num, v2->v_num, rnd);
return;
case V_COM:
q1 = qmod(v1->v_com->real, v2->v_num, rnd);
q2 = qmod(v1->v_com->imag, v2->v_num, rnd);
if (qiszero(q2)) {
qfree(q2);
vres->v_type = V_NUM;
vres->v_num = q1;
return;
}
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = q1;
c->imag = q2;
vres->v_com = c;
return;
default:
*vres = error_value(E_MOD_1);
return;
}
}
/*
* Test an arbitrary value to see if it is equal to "zero".
* The definition of zero varies depending on the value type. For example,
* the null string is "zero", and a matrix with zero values is "zero".
* Returns true if value is not equal to zero.
*/
bool
testvalue(VALUE *vp)
{
VALUE val;
LISTELEM *ep;
int i;
switch (vp->v_type) {
case V_NUM:
return !qiszero(vp->v_num);
case V_COM:
return !ciszero(vp->v_com);
case V_STR:
return stringtest(vp->v_str);
case V_MAT:
return mattest(vp->v_mat);
case V_LIST:
for (ep = vp->v_list->l_first; ep; ep = ep->e_next) {
if (testvalue(&ep->e_value))
return true;
}
return false;
case V_ASSOC:
return (vp->v_assoc->a_count != 0);
case V_FILE:
return validid(vp->v_file);
case V_NULL:
break;
case V_OBJ:
val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
return (val.v_int != 0);
case V_BLOCK:
for (i=0; i < vp->v_block->datalen; ++i) {
if (vp->v_block->data[i]) {
return true;
}
}
return false;
case V_OCTET:
return (*vp->v_octet != 0);
case V_NBLOCK:
if (vp->v_nblock->blk->data == NULL)
return false;
for (i=0; i < vp->v_nblock->blk->datalen; ++i) {
if (vp->v_nblock->blk->data[i]) {
return true;
}
}
return false;
default:
return true;
}
return false;
}
/*
* Compare two values for equality.
* Returns true if the two values differ.
*/
bool
comparevalue(VALUE *v1, VALUE *v2)
{
int r = false;
VALUE val;
if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
val = objcall(OBJ_CMP, v1, v2, NULL_VALUE);
return (val.v_int != 0);
}
if (v1 == v2)
return false;
if (v1->v_type == V_OCTET) {
if (v2->v_type == V_OCTET)
return (*v1->v_octet != *v2->v_octet);
if (v2->v_type == V_STR)
return (*v1->v_octet != (OCTET) *v2->v_str->s_str)
|| (v2->v_str->s_len != 1);
if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
qisneg(v2->v_num) || v2->v_num->num.len > 1)
return true;
return (*v2->v_num->num.v != *v1->v_octet);
}
if (v2->v_type == V_OCTET)
return comparevalue(v2, v1);
if (v1->v_type != v2->v_type)
return true;
if (v1->v_type <= 0)
return false;
switch (v1->v_type) {
case V_NUM:
r = qcmp(v1->v_num, v2->v_num);
break;
case V_COM:
r = c_cmp(v1->v_com, v2->v_com);
break;
case V_STR:
r = stringcmp(v1->v_str, v2->v_str);
break;
case V_MAT:
r = matcmp(v1->v_mat, v2->v_mat);
break;
case V_LIST:
r = listcmp(v1->v_list, v2->v_list);
break;
case V_ASSOC:
r = assoccmp(v1->v_assoc, v2->v_assoc);
break;
case V_FILE:
r = (v1->v_file != v2->v_file);
break;
case V_RAND:
r = randcmp(v1->v_rand, v2->v_rand);
break;
case V_RANDOM:
r = randomcmp(v1->v_random, v2->v_random);
break;
case V_CONFIG:
r = config_cmp(v1->v_config, v2->v_config);
break;
case V_HASH:
r = hash_cmp(v1->v_hash, v2->v_hash);
break;
case V_BLOCK:
r = blk_cmp(v1->v_block, v2->v_block);
break;
case V_OCTET:
r = (v1->v_octet != v2->v_octet);
break;
case V_NBLOCK:
return (v1->v_nblock != v2->v_nblock);
case V_VPTR:
return (v1->v_addr != v2->v_addr);
case V_OPTR:
return (v1->v_octet != v2->v_octet);
case V_SPTR:
return (v1->v_str != v2->v_str);
case V_NPTR:
return (v1->v_num != v2->v_num);
default:
math_error("Illegal values for comparevalue");
not_reached();
}
return (r != 0);
}
bool
acceptvalue(VALUE *v1, VALUE *v2)
{
long index;
FUNC *fp;
bool ret;
index = adduserfunc("accept");
fp = findfunc(index);
if (fp) {
++stack;
stack->v_type = V_ADDR;
stack->v_subtype = V_NOSUBTYPE;
stack->v_addr = v1;
++stack;
stack->v_type = V_ADDR;
stack->v_subtype = V_NOSUBTYPE;
stack->v_addr = v2;
calculate(fp, 2);
ret = testvalue(stack);
freevalue(stack--);
return ret;
}
return (!comparevalue(v1, v2));
}
bool
precvalue(VALUE *v1, VALUE *v2)
{
VALUE val;
long index;
int r = 0;
FUNC *fp;
bool ret;
index = adduserfunc("precedes");
fp = findfunc(index);
if (fp) {
++stack;
stack->v_type = V_ADDR;
stack->v_subtype = V_NOSUBTYPE;
stack->v_addr = v1;
++stack;
stack->v_type = V_ADDR;
stack->v_subtype = V_NOSUBTYPE;
stack->v_addr = v2;
calculate(fp, 2);
ret = testvalue(stack);
freevalue(stack--);
return ret;
}
relvalue(v1, v2, &val);
if ((val.v_type == V_NUM && qisneg(val.v_num)) ||
(val.v_type == V_COM && qisneg(val.v_com->imag)))
r = 1;
if (val.v_type == V_NULL)
r = (v1->v_type < v2->v_type);
freevalue(&val);
return r;
}
VALUE
signval(int r)
{
VALUE val;
val.v_type = V_NUM;
val.v_subtype = V_NOSUBTYPE;
if (r > 0)
val.v_num = qlink(&_qone_);
else if (r < 0)
val.v_num = qlink(&_qnegone_);
else
val.v_num = qlink(&_qzero_);
return val;
}
/*
* Compare two values for their relative values.
* Result is placed in the indicated location.
*/
void
relvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
int r = 0;
int i = 0;
NUMBER *q;
COMPLEX *c;
vres->v_subtype = V_NOSUBTYPE;
vres->v_type = V_NULL;
if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
*vres = objcall(OBJ_REL, v1, v2, NULL_VALUE);
return;
}
switch(v1->v_type) {
case V_NUM:
switch(v2->v_type) {
case V_NUM:
r = qrel(v1->v_num, v2->v_num);
break;
case V_OCTET:
q = itoq((long) *v2->v_octet);
r = qrel(v1->v_num, q);
qfree(q);
break;
case V_COM:
r = qrel(v1->v_num, v2->v_com->real);
i = qrel(&_qzero_, v2->v_com->imag);
break;
default:
return;
}
break;
case V_COM:
switch(v2->v_type) {
case V_NUM:
r = qrel(v1->v_com->real, v2->v_num);
i = qrel(v1->v_com->imag, &_qzero_);
break;
case V_COM:
r = qrel(v1->v_com->real, v2->v_com->real);
i = qrel(v1->v_com->imag, v2->v_com->imag);
break;
case V_OCTET:
q = itoq((long) *v2->v_octet);
r = qrel(v1->v_com->real, q);
qfree(q);
i = qrel(v1->v_com->imag, &_qzero_);
break;
default:
return;
}
break;
case V_STR:
switch(v2->v_type) {
case V_STR:
r = stringrel(v1->v_str, v2->v_str);
break;
case V_OCTET:
r = (unsigned char) *v1->v_str->s_str
- *v2->v_octet;
if (r == 0) {
if (v1->v_str->s_len == 0)
r = -1;
else
r = (v1->v_str->s_len > 1);
}
break;
default:
return;
}
break;
case V_OCTET:
switch(v2->v_type) {
case V_NUM:
q = itoq((long) *v1->v_octet);
r = qrel(q, v2->v_num);
qfree(q);
break;
case V_COM:
q = itoq((long) *v1->v_octet);
r = qrel(q, v2->v_com->real);
qfree(q);
i = qrel(&_qzero_, v2->v_com->imag);
break;
case V_OCTET:
r = *v1->v_octet - *v2->v_octet;
break;
case V_STR:
r = *v1->v_octet -
(unsigned char) *v2->v_str->s_str;
if (r == 0) {
if (v2->v_str->s_len == 0)
r = 1;
else
r = -(v2->v_str->s_len > 1);
}
break;
default:
return;
}
break;
case V_VPTR:
if (v2->v_type != V_VPTR)
return;
r = (v1->v_addr - v2->v_addr);
break;
case V_OPTR:
if (v2->v_type != V_OPTR)
return;
r = (v1->v_octet - v2->v_octet);
break;
default:
return;
}
vres->v_type = V_NUM;
*vres = signval(r);
if (i == 0)
return;
c = comalloc();
qfree(c->real);
c->real = vres->v_num;
*vres = signval(i);
qfree(c->imag);
c->imag = vres->v_num;
vres->v_type = V_COM;
vres->v_com = c;
return;
}
/*
* Find a value representing sign or signs in a value
* Result is placed in the indicated location.
*/
void
sgnvalue(VALUE *vp, VALUE *vres)
{
COMPLEX *c;
vres->v_type = vp->v_type;
switch (vp->v_type) {
case V_NUM:
vres->v_num = qsign(vp->v_num);
vres->v_subtype = vp->v_subtype;
return;
case V_COM:
c = comalloc();
qfree(c->real);
qfree(c->imag);
c->real = qsign(vp->v_com->real);
c->imag = qsign(vp->v_com->imag);
vres->v_com = c;
vres->v_type = V_COM;
vres->v_subtype = V_NOSUBTYPE;
return;
case V_OCTET:
vres->v_type = V_NUM;
vres->v_subtype = V_NOSUBTYPE;
vres->v_num = itoq((long) (*vp->v_octet != 0));
return;
case V_OBJ:
*vres = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
return;
default:
if (vp->v_type > 0)
*vres = error_value(E_SGN);
return;
}
}
int
userfunc(char *fname, VALUE *vp)
{
FUNC *fp;
fp = findfunc(adduserfunc(fname));
if (fp == NULL)
return 0;
++stack;
stack->v_addr = vp;
stack->v_type = V_ADDR;
stack->v_subtype = V_NOSUBTYPE;
calculate(fp, 1);
freevalue(stack--);
return 1;
}
/*
* Print the value of a descriptor in one of several formats.
* If flags contains PRINT_SHORT, then elements of arrays and lists
* will not be printed. If flags contains PRINT_UNAMBIG, then quotes
* are placed around strings and the null value is explicitly printed.
*/
void
printvalue(VALUE *vp, int flags)
{
NUMBER *qtemp;
int type;
char *errsym;
bool alloced;
type = vp->v_type;
if (type < 0) {
if (userfunc("error_print", vp)) {
return;
}
errsym = errnum_2_errsym(-type, &alloced);
if (errsym == NULL) {
if (-type >= E__BASE) {
math_fmt("Error %d", -type);
} else {
math_fmt("System error %d", -type);
}
} else {
if (-type >= E__BASE) {
math_fmt("Error %s", errsym);
} else {
math_fmt("System error %s", errsym);
}
if (alloced == true) {
free(errsym);
}
}
return;
}
switch (type) {
case V_NUM:
qprintnum(vp->v_num, MODE_DEFAULT, conf->outdigits);
if (conf->traceflags & TRACE_LINKS)
math_fmt("#%ld", vp->v_num->links);
break;
case V_COM:
comprint(vp->v_com);
if (conf->traceflags & TRACE_LINKS)
math_fmt("##%ld", vp->v_com->links);
break;
case V_STR:
if (flags & PRINT_UNAMBIG)
math_chr('\"');
math_str(vp->v_str->s_str);
if (flags & PRINT_UNAMBIG)
math_chr('\"');
break;
case V_NULL:
if (flags & PRINT_UNAMBIG)
math_str("NULL");
break;
case V_OBJ:
(void) objcall(OBJ_PRINT, vp, NULL_VALUE, NULL_VALUE);
break;
case V_LIST:
if (!userfunc("list_print", vp))
listprint(vp->v_list,
((flags & PRINT_SHORT) ? 0L : conf->maxprint));
break;
case V_ASSOC:
assocprint(vp->v_assoc,
((flags & PRINT_SHORT) ? 0L : conf->maxprint));
break;
case V_MAT:
if (!userfunc("mat_print", vp))
matprint(vp->v_mat,
((flags & PRINT_SHORT) ? 0L : conf->maxprint));
break;
case V_FILE:
if (!userfunc("file_print", vp))
printid(vp->v_file, flags);
break;
case V_RAND:
randprint(vp->v_rand, flags);
break;
case V_RANDOM:
randomprint(vp->v_random, flags);
break;
case V_CONFIG:
config_print(vp->v_config);
break;
case V_HASH:
hash_print(vp->v_hash);
break;
case V_BLOCK:
if (!userfunc("blk_print", vp))
blk_print(vp->v_block);
break;
case V_OCTET:
if (userfunc("octet_print", vp))
break;
qtemp = itoq((long) *vp->v_octet);
qprintnum(qtemp, MODE_DEFAULT, conf->outdigits);
qfree(qtemp);
break;
case V_OPTR:
math_fmt("o-ptr: %p", (void *)vp->v_octet);
break;
case V_VPTR:
math_fmt("v-ptr: %p", (void *)vp->v_addr);
break;
case V_SPTR:
math_fmt("s_ptr: %p", (void *)vp->v_str);
break;
case V_NPTR:
math_fmt("n_ptr: %p", (void *)vp->v_num);
break;
case V_NBLOCK:
if (!userfunc("nblk_print", vp))
nblock_print(vp->v_nblock);
break;
default:
math_error("Printing unrecognized type of value");
not_reached();
}
}
/*
* Print an exact text representation of a value
*/
void
printestr(VALUE *vp)
{
LISTELEM *ep;
MATRIX *mp;
OBJECT *op;
BLOCK *bp;
int mode;
long i, min, max;
USB8 *cp;
if (vp->v_type < 0) {
math_fmt("error(%d)", -vp->v_type);
return;
}
switch(vp->v_type) {
case V_NULL:
math_str("\"\"");
return;
case V_STR:
math_chr('"');
strprint(vp->v_str);
math_chr('"');
return;
case V_NUM:
qprintnum(vp->v_num, MODE_FRAC, conf->outdigits);
return;
case V_COM:
mode = math_setmode(MODE_FRAC);
comprint(vp->v_com);
math_setmode(mode);
return;
case V_LIST:
math_str("list(");
ep = vp->v_list->l_first;
if (ep) {
printestr(&ep->e_value);
while ((ep = ep->e_next)) {
math_chr(',');
printestr(&ep->e_value);
}
}
math_chr(')');
return;
case V_MAT:
mp = vp->v_mat;
if (mp->m_dim == 0)
math_str("(mat[])");
else {
math_str("mat[");
for (i = 0; i < mp->m_dim; i++) {
min = mp->m_min[i];
max = mp->m_max[i];
if (i > 0)
math_chr(',');
if (min)
math_fmt("%ld:%ld", min, max);
else
math_fmt("%ld", max + 1);
}
math_chr(']');
}
i = mp->m_size;
vp = mp->m_table;
break;
case V_OBJ:
op = vp->v_obj;
math_fmt("obj %s",objtypename(op->o_actions->oa_index));
i = op->o_actions->oa_count;
vp = op->o_table;
break;
case V_BLOCK:
case V_NBLOCK:
math_str("blk(");
if (vp->v_type == V_BLOCK)
bp = vp->v_block;
else {
math_fmt("\"%s\",", vp->v_nblock->name);
bp = vp->v_nblock->blk;
}
i = bp->datalen;
math_fmt("%ld,%d)", i, (int) bp->blkchunk);
cp = bp->data;
if (i > 0) {
math_str("={");
math_fmt("%d", *cp);
while (--i > 0) {
math_chr(',');
math_fmt("%d", *++cp);
}
math_chr('}');
}
return;
default:
math_str("\"???\"");
return;
}
if (i > 0) {
math_str("={");
printestr(vp);
while (--i > 0) {
math_chr(',');
printestr(++vp);
}
math_chr('}');
}
}
/*
* config_print - print a configuration value
*
* given:
* cfg what to print
*/
void
config_print(CONFIG *cfg)
{
NAMETYPE *cp;
VALUE tmp;
int tab_over; /* true => OK move over one tab stop */
size_t len;
/*
* firewall
*/
if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL ||
cfg->prompt2 == NULL) {
math_error("CONFIG value is invalid");
not_reached();
}
/*
* print each element
*/
tab_over = false;
for (cp = configs; cp->name; cp++) {
/* skip if special all or duplicate maxerr value */
if (cp->type == CONFIG_ALL || strcmp(cp->name, "maxerr") == 0 ||
strcmp(cp->name, "ctrl-d") == 0)
continue;
/* print tab if allowed */
if (tab_over) {
math_str("\t");
} else if (conf->tab_ok) {
tab_over = true; /* tab next time */
}
/* print name and spaces */
math_fmt("%s", cp->name);
len = 16 - strlen(cp->name);
while (len-- > 0)
math_str(" ");
/* print value */
config_value(cfg, cp->type, &tmp);
printvalue(&tmp, PRINT_SHORT | PRINT_UNAMBIG);
freevalue(&tmp);
if ((cp+1)->name)
math_str("\n");
}
}
Reference in New Issue View Git Blame Copy Permalink