/* * value - generic value manipulation routines * * Copyright (C) 1999 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. * 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. * * @(#) $Revision: 29.1 $ * @(#) $Id: value.c,v 29.1 1999/12/14 09:16:16 chongo Exp $ * @(#) $Source: /usr/local/src/cmd/calc/RCS/value.c,v $ * * Under source code control: 1990/02/15 01:48:25 * File existed as early as: before 1990 * * Share and enjoy! :-) http://reality.sgi.com/chongo/tech/comp/calc/ */ #include #include #include "value.h" #include "opcodes.h" #include "func.h" #include "symbol.h" #include "string.h" #include "zrand.h" #include "zrandom.h" #include "cmath.h" #include "nametype.h" #include "file.h" #include "config.h" #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; if (type < 0) return; switch (type) { case V_NULL: 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"); /*NOTREACHED*/ } vp->v_subtype = V_NOSUBTYPE; } /* * Set protection status for a value and all of its components */ void protectall(VALUE *vp, int sts) { VALUE *vq; int i; LISTELEM *ep; if (vp->v_type == V_NBLOCK) { vp->v_nblock->subtype |= sts; return; } vp->v_subtype |= sts; switch(vp->v_type) { case V_MAT: vq = vp->v_mat->m_table; i = vp->v_mat->m_size; while (i-- > 0) protectall(vq++, sts); break; case V_LIST: for (ep = vp->v_list->l_first; ep; ep = ep->e_next) protectall(&ep->e_value, sts); break; case V_OBJ: vq = vp->v_obj->o_table; i = vp->v_obj->o_actions->oa_count; while (i-- > 0) protectall(vq++, sts); break; } } /* * 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) { 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_subtype = V_NOSUBTYPE; newvp->v_num = itoq((long) *oldvp->v_octet); break; case V_NBLOCK: newvp->v_nblock = oldvp->v_nblock; return; default: math_error("Copying unknown value type"); /*NOTREACHED*/ } } 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 = cneg(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; } } /* * addnumeric - add two numeric values togethter * * If either value is not real or complex, it is assumed to have * a value of 0. * * Result is placed in the indicated location. */ void addnumeric(VALUE *v1, VALUE *v2, VALUE *vres) { COMPLEX *c; /* * add numeric values */ vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { case TWOVAL(V_NUM, V_NUM): vres->v_num = qqadd(v1->v_num, v2->v_num); vres->v_type = V_NUM; return; case TWOVAL(V_COM, V_NUM): vres->v_com = caddq(v1->v_com, v2->v_num); vres->v_type = V_COM; return; case TWOVAL(V_NUM, V_COM): vres->v_com = caddq(v2->v_com, v1->v_num); vres->v_type = V_COM; return; case TWOVAL(V_COM, V_COM): vres->v_com = cadd(v1->v_com, v2->v_com); vres->v_type = V_COM; c = vres->v_com; if (!cisreal(c)) return; vres->v_num = qlink(c->real); vres->v_type = V_NUM; comfree(c); return; } /* * assume zero if a value is not numeric */ if (v1->v_type == V_NUM) { /* v1 + 0 == v1 */ vres->v_type = v1->v_type; vres->v_num = qlink(v1->v_num); } else if (v1->v_type == V_COM) { /* v1 + 0 == v1 */ vres->v_type = v1->v_type; vres->v_com = clink(v1->v_com); } else if (v2->v_type == V_NUM) { /* v2 + 0 == v2 */ vres->v_type = v2->v_type; vres->v_num = qlink(v2->v_num); } else if (v2->v_type == V_COM) { /* v2 + 0 == v2 */ vres->v_type = v2->v_type; vres->v_com = clink(v2->v_com); } else { /* 0 + 0 = 0 */ vres->v_type = V_NUM; vres->v_num = qlink(&_qzero_); } return; } /* * Add two arbitrary values together. * Result is placed in the indicated location. */ void addvalue(VALUE *v1, VALUE *v2, VALUE *vres) { 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; switch (TWOVAL(v1->v_type, v2->v_type)) { 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 = caddq(v1->v_com, v2->v_num); return; case TWOVAL(V_NUM, V_COM): vres->v_com = caddq(v2->v_com, v1->v_num); vres->v_type = V_COM; return; case TWOVAL(V_COM, V_COM): vres->v_com = cadd(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): q = v2->v_num; if (qisfrac(q)) { math_error("Adding non-integer to address"); /*NOTREACHED*/ } i = qtoi(q); vres->v_addr = v1->v_addr + i; vres->v_type = V_VPTR; return; case TWOVAL(V_OPTR, V_NUM): q = v2->v_num; if (qisfrac(q)) { math_error("Adding non-integer to address"); /*NOTREACHED*/ } 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) { copyvalue(v1, vres); return; } if (v2->v_type < 0) { copyvalue(v2, vres); return; } *vres = error_value(E_ADD); 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) { COMPLEX *c; NUMBER *q; int i; vres->v_type = v1->v_type; vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { 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 = csubq(v1->v_com, v2->v_num); return; case TWOVAL(V_NUM, V_COM): c = csubq(v2->v_com, v1->v_num); vres->v_type = V_COM; vres->v_com = cneg(c); comfree(c); return; case TWOVAL(V_COM, V_COM): vres->v_com = csub(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): q = v2->v_num; if (qisfrac(q)) { math_error("Subtracting non-integer from address"); /*NOTREACHED*/ } i = qtoi(q); vres->v_addr = v1->v_addr - i; vres->v_type = V_VPTR; return; case TWOVAL(V_OPTR, V_NUM): q = v2->v_num; if (qisfrac(q)) { math_error("Adding non-integer to address"); /*NOTREACHED*/ } 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) { copyvalue(v1, vres); return; } if (v2->v_type < 0) { copyvalue(v2, vres); 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) { COMPLEX *c; vres->v_type = v1->v_type; vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { 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 = cmulq(v1->v_com, v2->v_num); break; case TWOVAL(V_NUM, V_COM): vres->v_com = cmulq(v2->v_com, v1->v_num); vres->v_type = V_COM; break; case TWOVAL(V_COM, V_COM): vres->v_com = cmul(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) { copyvalue(v1, vres); return; } if (v2->v_type < 0) { copyvalue(v2, vres); 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 = csquare(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) { copyvalue(vp, vres); 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_1OVER0); else vres->v_num = qinv(vp->v_num); return; case V_COM: vres->v_com = cinv(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_1OVER0); 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_1OVER0) { vres->v_type = V_NUM; vres->v_num = qlink(&_qzero_); return; } if (vp->v_type < 0) { copyvalue(vp, vres); 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) { 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; switch (TWOVAL(v1->v_type, v2->v_type)) { 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) { copyvalue(v1, vres); return; } if (v2->v_type < 0) { copyvalue(v2, vres); 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) { 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; switch (TWOVAL(v1->v_type, v2->v_type)) { 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) { copyvalue(v1, vres); return; } if (v2->v_type < 0) { copyvalue(v2, vres); 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) { vres->v_type = v1->v_type; vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { 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) { NUMBER *q; vres->v_type = v1->v_type; vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { 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) { vres->v_type = v1->v_type; vres->v_subtype = V_NOSUBTYPE; switch (TWOVAL(v1->v_type, v2->v_type)) { 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) { copyvalue(v1, vres); 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_APPR2); return; } switch(v3->v_type) { case V_NUM: if (qisfrac(v3->v_num)) { *vres = error_value(E_APPR3); return; } R = qtoi(v3->v_num); break; case V_NULL: R = conf->appr; break; default: *vres = error_value(E_APPR3); 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); 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_ROUND2); return; } places = qtoi(v2->v_num); break; case V_NULL: break; default: *vres = error_value(E_ROUND2); return; } rnd = 0; switch (v3->v_type) { case V_NUM: if (qisfrac(v3->v_num)) { *vres = error_value(E_ROUND3); return; } rnd = qtoi(v3->v_num); break; case V_NULL: rnd = conf->round; break; default: *vres = error_value(E_ROUND3); 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) { copyvalue(v1, vres); return; } *vres = error_value(E_ROUND); 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_BROUND2); return; } places = qtoi(v2->v_num); break; case V_NULL: break; default: *vres = error_value(E_BROUND2); return; } rnd = 0; switch (v3->v_type) { case V_NUM: if (qisfrac(v3->v_num)) { *vres = error_value(E_BROUND3); return; } rnd = qtoi(v3->v_num); break; case V_NULL: rnd = conf->round; break; default: *vres = error_value(E_BROUND3); 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) { copyvalue(v1, vres); return; } *vres = error_value(E_BROUND); 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 = cint(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) { copyvalue(vp, vres); 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 = cfrac(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) { copyvalue(vp, vres); 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 = caddq(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: vres->v_addr = vp->v_addr + 1; 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 = caddq(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: vres->v_addr = vp->v_addr - 1; 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) { copyvalue(vp, vres); 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) { copyvalue(v1, vres); 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_SQRT2); 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_SQRT3); 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 = csqrt(v1->v_com, q, R); break; default: *vres = error_value(E_SQRT); 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) { copyvalue(v1, vres); return; } if (v2->v_type != V_NUM) { *vres = error_value(E_ROOT2); return; } q2 = v2->v_num; if (qisneg(q2) || qiszero(q2) || qisfrac(q2)) { *vres = error_value(E_ROOT2); return; } if (v3->v_type != V_NUM || qiszero(v3->v_num)) { *vres = error_value(E_ROOT3); 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_ROOT4); vres->v_type = V_NUM; return; } ctmp.real = v1->v_num; ctmp.imag = &_qzero_; ctmp.links = 1; c = croot(&ctmp, q2, q3); break; case V_COM: c = croot(v1->v_com, q2, q3); break; case V_OBJ: *vres = objcall(OBJ_ROOT, v1, v2, v3); return; default: *vres = error_value(E_ROOT); return; } if (c == NULL) { *vres = error_value(E_ROOT4); 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) { copyvalue(v1, vres); 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_ABS2); return; } q = qhypot(v1->v_com->real, v1->v_com->imag, v2->v_num); break; default: *vres = error_value(E_ABS); 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) { copyvalue(vp, vres); 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) { copyvalue(v1, vres); return; } if ((v2->v_type != V_NUM) || (qisfrac(v2->v_num))) { *vres = error_value(E_SHIFT2); return; } if (v1->v_type != V_OBJ) { if (zge31b(v2->v_num->num)) { *vres = error_value(E_SHIFT2); 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); 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); return; } c = cshift(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); 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) { copyvalue(v1, vres); return; } if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) { *vres = error_value(E_SCALE2); return; } if (v1->v_type != V_OBJ) { if (zge31b(v2->v_num->num)) { *vres = error_value(E_SCALE2); 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 = cscale(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); return; } } /* * Raise a value to an integral power. * Result is placed in the indicated location. */ void powivalue(VALUE *v1, VALUE *v2, VALUE *vres) { NUMBER *q; 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_1OVER0) return; if (v2->v_type < 0) { vres->v_type = v2->v_type; return; } if (v2->v_type != V_NUM || qisfrac(v2->v_num)) { *vres = error_value(E_POWI2); return; } q = v2->v_num; if (v1->v_type == -E_1OVER0) { if (qisneg(q)) { vres->v_type = V_NUM; vres->v_num = qlink(&_qzero_); } return; } switch (v1->v_type) { case V_NUM: if (qiszero(v1->v_num)) { if (qisneg(q)) { *vres = error_value(E_1OVER0); return; } } vres->v_num = qpowi(v1->v_num, q); return; case V_COM: vres->v_com = cpowi(v1->v_com, q); 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 = matpowi(v1->v_mat, q); return; default: *vres = error_value(E_POWI); return; } } /* * Raise one value to another value's power, within the specified error. * Result is placed in the indicated location. */ void powervalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) { NUMBER *epsilon; COMPLEX *c, ctmp1, ctmp2; vres->v_subtype = V_NOSUBTYPE; if (v1->v_type < 0) { copyvalue(v1, vres); return; } if (v1->v_type != V_NUM && v1->v_type != V_COM) { *vres = error_value(E_POWER); return; } if (v2->v_type != V_NUM && v2->v_type != V_COM) { *vres = error_value(E_POWER2); return; } if (v3->v_type != V_NUM || qiszero(v3->v_num)) { *vres = error_value(E_POWER3); return; } epsilon = v3->v_num; switch (TWOVAL(v1->v_type, v2->v_type)) { 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 = cpower(&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_POWER4); return; case TWOVAL(V_NUM, V_COM): ctmp1.real = v1->v_num; ctmp1.imag = &_qzero_; ctmp1.links = 1; c = cpower(&ctmp1, v2->v_com, epsilon); break; case TWOVAL(V_COM, V_NUM): ctmp2.real = v2->v_num; ctmp2.imag = &_qzero_; ctmp2.links = 1; c = cpower(v1->v_com, &ctmp2, epsilon); break; case TWOVAL(V_COM, V_COM): c = cpower(v1->v_com, v2->v_com, epsilon); break; default: *vres = error_value(E_POWER); 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) { 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_1OVER0) { 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_1OVER0); else *vres = error_value(E_0OVER0); return; } vres->v_type = v1->v_type; switch (TWOVAL(v1->v_type, v2->v_type)) { 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 = cdivq(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 = cdiv(&ctmp, v2->v_com); vres->v_type = V_COM; return; case TWOVAL(V_COM, V_COM): vres->v_com = cdiv(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) { copyvalue(v1, vres); 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) { copyvalue(v2, vres); return; } if (v2->v_type != V_NUM) { *vres = error_value(E_QUO2); return; } rnd = 0; switch (v3->v_type) { case V_NUM: if (qisfrac(v3->v_num)) { *vres = error_value(E_QUO3); return; } rnd = qtoi(v3->v_num); break; case V_NULL: rnd = conf->quo; break; default: *vres = error_value(E_QUO3); 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); 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_subtype = V_NOSUBTYPE; if (v1->v_type < 0) { copyvalue(v1, vres); return; } vres->v_type = v1->v_type; 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) { copyvalue(v2, vres); return; } if (v2->v_type != V_NUM) { *vres = error_value(E_MOD2); return; } rnd = 0; switch (v3->v_type) { case V_NUM: if (qisfrac(v3->v_num)) { *vres = error_value(E_MOD3); return; } rnd = qtoi(v3->v_num); break; case V_NULL: rnd = conf->mod; break; default: *vres = error_value(E_MOD3); 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); 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; /* hack to get gcc on SunOS to be quiet */ 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; } /* hack to get gcc on SunOS to be quiet */ 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 = ccmp(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_NULL: 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"); /*NOTREACHED*/ } 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) { copyvalue(vp, vres); return; } *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; type = vp->v_type; if (type < 0) { if (userfunc("error_print", vp)) return; if (-type >= E__BASE) printf("Error %d", -type); else printf("System error %d", -type); return; } switch (type) { case V_NUM: qprintnum(vp->v_num, MODE_DEFAULT); if (conf->traceflags & TRACE_LINKS) printf("#%ld", vp->v_num->links); break; case V_COM: comprint(vp->v_com); if (conf->traceflags & TRACE_LINKS) printf("##%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); qfree(qtemp); break; case V_OPTR: printf("o-ptr: %p", vp->v_octet); break; case V_VPTR: printf("v-ptr: %p", vp->v_addr); break; case V_SPTR: printf("s_ptr: %p", vp->v_str); break; case V_NPTR: printf("n_ptr: %p", 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"); /*NOTREACHED*/ } } /* * 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 */ int i; /* * firewall */ if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL || cfg->prompt2 == NULL) { math_error("CONFIG value is invaid"); /*NOTREACHED*/ } /* * 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) { printf("\t"); } else if (conf->tab_ok) { tab_over = TRUE; /* tab next time */ } /* print name and spaces */ printf("%s", cp->name); i = 16 - (int)strlen(cp->name); while (i-- > 0) printf(" "); /* print value */ config_value(cfg, cp->type, &tmp); printvalue(&tmp, PRINT_SHORT | PRINT_UNAMBIG); freevalue(&tmp); if ((cp+1)->name) printf("\n"); } }