Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/unix/volume26/calc/part12

Text File | 1992-05-09 | 30.0 KB | 1,382 lines

Newsgroups: comp.sources.unix
From: [e-mail] (David I. Bell)
Subject: v26i038: CALC - An arbitrary precision C-like calculator, Part12/21
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (David I. Bell)
Posting-Number: Volume 26, Issue 38
Archive-Name: calc/part12

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 12 (of 21)."
# Contents:  value.c
# Wrapped by dbell@elm on Tue Feb 25 15:21:10 1992
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'value.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'value.c'\"
else
echo shar: Extracting \"'value.c'\" \(27747 characters\)
sed "s/^X//" >'value.c' <<'END_OF_FILE'
X/*
X * Copyright (c) 1992 David I. Bell
X * Permission is granted to use, distribute, or modify this source,
X * provided that this copyright notice remains intact.
X *
X * Generic value manipulation routines.
X */
X
X#include "calc.h"
X#include "opcodes.h"
X#include "func.h"
X#include "symbol.h"
X
X
X/*
X * Free a value and set its type to undefined.
X */
Xvoid
Xfreevalue(vp)
X    register VALUE *vp;    /* value to be freed */
X{
X    int type;        /* type of value being freed */
X
X    type = vp->v_type;
X    vp->v_type = V_NULL;
X    switch (type) {
X        case V_NULL:
X        case V_ADDR:
X        case V_FILE:
X            break;
X        case V_STR:
X            if (vp->v_subtype == V_STRALLOC)
X                free(vp->v_str);
X            break;
X        case V_NUM:
X            qfree(vp->v_num);
X            break;
X        case V_COM:
X            comfree(vp->v_com);
X            break;
X        case V_MAT:
X            matfree(vp->v_mat);
X            break;
X        case V_LIST:
X            listfree(vp->v_list);
X            break;
X        case V_OBJ:
X            objfree(vp->v_obj);
X            break;
X        default:
X            error("Freeing unknown value type");
X    }
X}
X
X
X/*
X * Copy a value from one location to another.
X * This overwrites the specified new value without checking it.
X */
Xvoid
Xcopyvalue(oldvp, newvp)
X    register VALUE *oldvp;        /* value to be copied from */
X    register VALUE *newvp;        /* value to be copied into */
X{
X    newvp->v_type = V_NULL;
X    switch (oldvp->v_type) {
X        case V_NULL:
X            break;
X        case V_FILE:
X            newvp->v_file = oldvp->v_file;
X            break;
X        case V_NUM:
X            newvp->v_num = qlink(oldvp->v_num);
X            break;
X        case V_COM:
X            newvp->v_com = clink(oldvp->v_com);
X            break;
X        case V_STR:
X            newvp->v_str = oldvp->v_str;
X            if (oldvp->v_subtype == V_STRALLOC) {
X                newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
X                if (newvp->v_str == NULL)
X                    error("Cannot get memory for string copy");
X                strcpy(newvp->v_str, oldvp->v_str);
X            }
X            break;
X        case V_MAT:
X            newvp->v_mat = matcopy(oldvp->v_mat);
X            break;
X        case V_LIST:
X            newvp->v_list = listcopy(oldvp->v_list);
X            break;
X        case V_ADDR:
X            newvp->v_addr = oldvp->v_addr;
X            break;
X        case V_OBJ:
X            newvp->v_obj = objcopy(oldvp->v_obj);
X            break;
X        default:
X            error("Copying unknown value type");
X    }
X    newvp->v_subtype = oldvp->v_subtype;
X    newvp->v_type = oldvp->v_type;
X
X}
X
X
X/*
X * Negate an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xnegvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qneg(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cneg(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matneg(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_NEG, vp);
X            return;
X        default:
X            error("Illegal value for negation");
X    }
X}
X
X
X/*
X * Add two arbitrary values together.
X * Result is placed in the indicated location.
X */
Xvoid
Xaddvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qadd(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = caddq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            vres->v_com = caddq(v2->v_com, v1->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cadd(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matadd(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for add");
X            *vres = objcall(OBJ_ADD, v1, v2);
X            return;
X    }
X}
X
X
X/*
X * Subtract one arbitrary value from another one.
X * Result is placed in the indicated location.
X */
Xvoid
Xsubvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qsub(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = csubq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            c = csubq(v2->v_com, v1->v_num);
X            vres->v_com = cneg(c);
X            comfree(c);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = csub(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matsub(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for subtract");
X            *vres = objcall(OBJ_SUB, v1, v2);
X            return;
X    }
X}
X
X
X/*
X * Multiply two arbitrary values together.
X * Result is placed in the indicated location.
X */
Xvoid
Xmulvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qmul(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = cmulq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_NUM, V_COM):
X            vres->v_com = cmulq(v2->v_com, v1->v_num);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cmul(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matmul(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case TWOVAL(V_MAT, V_NUM):
X        case TWOVAL(V_MAT, V_COM):
X            vres->v_mat = matmulval(v1->v_mat, v2);
X            vres->v_type = V_MAT;
X            return;
X        case TWOVAL(V_NUM, V_MAT):
X        case TWOVAL(V_COM, V_MAT):
X            vres->v_mat = matmulval(v2->v_mat, v1);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for multiply");
X            *vres = objcall(OBJ_MUL, v1, v2);
X            return;
X    }
X    c = vres->v_com;
X    if (cisreal(c)) {
X        vres->v_num = qlink(c->real);
X        vres->v_type = V_NUM;
X        comfree(c);
X    }
X}
X
X
X/*
X * Square an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xsquarevalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qsquare(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = csquare(vp->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matsquare(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_SQUARE, vp);
X            return;
X        default:
X            error("Illegal value for squaring");
X    }
X}
X
X
X/*
X * Invert an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xinvertvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qinv(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cinv(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matinv(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INV, vp);
X            return;
X        default:
X            error("Illegal value for inverting");
X    }
X}
X
X
X/*
X * Round an arbitrary value to the specified number of decimal places.
X * Result is placed in the indicated location.
X */
Xvoid
Xroundvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long places;
X    NUMBER *q;
X    COMPLEX *c;
X
X    switch (v2->v_type) {
X        case V_NUM:
X            q = v2->v_num;
X            if (qisfrac(q) || isbig(q->num))
X                error("Bad number of places for round");
X            places = qtoi(q);
X            break;
X        case V_INT:
X            places = v2->v_int;
X            break;
X        default:
X            error("Bad value type for places in round");
X    }
X    if (places < 0)
X        error("Negative number of places in round");
X    vres->v_type = V_NULL;
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisint(v1->v_num))
X                vres->v_num = qlink(v1->v_num);
X            else
X                vres->v_num = qround(v1->v_num, places);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(v1->v_com)) {
X                vres->v_com = clink(v1->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cround(v1->v_com, places);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matround(v1->v_mat, places);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_ROUND, v1, v2);
X            return;
X        default:
X            error("Illegal value for round");
X    }
X}
X
X
X/*
X * Round an arbitrary value to the specified number of binary places.
X * Result is placed in the indicated location.
X */
Xvoid
Xbroundvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long places;
X    NUMBER *q;
X    COMPLEX *c;
X
X    switch (v2->v_type) {
X        case V_NUM:
X            q = v2->v_num;
X            if (qisfrac(q) || isbig(q->num))
X                error("Bad number of places for bround");
X            places = qtoi(q);
X            break;
X        case V_INT:
X            places = v2->v_int;
X            break;
X        default:
X            error("Bad value type for places in bround");
X    }
X    if (places < 0)
X        error("Negative number of places in bround");
X    vres->v_type = V_NULL;
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisint(v1->v_num))
X                vres->v_num = qlink(v1->v_num);
X            else
X                vres->v_num = qbround(v1->v_num, places);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(v1->v_com)) {
X                vres->v_com = clink(v1->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cbround(v1->v_com, places);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matbround(v1->v_mat, places);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_BROUND, v1, v2);
X            return;
X        default:
X            error("Illegal value for bround");
X    }
X}
X
X
X/*
X * Take the integer part of an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xintvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            if (qisint(vp->v_num))
X                vres->v_num = qlink(vp->v_num);
X            else
X                vres->v_num = qint(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(vp->v_com)) {
X                vres->v_com = clink(vp->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cint(vp->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matint(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INT, vp);
X            return;
X        default:
X            error("Illegal value for int");
X    }
X}
X
X
X/*
X * Take the fractional part of an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xfracvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            if (qisint(vp->v_num))
X                vres->v_num = qlink(&_qzero_);
X            else
X                vres->v_num = qfrac(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(vp->v_com)) {
X                vres->v_num = clink(&_qzero_);
X                vres->v_type = V_NUM;
X                return;
X            }
X            vres->v_com = cfrac(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matfrac(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_FRAC, vp);
X            return;
X        default:
X            error("Illegal value for frac function");
X    }
X}
X
X
X/*
X * Increment an arbitrary value by one.
X * Result is placed in the indicated location.
X */
Xvoid
Xincvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qinc(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = caddq(vp->v_com, &_qone_);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INC, vp);
X            return;
X        default:
X            error("Illegal value for incrementing");
X    }
X}
X
X
X/*
X * Decrement an arbitrary value by one.
X * Result is placed in the indicated location.
X */
Xvoid
Xdecvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qdec(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = caddq(vp->v_com, &_qnegone_);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_DEC, vp);
X            return;
X        default:
X            error("Illegal value for decrementing");
X    }
X}
X
X
X/*
X * Produce the 'conjugate' of an arbitrary value.
X * Result is placed in the indicated location.
X * (Example: complex conjugate.)
X */
Xvoid
Xconjvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qlink(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = comalloc();
X            vres->v_com->real = qlink(vp->v_com->real);
X            vres->v_com->imag = qneg(vp->v_com->imag);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matconj(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_CONJ, vp);
X            return;
X        default:
X            error("Illegal value for conjugation");
X    }
X}
X
X
X/*
X * Take the square root of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xsqrtvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q, *tmp;
X    COMPLEX *c;
X
X    if (v2->v_type != V_NUM)
X        error("Non-real epsilon for sqrt");
X    q = v2->v_num;
X    if (qisneg(q) || qiszero(q))
X        error("Illegal epsilon value for sqrt");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (!qisneg(v1->v_num)) {
X                vres->v_num = qsqrt(v1->v_num, q);
X                vres->v_type = V_NUM;
X                return;
X            }
X            tmp = qneg(v1->v_num);
X            c = comalloc();
X            c->imag = qsqrt(tmp, q);
X            qfree(tmp);
X            vres->v_com = c;
X            vres->v_type = V_COM;
X            return;
X        case V_COM:
X            vres->v_com = csqrt(v1->v_com, q);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_SQRT, v1, v2);
X            return;
X        default:
X            error("Bad value for taking square root");
X    }
X}
X
X
X/*
X * Take the Nth root of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xrootvalue(v1, v2, v3, vres)
X    VALUE *v1;        /* value to take root of */
X    VALUE *v2;        /* value specifying root to take */
X    VALUE *v3;        /* value specifying error */
X    VALUE *vres;
X{
X    NUMBER *q1, *q2;
X    COMPLEX ctmp;
X
X    if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
X        error("Non-real arguments for root");
X    q1 = v2->v_num;
X    q2 = v3->v_num;
X    if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
X        error("Non-positive or non-integral root");
X    if (qisneg(q2) || qiszero(q2))
X        error("Non-positive epsilon for root");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (!qisneg(v1->v_num) || isodd(q1->num)) {
X                vres->v_num = qroot(v1->v_num, q1, q2);
X                vres->v_type = V_NUM;
X                return;
X            }
X            ctmp.real = v1->v_num;
X            ctmp.imag = &_qzero_;
X            vres->v_com = croot(&ctmp, q1, q2);
X            vres->v_type = V_COM;
X            return;
X        case V_COM:
X            vres->v_com = croot(v1->v_com, q1, q2);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_ROOT, v1, v2, v3);
X            return;
X        default:
X            error("Taking root of bad value");
X    }
X}
X
X
X/*
X * Take the absolute value of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xabsvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q, *epsilon;
X
X    if (v2->v_type != V_NUM)
X        error("Bad epsilon type for abs");
X    epsilon = v2->v_num;
X    if (qiszero(epsilon) || qisneg(epsilon))
X        error("Non-positive epsilon for abs");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisneg(v1->v_num))
X                q = qneg(v1->v_num);
X            else
X                q = qlink(v1->v_num);
X            break;
X        case V_COM:
X            q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
X            break;
X        case V_OBJ:
X            *vres = objcall(OBJ_ABS, v1, v2);
X            return;
X        default:
X            error("Illegal value for absolute value");
X    }
X    vres->v_num = q;
X    vres->v_type = V_NUM;
X}
X
X
X/*
X * Calculate the norm of an arbitrary value.
X * Result is placed in the indicated location.
X * The norm is the square of the absolute value.
X */
Xvoid
Xnormvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    NUMBER *q1, *q2;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qsquare(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            q1 = qsquare(vp->v_com->real);
X            q2 = qsquare(vp->v_com->imag);
X            vres->v_num = qadd(q1, q2);
X            vres->v_type = V_NUM;
X            qfree(q1);
X            qfree(q2);
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_NORM, vp);
X            return;
X        default:
X            error("Illegal value for norm");
X    }
X}
X
X
X/*
X * Shift a value left or right by the specified number of bits.
X * Negative shift value means shift the direction opposite the selected dir.
X * Right shifts are defined to lose bits off the low end of the number.
X * Result is placed in the indicated location.
X */
Xvoid
Xshiftvalue(v1, v2, rightshift, vres)
X    VALUE *v1, *v2, *vres;
X    BOOL rightshift;    /* TRUE if shift right instead of left */
X{
X    COMPLEX *c;
X    long n;
X    VALUE tmp;
X
X    if (v2->v_type != V_NUM)
X        error("Non-real shift value");
X     if (qisfrac(v2->v_num))
X        error("Non-integral shift value");
X    if (v1->v_type != V_OBJ) {
X        if (isbig(v2->v_num->num))
X            error("Very large shift value");
X        n = qtoi(v2->v_num);
X    }
X    if (rightshift)
X        n = -n;
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qshift(v1->v_num, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            c = cshift(v1->v_com, n);
X            if (!cisreal(c)) {
X                vres->v_com = c;
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matshift(v1->v_mat, n);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            if (!rightshift) {
X                *vres = objcall(OBJ_SHIFT, v1, v2);
X                return;
X            }
X            tmp.v_num = qneg(v2->v_num);
X            tmp.v_type = V_NUM;
X            *vres = objcall(OBJ_SHIFT, v1, &tmp);
X            qfree(tmp.v_num);
X            return;
X        default:
X            error("Bad value for shifting");
X    }
X}
X
X
X/*
X * Scale a value by a power of two.
X * Result is placed in the indicated location.
X */
Xvoid
Xscalevalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long n;
X
X    if (v2->v_type != V_NUM)
X        error("Non-real scaling factor");
X    if (qisfrac(v2->v_num))
X        error("Non-integral scaling factor");
X    if (v1->v_type != V_OBJ) {
X        if (isbig(v2->v_num->num))
X            error("Very large scaling factor");
X        n = qtoi(v2->v_num);
X    }
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qscale(v1->v_num, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cscale(v1->v_com, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_MAT:
X            vres->v_mat = matscale(v1->v_mat, n);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_SCALE, v1, v2);
X            return;
X        default:
X            error("Bad value for scaling");
X    }
X}
X
X
X/*
X * Raise a value to an integral power.
X * Result is placed in the indicated location.
X */
Xvoid
Xpowivalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q;
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    if (v2->v_type != V_NUM)
X        error("Raising value to non-real power");
X    q = v2->v_num;
X    if (qisfrac(q))
X        error("Raising value to non-integral power");
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qpowi(v1->v_num, q);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cpowi(v1->v_com, q);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matpowi(v1->v_mat, q);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_POW, v1, v2);
X            return;
X        default:
X            error("Illegal value for raising to integer power");
X    }
X}
X
X
X/*
X * Raise one value to another value's power, within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xpowervalue(v1, v2, v3, vres)
X    VALUE *v1, *v2, *v3, *vres;
X{
X    NUMBER *epsilon;
X    COMPLEX *c, ctmp;
X
X    vres->v_type = V_NULL;
X    if (v3->v_type != V_NUM)
X        error("Non-real epsilon value for power");
X    epsilon = v3->v_num;
X    if (qisneg(epsilon) || qiszero(epsilon))
X        error("Non-positive epsilon value for power");
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            ctmp.real = v1->v_num;
X            ctmp.imag = &_qzero_;
X            vres->v_com = cpower(&ctmp, v2->v_com, epsilon);
X            break;
X        case TWOVAL(V_COM, V_NUM):
X            ctmp.real = v2->v_num;
X            ctmp.imag = &_qzero_;
X            vres->v_com = cpower(v1->v_com, &ctmp, epsilon);
X            break;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cpower(v1->v_com, v2->v_com, epsilon);
X            break;
X        default:
X            error("Illegal value for raising to power");
X    }
X    /*
X     * Here for any complex result.
X     */
X    vres->v_type = V_COM;
X    c = vres->v_com;
X    if (!cisreal(c))
X        return;
X    vres->v_num = qlink(c->real);
X    vres->v_type = V_NUM;
X    comfree(c);
X}
X
X
X/*
X * Divide one arbitrary value by another one.
X * Result is placed in the indicated location.
X */
Xvoid
Xdivvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X    COMPLEX tmp;
X    VALUE tmpval;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qdiv(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = cdivq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            if (qiszero(v1->v_num)) {
X                vres->v_num = qlink(&_qzero_);
X                vres->v_type = V_NUM;
X                return;
X            }
X            tmp.real = v1->v_num;
X            tmp.imag = &_qzero_;
X            vres->v_com = cdiv(&tmp, v2->v_com);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cdiv(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case TWOVAL(V_MAT, V_NUM):
X        case TWOVAL(V_MAT, V_COM):
X            invertvalue(v2, &tmpval);
X            vres->v_mat = matmulval(v1->v_mat, &tmpval);
X            vres->v_type = V_MAT;
X            freevalue(&tmpval);
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for divide");
X            *vres = objcall(OBJ_DIV, v1, v2);
X            return;
X    }
X}
X
X
X/*
X * Divide one arbitrary value by another one keeping only the integer part.
X * Result is placed in the indicated location.
X */
Xvoid
Xquovalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qquo(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = cquoq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case TWOVAL(V_MAT, V_NUM):
X        case TWOVAL(V_MAT, V_COM):
X            vres->v_mat = matquoval(v1->v_mat, v2);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for quotient");
X            *vres = objcall(OBJ_QUO, v1, v2);
X            return;
X    }
X}
X
X
X/*
X * Divide one arbitrary value by another one keeping only the remainder.
X * Result is placed in the indicated location.
X */
Xvoid
Xmodvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qmod(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = cmodq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case TWOVAL(V_MAT, V_NUM):
X        case TWOVAL(V_MAT, V_COM):
X            vres->v_mat = matmodval(v1->v_mat, v2);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                error("Non-compatible values for mod");
X            *vres = objcall(OBJ_MOD, v1, v2);
X            return;
X    }
X}
X
X
X/*
X * Test an arbitrary value to see if it is equal to "zero".
X * The definition of zero varies depending on the value type.  For example,
X * the null string is "zero", and a matrix with zero values is "zero".
X * Returns TRUE if value is not equal to zero.
X */
XBOOL
Xtestvalue(vp)
X    VALUE *vp;
X{
X    VALUE val;
X
X    switch (vp->v_type) {
X        case V_NUM:
X            return !qiszero(vp->v_num);
X        case V_COM:
X            return !ciszero(vp->v_com);
X        case V_STR:
X            return (vp->v_str[0] != '\0');
X        case V_MAT:
X            return mattest(vp->v_mat);
X        case V_LIST:
X            return (vp->v_list->l_count != 0);
X        case V_FILE:
X            return validid(vp->v_file);
X        case V_NULL:
X            return FALSE;
X        case V_OBJ:
X            val = objcall(OBJ_TEST, vp);
X            return (val.v_int != 0);
X        default:
X            return TRUE;
X    }
X}
X
X
X/*
X * Compare two values for equality.
X * Returns TRUE if the two values differ.
X */
XBOOL
Xcomparevalue(v1, v2)
X    VALUE *v1, *v2;
X{
X    int r;
X    VALUE val;
X
X    if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
X        val = objcall(OBJ_CMP, v1, v2);
X        return (val.v_int != 0);
X    }
X    if (v1 == v2)
X        return FALSE;
X    if (v1->v_type != v2->v_type)
X        return TRUE;
X    switch (v1->v_type) {
X        case V_NUM:
X            r = qcmp(v1->v_num, v2->v_num);
X            break;
X        case V_COM:
X            r = ccmp(v1->v_com, v2->v_com);
X            break;
X        case V_STR:
X            r = ((v1->v_str != v2->v_str) &&
X                ((v1->v_str[0] - v2->v_str[0]) ||
X                strcmp(v1->v_str, v2->v_str)));
X            break;
X        case V_MAT:
X            r = matcmp(v1->v_mat, v2->v_mat);
X            break;
X        case V_LIST:
X            r = listcmp(v1->v_list, v2->v_list);
X            break;
X        case V_NULL:
X            r = FALSE;
X            break;
X        case V_FILE:
X            r = (v1->v_file != v2->v_file);
X            break;
X        default:
X            error("Illegal values for comparevalue");
X    }
X    return (r != 0);
X}
X
X
X/*
X * Compare two values for their relative values.
X * Returns minus one if the first value is less than the second one,
X * one if the first value is greater than the second one, and
X * zero if they are equal.
X */
XFLAG
Xrelvalue(v1, v2)
X    VALUE *v1, *v2;
X{
X    int r;
X    VALUE val;
X
X    if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
X        val = objcall(OBJ_REL, v1, v2);
X        return val.v_int;
X    }
X    if (v1 == v2)
X        return 0;
X    if (v1->v_type != v2->v_type)
X        error("Relative comparison of differing types");
X    switch (v1->v_type) {
X        case V_NUM:
X            r = qrel(v1->v_num, v2->v_num);
X            break;
X        case V_STR:
X            r = strcmp(v1->v_str, v2->v_str);
X            break;
X        case V_NULL:
X            r = 0;
X            break;
X        default:
X            error("Illegal value for relative comparison");
X    }
X    if (r < 0)
X        return -1;
X    return (r != 0);
X}
X
X
X/*
X * Print the value of a descriptor in one of several formats.
X * If flags contains PRINT_SHORT, then elements of arrays and lists
X * will not be printed.  If flags contains PRINT_UNAMBIG, then quotes
X * are placed around strings and the null value is explicitly printed.
X */
Xvoid
Xprintvalue(vp, flags)
X    VALUE *vp;
X{
X    switch (vp->v_type) {
X        case V_NUM:
X            qprintnum(vp->v_num, MODE_DEFAULT);
X            break;
X        case V_COM:
X            comprint(vp->v_com);
X            break;
X        case V_STR:
X            if (flags & PRINT_UNAMBIG)
X                math_chr('\"');
X            math_str(vp->v_str);
X            if (flags & PRINT_UNAMBIG)
X                math_chr('\"');
X            break;
X        case V_NULL:
X            if (flags & PRINT_UNAMBIG)
X                math_str("NULL");
X            break;
X        case V_OBJ:
X            (void) objcall(OBJ_PRINT, vp);
X            break;
X        case V_LIST:
X            listprint(vp->v_list,
X                ((flags & PRINT_SHORT) ? 0L : maxprint));
X            break;
X        case V_MAT:
X            matprint(vp->v_mat,
X                ((flags & PRINT_SHORT) ? 0L : maxprint));
X            break;
X        case V_FILE:
X            printid(vp->v_file, flags);
X            break;
X        default:
X            error("Printing unknown value");
X    }
X}
X
X/* END CODE */
END_OF_FILE
if test 27747 -ne `wc -c <'value.c'`; then
    echo shar: \"'value.c'\" unpacked with wrong size!
fi
# end of 'value.c'
fi
echo shar: End of archive 12 \(of 21\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 21 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0