Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume27/calc-2.9.0/part07

Text File | 1993-12-07 | 57.1 KB | 2,797 lines

Newsgroups: comp.sources.unix
From: [e-mail] (David I. Bell)
Subject: v27i134: calc-2.9.0 - arbitrary precision C-like programmable calculator, Part07/19
References: <[e-mail]>
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (David I. Bell)
Posting-Number: Volume 27, Issue 134
Archive-Name: calc-2.9.0/part07

#!/bin/sh
# this is part 7 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc2.9.0/obj.c continued
#
CurArch=7
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
     exit 1; fi
( read Scheck
  if test "$Scheck" != $CurArch
  then echo "Please unpack part $Scheck next!"
       exit 1;
  else exit 0; fi
) < s2_seq_.tmp || exit 1
echo "x - Continuing file calc2.9.0/obj.c"
sed 's/^X//' << 'SHAR_EOF' >> calc2.9.0/obj.c
X * This converts the element index from the element table into an offset
X * into the object value array.  Returns -1 if the element index is unknown.
X */
Xint
Xobjoffset(op, index)
X    OBJECT *op;
X    long index;
X{
X    register OBJECTACTIONS *oap;
X    int offset;            /* offset into value array */
X
X    oap = op->o_actions;
X    for (offset = oap->count - 1; offset >= 0; offset--) {
X        if (oap->elements[offset] == index)
X            return offset;
X    }
X    return -1;
X}
X
X
X/*
X * Allocate a new object structure with the specified index.
X */
XOBJECT *
Xobjalloc(index)
X    long index;
X{
X    OBJECTACTIONS *oap;
X    OBJECT *op;
X    VALUE *vp;
X    int i;
X
X    if ((unsigned) index >= MAXOBJECTS)
X        math_error("Allocating bad object index");
X    oap = objects[index];
X    if (oap == NULL)
X        math_error("Object type not defined");
X    i = oap->count;
X    if (i < USUAL_ELEMENTS)
X        i = USUAL_ELEMENTS;
X    if (i == USUAL_ELEMENTS)
X        op = (OBJECT *) allocitem(&freelist);
X    else
X        op = (OBJECT *) malloc(objectsize(i));
X    if (op == NULL)
X        math_error("Cannot allocate object");
X    op->o_actions = oap;
X    vp = op->o_table;
X    for (i = oap->count; i-- > 0; vp++) {
X        vp->v_num = qlink(&_qzero_);
X        vp->v_type = V_NUM;
X    }
X    return op;
X}
X
X
X/*
X * Free an object structure.
X */
Xvoid
Xobjfree(op)
X    register OBJECT *op;
X{
X    VALUE *vp;
X    int i;
X
X    vp = op->o_table;
X    for (i = op->o_actions->count; i-- > 0; vp++) {
X        if (vp->v_type == V_NUM) {
X            qfree(vp->v_num);
X        } else
X            freevalue(vp);
X    }
X    if (op->o_actions->count <= USUAL_ELEMENTS)
X        freeitem(&freelist, (FREEITEM *) op);
X    else
X        free((char *) op);
X}
X
X
X/*
X * Copy an object value
X */
XOBJECT *
Xobjcopy(op)
X    OBJECT *op;
X{
X    VALUE *v1, *v2;
X    OBJECT *np;
X    int i;
X
X    i = op->o_actions->count;
X    if (i < USUAL_ELEMENTS)
X        i = USUAL_ELEMENTS;
X    if (i == USUAL_ELEMENTS)
X        np = (OBJECT *) allocitem(&freelist);
X    else
X        np = (OBJECT *) malloc(objectsize(i));
X    if (np == NULL)
X        math_error("Cannot allocate object");
X    np->o_actions = op->o_actions;
X    v1 = op->o_table;
X    v2 = np->o_table;
X    for (i = op->o_actions->count; i-- > 0; v1++, v2++) {
X        if (v1->v_type == V_NUM) {
X            v2->v_num = qlink(v1->v_num);
X            v2->v_type = V_NUM;
X        } else
X            copyvalue(v1, v2);
X    }
X    return np;
X}
X
X
X/*
X * Return a trivial hash value for an object.
X */
XHASH
Xobjhash(op)
X    OBJECT *op;
X{
X    HASH hash;
X    int i;
X
X    hash = 0;
X    i = op->o_actions->count;
X    while (--i >= 0)
X        hash = hash * 4000037 + hashvalue(&op->o_table[i]);
X    return hash;
X}
X
X/* END CODE */
SHAR_EOF
echo "File calc2.9.0/obj.c is complete"
chmod 0644 calc2.9.0/obj.c || echo "restore of calc2.9.0/obj.c fails"
set `wc -c calc2.9.0/obj.c`;Sum=$1
if test "$Sum" != "15522"
then echo original size 15522, current size $Sum;fi
echo "x - extracting calc2.9.0/opcodes.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/opcodes.c &&
X/*
X * Copyright (c) 1993 David I. Bell
X * Permission is granted to use, distribute, or modify this source,
X * provided that this copyright notice remains intact.
X *
X * Opcode execution module
X */
X
X#include "stdarg.h"
X#include "calc.h"
X#include "opcodes.h"
X#include "func.h"
X#include "symbol.h"
X#include "hist.h"
X
X#define    QUICKLOCALS    20        /* local vars to handle quickly */
X
X
XVALUE *stack;                /* current location of top of stack */
Xstatic VALUE stackarray[MAXSTACK];    /* storage for stack */
Xstatic VALUE oldvalue;            /* previous calculation value */
Xstatic char *funcname;            /* function being executed */
Xstatic long funcline;            /* function line being executed */
X
XFLAG traceflags;            /* current trace flags */
X
X
X/*
X * Routine definitions
X */
Xstatic void o_nop(), o_localaddr(), o_globaladdr(), o_paramaddr();
Xstatic void o_globalvalue(), o_paramvalue(), o_number(), o_indexaddr();
Xstatic void o_assign(), o_add(), o_sub(), o_mul(), o_div();
Xstatic void o_mod(), o_save(), o_negate(), o_invert(), o_int(), o_frac();
Xstatic void o_numerator(), o_denominator(), o_duplicate(), o_pop();
Xstatic void o_jumpeq(), o_jumpne(), o_jump(), o_usercall(), o_getvalue();
Xstatic void o_eq(), o_ne(), o_le(), o_ge(), o_lt(), o_gt(), o_preinc();
Xstatic void o_postinc(), o_postdec(), o_debug(), o_print(), o_assignpop();
Xstatic void o_zero(), o_one(), o_printeol(), o_printspace(), o_printstring();
Xstatic void o_oldvalue(), o_quo(), o_power(), o_quit(), o_call(), o_swap();
Xstatic void o_dupvalue(), o_getepsilon(), o_and(), o_or(), o_not();
Xstatic void o_abs(), o_sgn(), o_isint(), o_condorjump(), o_condandjump();
Xstatic void o_square(), o_string(), o_isnum(), o_undef(), o_isnull();
Xstatic void o_matcreate(), o_ismat(), o_isstr(), o_getconfig(), o_predec();
Xstatic void o_leftshift(), o_rightshift(), o_casejump();
Xstatic void o_isodd(), o_iseven(), o_fiaddr(), o_fivalue(), o_argvalue();
Xstatic void o_isreal(), o_imaginary(), o_re(), o_im(), o_conjugate();
Xstatic void o_objcreate(), o_isobj(), o_norm(), o_elemaddr(), o_elemvalue();
Xstatic void o_istype(), o_scale(), o_localvalue(), o_return(), o_islist();
Xstatic void o_issimple(), o_cmp(), o_quomod(), o_setconfig(), o_setepsilon();
Xstatic void o_printresult(), o_isfile(), o_isassoc(), o_eleminit();
X
X
X/*
X * Types of opcodes (depends on arguments saved after the opcode).
X */
X#define OPNUL    1    /* opcode has no arguments */
X#define OPONE    2    /* opcode has one integer argument */
X#define OPTWO    3    /* opcode has two integer arguments */
X#define OPJMP    4    /* opcode is a jump (with one pointer argument) */
X#define OPRET    5    /* opcode is a return (with no argument) */
X#define OPGLB    6    /* opcode has global symbol pointer argument */
X#define OPPAR    7    /* opcode has parameter index argument */
X#define OPLOC    8    /* opcode needs local variable pointer (with one arg) */
X#define OPSTR    9    /* opcode has a string constant arg */
X#define OPARG    10    /* opcode is given number of arguments */
X#define    OPSTI    11    /* opcode is static initialization */
X
X
X/*
X * Information about each opcode.
X */
Xstatic struct opcode {
X    void (*o_func)();    /* routine to call for opcode */
X    int o_type;        /* type of opcode */
X    char *o_name;        /* name of opcode */
X} opcodes[MAX_OPCODE+1] = {
X    o_nop,        OPNUL,  "NOP",        /* no operation */
X    o_localaddr,    OPLOC,  "LOCALADDR",    /* address of local variable */
X    o_globaladdr,    OPGLB,  "GLOBALADDR",    /* address of global variable */
X    o_paramaddr,    OPPAR,  "PARAMADDR",    /* address of paramater variable */
X    o_localvalue,    OPLOC,  "LOCALVALUE",    /* value of local variable */
X    o_globalvalue,    OPGLB,  "GLOBALVALUE",    /* value of global variable */
X    o_paramvalue,    OPPAR,  "PARAMVALUE",     /* value of paramater variable */
X    o_number,    OPONE,  "NUMBER",    /* constant real numeric value */
X    o_indexaddr,    OPTWO,  "INDEXADDR",    /* array index address */
X    o_printresult,    OPNUL,  "PRINTRESULT",    /* print result of top-level expression */
X    o_assign,    OPNUL,  "ASSIGN",    /* assign value to variable */
X    o_add,        OPNUL,  "ADD",        /* add top two values */
X    o_sub,        OPNUL,  "SUB",        /* subtract top two values */
X    o_mul,        OPNUL,  "MUL",        /* multiply top two values */
X    o_div,        OPNUL,  "DIV",        /* divide top two values */
X    o_mod,        OPNUL,  "MOD",        /* take mod of top two values */
X    o_save,        OPNUL,  "SAVE",        /* save value for later use */
X    o_negate,    OPNUL,  "NEGATE",    /* negate top value */
X    o_invert,    OPNUL,  "INVERT",    /* invert top value */
X    o_int,        OPNUL,  "INT",        /* take integer part */
X    o_frac,        OPNUL,  "FRAC",        /* take fraction part */
X    o_numerator,    OPNUL,  "NUMERATOR",    /* take numerator */
X    o_denominator,    OPNUL,  "DENOMINATOR",    /* take denominator */
X    o_duplicate,    OPNUL,  "DUPLICATE",    /* duplicate top value */
X    o_pop,        OPNUL,  "POP",        /* pop top value */
X    o_return,    OPRET,  "RETURN",    /* return value of function */
X    o_jumpeq,    OPJMP,  "JUMPEQ",    /* jump if value zero */
X    o_jumpne,    OPJMP,  "JUMPNE",    /* jump if value nonzero */
X    o_jump,        OPJMP,  "JUMP",        /* jump unconditionally */
X    o_usercall,    OPTWO,  "USERCALL",    /* call a user function */
X    o_getvalue,    OPNUL,  "GETVALUE",    /* convert address to value */
X    o_eq,        OPNUL,  "EQ",        /* test elements for equality */
X    o_ne,        OPNUL,  "NE",        /* test elements for inequality */
X    o_le,        OPNUL,  "LE",        /* test elements for <= */
X    o_ge,        OPNUL,  "GE",        /* test elements for >= */
X    o_lt,        OPNUL,  "LT",        /* test elements for < */
X    o_gt,        OPNUL,  "GT",        /* test elements for > */
X    o_preinc,    OPNUL,  "PREINC",    /* add one to variable (++x) */
X    o_predec,    OPNUL,  "PREDEC",    /* subtract one from variable (--x) */
X    o_postinc,    OPNUL,  "POSTINC",    /* add one to variable (x++) */
X    o_postdec,    OPNUL,  "POSTDEC",    /* subtract one from variable (x--) */
X    o_debug,    OPONE,  "DEBUG",    /* debugging point */
X    o_print,    OPONE,  "PRINT",    /* print value */
X    o_assignpop,    OPNUL,  "ASSIGNPOP",    /* assign to variable and pop it */
X    o_zero,        OPNUL,  "ZERO",        /* put zero on the stack */
X    o_one,        OPNUL,  "ONE",        /* put one on the stack */
X    o_printeol,    OPNUL,  "PRINTEOL",    /* print end of line */
X    o_printspace,    OPNUL,  "PRINTSPACE",    /* print a space */
X    o_printstring,    OPSTR,  "PRINTSTR",    /* print constant string */
X    o_dupvalue,    OPNUL,  "DUPVALUE",    /* duplicate value of top value */
X    o_oldvalue,    OPNUL,  "OLDVALUE",    /* old value from previous calc */
X    o_quo,        OPNUL,  "QUO",        /* integer quotient of top values */
X    o_power,    OPNUL,  "POWER",    /* value raised to a power */
X    o_quit,        OPSTR,  "QUIT",        /* quit program */
X    o_call,        OPTWO,  "CALL",        /* call built-in routine */
X    o_getepsilon,    OPNUL,  "GETEPSILON",    /* get allowed error for calculations */
X    o_and,        OPNUL,  "AND",        /* arithmetic and or top two values */
X    o_or,        OPNUL,  "OR",        /* arithmetic or of top two values */
X    o_not,        OPNUL,  "NOT",        /* logical not or top value */
X    o_abs,        OPNUL,  "ABS",        /* absolute value of top value */
X    o_sgn,        OPNUL,  "SGN",        /* sign of number */
X    o_isint,    OPNUL,  "ISINT",    /* whether number is an integer */
X    o_condorjump,    OPJMP,  "CONDORJUMP",    /* conditional or jump */
X    o_condandjump,    OPJMP,  "CONDANDJUMP",    /* conditional and jump */
X    o_square,    OPNUL,  "SQUARE",    /* square top value */
X    o_string,    OPSTR,  "STRING",    /* string constant value */
X    o_isnum,    OPNUL,  "ISNUM",    /* whether value is a number */
X    o_undef,    OPNUL,  "UNDEF",    /* load undefined value on stack */
X    o_isnull,    OPNUL,  "ISNULL",    /* whether value is the null value */
X    o_argvalue,    OPARG,  "ARGVALUE",    /* load value of arg (parameter) n */
X    o_matcreate,    OPONE,  "MATCREATE",    /* create matrix */
X    o_ismat,    OPNUL,  "ISMAT",    /* whether value is a matrix */
X    o_isstr,    OPNUL,  "ISSTR",    /* whether value is a string */
X    o_getconfig,    OPNUL,  "GETCONFIG",    /* get value of configuration parameter */
X    o_leftshift,    OPNUL,  "LEFTSHIFT",    /* left shift of integer */
X    o_rightshift,    OPNUL,  "RIGHTSHIFT",    /* right shift of integer */
X    o_casejump,    OPJMP,  "CASEJUMP",    /* test case and jump if not matched */
X    o_isodd,    OPNUL,  "ISODD",    /* whether value is odd integer */
X    o_iseven,    OPNUL,  "ISEVEN",    /* whether value is even integer */
X    o_fiaddr,    OPNUL,  "FIADDR",    /* 'fast index' matrix address */
X    o_fivalue,    OPNUL,  "FIVALUE",    /* 'fast index' matrix value */
X    o_isreal,    OPNUL,  "ISREAL",    /* whether value is real number */
X    o_imaginary,    OPONE,  "IMAGINARY",    /* constant imaginary numeric value */
X    o_re,        OPNUL,  "RE",        /* real part of complex number */
X    o_im,        OPNUL,  "IM",        /* imaginary part of complex number */
X    o_conjugate,    OPNUL,  "CONJUGATE",    /* complex conjugate */
X    o_objcreate,    OPONE,  "OBJCREATE",    /* create object */
X    o_isobj,    OPNUL,  "ISOBJ",    /* whether value is an object */
X    o_norm,        OPNUL,  "NORM",        /* norm of value (square of abs) */
X    o_elemaddr,    OPONE,  "ELEMADDR",    /* address of element of object */
X    o_elemvalue,    OPONE,  "ELEMVALUE",    /* value of element of object */
X    o_istype,    OPNUL,  "ISTYPE",    /* whether types are the same */
X    o_scale,    OPNUL,  "SCALE",    /* scale value by a power of two */
X    o_islist,    OPNUL,    "ISLIST",    /* whether value is a list */
X    o_swap,        OPNUL,    "SWAP",        /* swap values of two variables */
X    o_issimple,    OPNUL,    "ISSIMPLE",    /* whether value is simple type */
X    o_cmp,        OPNUL,    "CMP",        /* compare values returning -1, 0, 1 */
X    o_quomod,    OPNUL,    "QUOMOD",    /* calculate quotient and remainder */
X    o_setconfig,    OPNUL,    "SETCONFIG",    /* set configuration parameter */
X    o_setepsilon,    OPNUL,  "SETEPSILON",    /* set allowed error for calculations */
X    o_isfile,    OPNUL,  "ISFILE",    /* whether value is a file */
X    o_isassoc,    OPNUL,  "ISASSOC",    /* whether value is an association */
X    o_nop,        OPSTI,  "INITSTATIC",    /* once only code for static init */
X    o_eleminit,    OPONE,    "ELEMINIT"    /* assign element of matrix or object */
X};
X
X
X
X/*
X * Initialize the stack.
X */
Xvoid
Xinitstack()
X{
X    if (stack == NULL)
X        stack = stackarray;
X    while (stack != stackarray)
X        freevalue(stack--);
X}
X
X
X/*
X * Compute the result of a function by interpreting opcodes.
X * Arguments have just been pushed onto the evaluation stack.
X */
Xvoid
Xcalculate(fp, argcount)
X    register FUNC *fp;        /* function to calculate */
X    int argcount;            /* number of arguments called with */
X{
X    register unsigned long pc;    /* current pc inside function */
X    register struct opcode *op;    /* current opcode pointer */
X    register VALUE *locals;        /* pointer to local variables */
X    long oldline;            /* old value of line counter */
X    unsigned int opnum;        /* current opcode number */
X    int origargcount;        /* original number of arguments */
X    int i;                /* loop counter */
X    BOOL dojump;            /* TRUE if jump is to occur */
X    char *oldname;            /* old function name being executed */
X    VALUE *beginstack;        /* beginning of stack frame */
X    VALUE *args;            /* pointer to function arguments */
X    VALUE retval;            /* function return value */
X    VALUE localtable[QUICKLOCALS];    /* some local variables */
X
X    oldname = funcname;
X    oldline = funcline;
X    funcname = fp->f_name;
X    funcline = 0;
X    origargcount = argcount;
X    while (argcount < fp->f_paramcount) {
X        stack++;
X        stack->v_type = V_NULL;
X        argcount++;
X    }
X    locals = localtable;
X    if (fp->f_localcount > QUICKLOCALS) {
X        locals = (VALUE *) malloc(sizeof(VALUE) * fp->f_localcount);
X        if (locals == NULL)
X            math_error("No memory for local variables");
X    }
X    for (i = 0; i < fp->f_localcount; i++) {
X        locals[i].v_num = qlink(&_qzero_);
X        locals[i].v_type = V_NUM;
X    }
X    pc = 0;
X    beginstack = stack;
X    args = beginstack - (argcount - 1);
X    for (;;) {
X        if (abortlevel >= ABORT_OPCODE)
X            math_error("Calculation aborted in opcode");
X        if (pc >= fp->f_opcodecount)
X            math_error("Function pc out of range");
X        if (stack > &stackarray[MAXSTACK-3])
X            math_error("Evaluation stack depth exceeded");
X        opnum = fp->f_opcodes[pc];
X        if (opnum > MAX_OPCODE)
X            math_error("Function opcode out of range");
X        op = &opcodes[opnum];
X        if (traceflags & TRACE_OPCODES) {
X            printf("%8s, pc %4ld:  ", fp->f_name, pc);
X            (void)dumpop(&fp->f_opcodes[pc]);
X        }
X        /*
X         * Now call the opcode routine appropriately.
X         */
X        pc++;
X        switch (op->o_type) {
X        case OPNUL:    /* no extra arguments */
X            (*op->o_func)(fp);
X            break;
X
X        case OPONE:    /* one extra integer argument */
X            (*op->o_func)(fp, fp->f_opcodes[pc++]);
X            break;
X
X        case OPTWO:    /* two extra integer arguments */
X            (*op->o_func)(fp, fp->f_opcodes[pc],
X                fp->f_opcodes[pc+1]);
X            pc += 2;
X            break;
X
X        case OPJMP:    /* jump opcodes (one extra pointer arg) */
X            dojump = FALSE;
X            (*op->o_func)(fp, &dojump);
X            if (dojump)
X                pc = fp->f_opcodes[pc];
X            else
X                pc++;
X            break;
X
X        case OPGLB:    /* global symbol reference (pointer arg) */
X        case OPSTR:    /* string constant address */
X            (*op->o_func)(fp, *((char **) &fp->f_opcodes[pc]));
X            pc += PTR_SIZE;
X            break;
X
X        case OPLOC:    /* local variable reference */
X            (*op->o_func)(fp, locals, fp->f_opcodes[pc++]);
X            break;
X
X        case OPPAR:    /* parameter variable reference */
X            (*op->o_func)(fp, argcount, args, fp->f_opcodes[pc++]);
X            break;
X
X        case OPARG:    /* parameter variable reference */
X            (*op->o_func)(fp, origargcount, args);
X            break;
X
X        case OPRET:    /* return from function */
X            if (stack->v_type == V_ADDR)
X                copyvalue(stack->v_addr, stack);
X            for (i = 0; i < fp->f_localcount; i++)
X                freevalue(&locals[i]);
X            if (locals != localtable)
X                free(locals);
X            if (stack != &beginstack[1])
X                math_error("Misaligned stack");
X            if (argcount <= 0) {
X                funcname = oldname;
X                funcline = oldline;
X                return;
X            }
X            retval = *stack--;
X            while (--argcount >= 0)
X                freevalue(stack--);
X            *++stack = retval;
X            funcname = oldname;
X            funcline = oldline;
X            return;
X
X        case OPSTI:    /* static initialization code */
X            fp->f_opcodes[pc++ - 1] = OP_JUMP;
X            break;
X
X        default:
X            math_error("Unknown opcode type");
X        }
X    }
X}
X
X
X/*
X * Dump an opcode at a particular address.
X * Returns the size of the opcode so that it can easily be skipped over.
X */
Xint
Xdumpop(pc)
X    long *pc;        /* location of the opcode */
X{
X    unsigned long op;    /* opcode number */
X
X    op = *pc++;
X    if (op <= MAX_OPCODE)
X        printf("%s", opcodes[op].o_name);
X    else
X        printf("OP%ld", op);
X    switch (op) {
X        case OP_LOCALADDR: case OP_LOCALVALUE:
X            printf(" %s\n", localname(*pc));
X            return 2;
X        case OP_GLOBALADDR: case OP_GLOBALVALUE:
X            printf(" %s\n", globalname(*((GLOBAL **) pc)));
X            return (1 + PTR_SIZE);
X        case OP_PARAMADDR: case OP_PARAMVALUE:
X            printf(" %s\n", paramname(*pc));
X            return 2;
X        case OP_PRINTSTRING: case OP_STRING:
X            printf(" \"%s\"\n", *((char **) pc));
X            return (1 + PTR_SIZE);
X        case OP_QUIT:
X            if (*(char **) pc)
X                printf(" \"%s\"\n", *((char **) pc));
X            else
X                printf("\n");
X            return (1 + PTR_SIZE);
X        case OP_INDEXADDR:
X            printf(" %ld %ld\n", pc[0], pc[1]);
X            return 3;
X        case OP_PRINT: case OP_JUMPEQ: case OP_JUMPNE: case OP_JUMP:
X        case OP_CONDORJUMP: case OP_CONDANDJUMP: case OP_CASEJUMP:
X        case OP_INITSTATIC: case OP_MATCREATE: case OP_OBJCREATE:
X            printf(" %ld\n", *pc);
X            return 2;
X        case OP_NUMBER: case OP_IMAGINARY:
X            qprintf(" %r\n", constvalue(*pc));
X            return 2;
X        case OP_DEBUG:
X            printf(" line %ld\n", *pc);
X            return 2;
X        case OP_CALL:
X            printf(" %s with %ld args\n", builtinname(pc[0]), pc[1]);
X            return 3;
X        case OP_USERCALL:
X            printf(" %s with %ld args\n", namefunc(pc[0]), pc[1]);
X            return 3;
X        default:
X            printf("\n");
X            return 1;
X    }
X}
X
X
X/*
X * The various opcodes
X */
X
Xstatic void
Xo_nop()
X{
X}
X
X
Xstatic void
Xo_localaddr(fp, locals, index)
X    FUNC *fp;
X    VALUE *locals;
X    long index;
X{
X    if ((unsigned long)index >= fp->f_localcount)
X        math_error("Bad local variable index");
X    locals += index;
X    stack++;
X    stack->v_addr = locals;
X    stack->v_type = V_ADDR;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_globaladdr(fp, sp)
X    FUNC *fp;
X    GLOBAL *sp;
X{
X    if (sp == NULL)
X        math_error("Global variable \"%s\" not initialized", sp->g_name);
X    stack++;
X    stack->v_addr = &sp->g_value;
X    stack->v_type = V_ADDR;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_paramaddr(fp, argcount, args, index)
X    FUNC *fp;
X    int argcount;
X    VALUE *args;
X    long index;
X{
X    if ((unsigned long)index >= argcount)
X        math_error("Bad parameter index");
X    args += index;
X    stack++;
X    if (args->v_type == V_ADDR)
X        stack->v_addr = args->v_addr;
X    else
X        stack->v_addr = args;
X    stack->v_type = V_ADDR;
X}
X
X
Xstatic void
Xo_localvalue(fp, locals, index)
X    FUNC *fp;
X    VALUE *locals;
X    long index;
X{
X    if ((unsigned long)index >= fp->f_localcount)
X        math_error("Bad local variable index");
X    locals += index;
X    copyvalue(locals, ++stack);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_globalvalue(fp, sp)
X    FUNC *fp;
X    GLOBAL *sp;        /* global symbol */
X{
X    if (sp == NULL)
X        math_error("Global variable not defined");
X    copyvalue(&sp->g_value, ++stack);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_paramvalue(fp, argcount, args, index)
X    FUNC *fp;
X    int argcount;
X    VALUE *args;
X    long index;
X{
X    if ((unsigned long)index >= argcount)
X        math_error("Bad paramaeter index");
X    args += index;
X    if (args->v_type == V_ADDR)
X        args = args->v_addr;
X    copyvalue(args, ++stack);
X}
X
X
Xstatic void
Xo_argvalue(fp, argcount, args)
X    FUNC *fp;
X    int argcount;
X    VALUE *args;
X{
X    VALUE *vp;
X    long index;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
X        qisfrac(vp->v_num))
X            math_error("Illegal argument for arg function");
X    if (qiszero(vp->v_num)) {
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = itoq((long) argcount);
X        stack->v_type = V_NUM;
X        return;
X    }
X    index = qtoi(vp->v_num) - 1;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    (void) o_paramvalue(fp, argcount, args, index);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_number(fp, arg)
X    FUNC *fp;
X    long arg;
X{
X    NUMBER *q;
X
X    q = constvalue(arg);
X    if (q == NULL)
X        math_error("Numeric constant value not found");
X    stack++;
X    stack->v_num = qlink(q);
X    stack->v_type = V_NUM;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_imaginary(fp, arg)
X    FUNC *fp;
X    long arg;
X{
X    NUMBER *q;
X    COMPLEX *c;
X
X    q = constvalue(arg);
X    if (q == NULL)
X        math_error("Numeric constant value not found");
X    stack++;
X    if (qiszero(q)) {
X        stack->v_num = qlink(q);
X        stack->v_type = V_NUM;
X        return;
X    }
X    c = comalloc();
X    c->real = qlink(&_qzero_);
X    c->imag = qlink(q);
X    stack->v_com = c;
X    stack->v_type = V_COM;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_string(fp, cp)
X    FUNC *fp;
X    char *cp;
X{
X    stack++;
X    stack->v_str = cp;
X    stack->v_type = V_STR;
X    stack->v_subtype = V_STRLITERAL;
X}
X
X
Xstatic void
Xo_undef()
X{
X    stack++;
X    stack->v_type = V_NULL;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_matcreate(fp, dim)
X    FUNC *fp;
X    long dim;
X{
X    register MATRIX *mp;    /* matrix being defined */
X    NUMBER *num1;        /* first number from stack */
X    NUMBER *num2;        /* second number from stack */
X    VALUE *vp;        /* value being defined */
X    VALUE *v1, *v2;
X    long min[MAXDIM];    /* minimum range */
X    long max[MAXDIM];    /* maximum range */
X    long i;            /* index */
X    long tmp;        /* temporary */
X    long size;        /* size of matrix */
X
X    if ((dim <= 0) || (dim > MAXDIM))
X        math_error("Bad dimension %ld for matrix", dim);
X    if (stack[-2*dim].v_type != V_ADDR)
X        math_error("Attempting to init matrix for non-address");
X    size = 1;
X    for (i = dim - 1; i >= 0; i--) {
X        v1 = &stack[-1];
X        v2 = &stack[0];
X        if (v1->v_type == V_ADDR)
X            v1 = v1->v_addr;
X        if (v2->v_type == V_ADDR)
X            v2 = v2->v_addr;
X        if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
X            math_error("Non-numeric bounds for matrix");
X        num1 = v1->v_num;
X        num2 = v2->v_num;
X        if (qisfrac(num1) || qisfrac(num2))
X            math_error("Non-integral bounds for matrix");
X        if (zisbig(num1->num) || zisbig(num2->num))
X            math_error("Very large bounds for matrix");
X        min[i] = qtoi(num1);
X        max[i] = qtoi(num2);
X        if (min[i] > max[i]) {
X            tmp = min[i];
X            min[i] = max[i];
X            max[i] = tmp;
X        }
X        size *= (max[i] - min[i] + 1);
X        if (size > 10000000)
X            math_error("Very large size for matrix");
X        freevalue(stack--);
X        freevalue(stack--);
X    }
X    mp = matalloc(size);
X    mp->m_dim = dim;
X    for (i = 0; i < dim; i++) {
X        mp->m_min[i] = min[i];
X        mp->m_max[i] = max[i];
X    }
X    vp = mp->m_table;
X    for (i = 0; i < size; i++) {
X        vp->v_type = V_NUM;
X        vp->v_num = qlink(&_qzero_);
X        vp++;
X    }
X    vp = stack[0].v_addr;
X    vp->v_type = V_MAT;
X    vp->v_mat = mp;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_eleminit(fp, index)
X    FUNC *fp;
X    long index;
X{
X    VALUE *vp;
X    VALUE *oldvp;
X    MATRIX *mp;
X    OBJECT *op;
X
X    vp = &stack[-1];
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    switch (vp->v_type) {
X        case V_MAT:
X            mp = vp->v_mat;
X            if ((index < 0) || (index >= mp->m_size))
X                math_error("Too many initializer values");
X            oldvp = &mp->m_table[index];
X            break;
X        case V_OBJ:
X            op = vp->v_obj;
X            if ((index < 0) || (index >= op->o_actions->count))
X                math_error("Too many initializer values");
X            oldvp = &op->o_table[index];
X            break;
X        default:
X            math_error("Attempt to initialize non matrix or object");
X    }
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    freevalue(oldvp);
X    copyvalue(vp, oldvp);
X    stack--;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_indexaddr(fp, dim, writeflag)
X    FUNC *fp;
X    long dim;        /* dimension of matrix */
X    long writeflag;        /* nonzero if element will be written */
X{
X    int i;
X    BOOL flag;
X    VALUE *val;
X    VALUE *vp;
X    VALUE indices[MAXDIM];    /* index values */
X
X    flag = (writeflag != 0);
X    if ((dim <= 0) || (dim > MAXDIM))
X        math_error("Too many dimensions for indexing");
X    val = &stack[-dim];
X    if (val->v_type != V_ADDR)
X        math_error("Non-pointer for index operation");
X    val = val->v_addr;
X    vp = &stack[-dim + 1];
X    for (i = 0; i < dim; i++) {
X        if (vp->v_type == V_ADDR)
X            indices[i] = vp->v_addr[0];
X        else
X            indices[i] = vp[0];
X        vp++;
X    }
X    switch (val->v_type) {
X        case V_MAT:
X            vp = matindex(val->v_mat, flag, dim, indices);
X            break;
X        case V_ASSOC:
X            vp = associndex(val->v_assoc, flag, dim, indices);
X            break;
X        default:
X            math_error("Illegal value for indexing");
X    }
X    while (dim-- > 0)
X        freevalue(stack--);
X    stack->v_type = V_ADDR;
X    stack->v_addr = vp;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_elemaddr(fp, index)
X    FUNC *fp;
X    long index;
X{
X    if (stack->v_type != V_ADDR)
X        math_error("Non-pointer for element reference");
X    if (stack->v_addr->v_type != V_OBJ)
X        math_error("Referencing element of non-object");
X    index = objoffset(stack->v_addr->v_obj, index);
X    if (index < 0)
X        math_error("Element does not exist for object");
X    stack->v_addr = &stack->v_addr->v_obj->o_table[index];
X}
X
X
Xstatic void
Xo_elemvalue(fp, index)
X    FUNC *fp;
X    long index;
X{
X    if (stack->v_type != V_OBJ) {
X        (void) o_elemaddr(fp, index);
X        (void) o_getvalue();
X        return;
X    }
X    index = objoffset(stack->v_obj, index);
X    if (index < 0)
X        math_error("Element does not exist for object");
X    copyvalue(&stack->v_obj->o_table[index], stack);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_objcreate(fp, arg)
X    FUNC *fp;
X    long arg;
X{
X    OBJECT *op;        /* object being created */
X    VALUE *vp;        /* value being defined */
X
X    if (stack->v_type != V_ADDR)
X        math_error("Attempting to init object for non-address");
X    op = objalloc(arg);
X    vp = stack->v_addr;
X    vp->v_type = V_OBJ;
X    vp->v_obj = op;
X}
X
X
Xstatic void
Xo_assign()
X{
X    VALUE *var;        /* variable value */
X    VALUE *vp;
X
X    var = &stack[-1];
X    if (var->v_type != V_ADDR)
X        math_error("Assignment into non-variable");
X    var = var->v_addr;
X    stack[-1] = stack[0];
X    stack--;
X    vp = stack;
X    if (vp->v_type == V_ADDR) {
X        vp = vp->v_addr;
X        if (vp == var)
X            return;
X    }
X    freevalue(var);
X    copyvalue(vp, var);
X}
X
X
Xstatic void
Xo_assignpop()
X{
X    VALUE *var;        /* variable value */
X    VALUE *vp;
X
X    var = &stack[-1];
X    if (var->v_type != V_ADDR)
X        math_error("Assignment into non-variable");
X    var = var->v_addr;
X    vp = &stack[0];
X    if ((vp->v_type == V_ADDR) && (vp->v_addr == var)) {
X        stack -= 2;
X        return;
X    }
X    freevalue(var);
X    if (vp->v_type == V_ADDR)
X        copyvalue(vp->v_addr, var);
X    else
X        *var = *vp;
X    stack -= 2;
X}
X
X
Xstatic void
Xo_swap()
X{
X    VALUE *v1, *v2;        /* variables to be swapped */
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if ((v1->v_type != V_ADDR) || (v2->v_type != V_ADDR))
X        math_error("Swapping non-variables");
X    tmp = v1->v_addr[0];
X    v1->v_addr[0] = v2->v_addr[0];
X    v2->v_addr[0] = tmp;
X    stack--;
X    stack->v_type = V_NULL;
X}
X
X
Xstatic void
Xo_add()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        addvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qadd(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_sub()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        subvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qsub(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_mul()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        mulvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qmul(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_power()
X{
X    VALUE *v1, *v2;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    powivalue(v1, v2, &tmp);
X    freevalue(stack--);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_div()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        divvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qdiv(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_quo()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        quovalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qquo(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_mod()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        modvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = qmod(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_quomod()
X{
X    VALUE *v1, *v2, *v3, *v4;
X    VALUE valquo, valmod;
X    BOOL res;
X
X    v1 = &stack[-3];
X    v2 = &stack[-2];
X    v3 = &stack[-1];
X    v4 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v3->v_type != V_ADDR) || (v4->v_type != V_ADDR))
X        math_error("Non-variable for quomod");
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
X        math_error("Non-reals for quomod");
X    v3 = v3->v_addr;
X    v4 = v4->v_addr;
X    valquo.v_type = V_NUM;
X    valmod.v_type = V_NUM;
X    res = qquomod(v1->v_num, v2->v_num, &valquo.v_num, &valmod.v_num);
X    freevalue(stack--);
X    freevalue(stack--);
X    stack--;
X    stack->v_num = (res ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X    freevalue(v3);
X    freevalue(v4);
X    *v3 = valquo;
X    *v4 = valmod;
X}
X
X
Xstatic void
Xo_and()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
X        math_error("Non-numerics for and");
X    q = qand(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_or()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
X        math_error("Non-numerics for or");
X    q = qor(v1->v_num, v2->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_not()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = testvalue(vp);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qzero_) : qlink(&_qone_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_negate()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        q = qneg(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    negvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_invert()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        q = qinv(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    invertvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_scale()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[0];
X    v2 = &stack[-1];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
X        scalevalue(v2, v1, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    q = v1->v_num;
X    if (qisfrac(q))
X        math_error("Non-integral scaling factor");
X    if (zisbig(q->num))
X        math_error("Very large scaling factor");
X    q = qscale(v2->v_num, qtoi(q));
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_int()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (qisint(vp->v_num) && (stack->v_type == V_NUM))
X            return;
X        q = qint(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    intvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_frac()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        q = qfrac(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    fracvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_abs()
X{
X    VALUE *v1, *v2;
X    NUMBER *q;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM) ||
X        !qispos(v2->v_num))
X    {
X        absvalue(v1, v2, &tmp);
X        freevalue(stack--);
X        freevalue(stack);
X        *stack = tmp;
X        return;
X    }
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack--;
X    if ((stack->v_type == V_NUM) && !qisneg(v1->v_num))
X        return;
X    q = qabs(v1->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_norm()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        q = qsquare(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    normvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_square()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        q = qsquare(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = q;
X        stack->v_type = V_NUM;
X        return;
X    }
X    squarevalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_istype()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if ((v1->v_type != V_OBJ) || (v2->v_type != V_OBJ))
X        r = (v1->v_type == v2->v_type);
X    else
X        r = (v1->v_obj->o_actions == v2->v_obj->o_actions);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) r);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isint()
X{
X    VALUE *vp;
X    NUMBER *q;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = stack->v_addr;
X    if (vp->v_type != V_NUM) {
X        freevalue(stack);
X        stack->v_num = qlink(&_qzero_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    if (qisint(vp->v_num))
X        q = qlink(&_qone_);
X    else
X        q = qlink(&_qzero_);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isnum()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    switch (vp->v_type) {
X        case V_NUM:
X            if (stack->v_type == V_NUM)
X                qfree(stack->v_num);
X            break;
X        case V_COM:
X            if (stack->v_type == V_COM)
X                comfree(stack->v_com);
X            break;
X        default:
X            freevalue(stack);
X            stack->v_num = qlink(&_qzero_);
X            stack->v_type = V_NUM;
X            return;
X    }
X    stack->v_num = qlink(&_qone_);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_ismat()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_MAT) {
X        freevalue(stack);
X        stack->v_num = qlink(&_qzero_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    freevalue(stack);
X    stack->v_type = V_NUM;
X    stack->v_num = qlink(&_qone_);
X}
X
X
Xstatic void
Xo_islist()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = (vp->v_type == V_LIST);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isobj()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = (vp->v_type == V_OBJ);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isstr()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = (vp->v_type == V_STR);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isfile()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = (vp->v_type == V_FILE);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isassoc()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = (vp->v_type == V_ASSOC);
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_issimple()
X{
X    VALUE *vp;
X    int r;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    r = 0;
X    switch (vp->v_type) {
X        case V_NULL:
X        case V_NUM:
X        case V_COM:
X        case V_STR:
X            r = 1;
X    }
X    freevalue(stack);
X    stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isodd()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = qlink(&_qone_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    freevalue(stack);
X    stack->v_num = qlink(&_qzero_);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_iseven()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = qlink(&_qone_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    freevalue(stack);
X    stack->v_num = qlink(&_qzero_);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isreal()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = qlink(&_qone_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    freevalue(stack);
X    stack->v_num = qlink(&_qzero_);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_isnull()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NULL) {
X        freevalue(stack);
X        stack->v_num = qlink(&_qzero_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    freevalue(stack);
X    stack->v_num = qlink(&_qone_);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_re()
X{
X    VALUE *vp;
X    NUMBER *q;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (stack->v_type == V_ADDR) {
X            stack->v_num = qlink(vp->v_num);
X            stack->v_type = V_NUM;
X        }
X        return;
X    }
X    if (vp->v_type != V_COM)
X        math_error("Taking real part of non-number");
X    q = qlink(vp->v_com->real);
X    if (stack->v_type == V_COM)
X        comfree(stack->v_com);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_im()
X{
X    VALUE *vp;
X    NUMBER *q;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack->v_num = qlink(&_qzero_);
X        stack->v_type = V_NUM;
X        return;
X    }
X    if (vp->v_type != V_COM)
X        math_error("Taking imaginary part of non-number");
X    q = qlink(vp->v_com->imag);
X    if (stack->v_type == V_COM)
X        comfree(stack->v_com);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_conjugate()
X{
X    VALUE *vp;
X    VALUE tmp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (stack->v_type == V_ADDR) {
X            stack->v_num = qlink(vp->v_num);
X            stack->v_type = V_NUM;
X        }
X        return;
X    }
X    conjvalue(vp, &tmp);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_fiaddr()
X{
X    register MATRIX *m;    /* current matrix element */
X    NUMBER *q;        /* index value */
X    LIST *lp;        /* list header */
X    ASSOC *ap;        /* association header */
X    VALUE *vp;        /* stack value */
X    long index;        /* index value as an integer */
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NUM)
X        math_error("Fast indexing by non-number");
X    q = vp->v_num;
X    if (qisfrac(q))
X        math_error("Fast indexing by non-integer");
X    index = qtoi(q);
X    if (zisbig(q->num) || (index < 0))
X        math_error("Index out of range for fast indexing");
X    if (stack->v_type == V_NUM)
X        qfree(q);
X    stack--;
X    vp = stack;
X    if (vp->v_type != V_ADDR)
X        math_error("Bad value for fast indexing");
X    switch (vp->v_addr->v_type) {
X        case V_OBJ:
X            if (index >= vp->v_addr->v_obj->o_actions->count)
X                math_error("Index out of bounds for object");
X            vp->v_addr = vp->v_addr->v_obj->o_table + index;
X            break;
X        case V_MAT:
X            m = vp->v_addr->v_mat;
X            if (index >= m->m_size)
X                math_error("Index out of bounds for matrix");
X            vp->v_addr = m->m_table + index;
X            break;
X        case V_LIST:
X            lp = vp->v_addr->v_list;
X            vp->v_addr = listfindex(lp, index);
X            if (vp->v_addr == NULL)
X                math_error("Index out of bounds for list");
X            break;
X        case V_ASSOC:
X            ap = vp->v_addr->v_assoc;
X            vp->v_addr = assocfindex(ap, index);
X            if (vp->v_addr == NULL)
X                math_error("Index out of bounds for association");
X            break;
X        default:
X            math_error("Bad variable type for fast indexing");
X    }
X}
X
X
Xstatic void
Xo_fivalue()
X{
X    (void) o_fiaddr();
X    (void) o_getvalue();
X}
X
X
Xstatic void
Xo_sgn()
X{
X    VALUE *vp;
X    NUMBER *q;
X    VALUE val;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    switch (vp->v_type) {
X        case V_NUM:
X            q = qsign(vp->v_num);
X            if (stack->v_type == V_NUM)
X                qfree(vp->v_num);
X            stack->v_num = q;
X            stack->v_type = V_NUM;
X            break;
X        case V_OBJ:
X            val = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
X            q = itoq(val.v_int);
X            freevalue(stack);
X            stack->v_num = q;
X            stack->v_type = V_NUM;
X            break;
X        default:
X            math_error("Bad value for sgn");
X    }
X}
X
X
Xstatic void
Xo_numerator()
X{
X    VALUE *vp;
X    NUMBER *q;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NUM)
X        math_error("Numerator of non-number");
X    if ((stack->v_type == V_NUM) && qisint(vp->v_num))
X        return;
X    q = qnum(vp->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_denominator()
X{
X    VALUE *vp;
X    NUMBER *q;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NUM)
X        math_error("Denominator of non-number");
X    q = qden(vp->v_num);
X    if (stack->v_type == V_NUM)
X        qfree(stack->v_num);
X    stack->v_num = q;
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_duplicate()
X{
X    copyvalue(stack, stack + 1);
X    stack++;
X}
X
X
Xstatic void
Xo_dupvalue()
X{
X    if (stack->v_type == V_ADDR)
X        copyvalue(stack->v_addr, stack + 1);
X    else
X        copyvalue(stack, stack + 1);
X    stack++;
X}
X
X
Xstatic void
Xo_pop()
X{
X    freevalue(stack--);
X}
X
X
Xstatic void
Xo_return()
X{
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_jumpeq(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    VALUE *vp;
X    int i;            /* result of comparison */
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        i = !qiszero(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X    } else {
X        i = testvalue(vp);
X        freevalue(stack);
X    }
X    stack--;
X    if (!i)
X        *dojump = TRUE;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_jumpne(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    VALUE *vp;
X    int i;            /* result of comparison */
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        i = !qiszero(vp->v_num);
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X    } else {
X        i = testvalue(vp);
X        freevalue(stack);
X    }
X    stack--;
X    if (i)
X        *dojump = TRUE;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_condorjump(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (!qiszero(vp->v_num)) {
X            *dojump = TRUE;
X            return;
X        }
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack--;
X        return;
X    }
X    if (testvalue(vp))
X        *dojump = TRUE;
X    else
X        freevalue(stack--);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_condandjump(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type == V_NUM) {
X        if (qiszero(vp->v_num)) {
X            *dojump = TRUE;
X            return;
X        }
X        if (stack->v_type == V_NUM)
X            qfree(stack->v_num);
X        stack--;
X        return;
X    }
X    if (!testvalue(vp))
X        *dojump = TRUE;
X    else
X        freevalue(stack--);
X}
X
X
X/*
X * Compare the top two values on the stack for equality and jump if they are
X * different, popping off the top element, leaving the first one on the stack.
X * If they are equal, pop both values and do not jump.
X */
X/*ARGSUSED*/
Xstatic void
Xo_casejump(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = comparevalue(v1, v2);
X    freevalue(stack--);
X    if (r)
X        *dojump = TRUE;
X    else
X        freevalue(stack--);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_jump(fp, dojump)
X    FUNC *fp;
X    BOOL *dojump;
X{
X    *dojump = TRUE;
X}
X
X
Xstatic void
Xo_usercall(fp, index, argcount)
X    FUNC *fp;
X    long index, argcount;
X{
X    fp = findfunc(index);
X    if (fp == NULL)
X        math_error("Function \"%s\" is undefined", namefunc(index));
X    calculate(fp, (int) argcount);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_call(fp, index, argcount)
X    FUNC *fp;
X    long index, argcount;
X{
X    VALUE result;
X
X    result = builtinfunc(index, (int) argcount, stack);
X    while (--argcount >= 0)
X        freevalue(stack--);
X    stack++;
X    *stack = result;
X}
X
X
Xstatic void
Xo_getvalue()
X{
X    if (stack->v_type == V_ADDR)
X        copyvalue(stack->v_addr, stack);
X}
X
X
Xstatic void
Xo_cmp()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = relvalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) r);
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_eq()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = comparevalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r == 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_ne()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = comparevalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r != 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_le()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = relvalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r <= 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_ge()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = relvalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r >= 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_lt()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = relvalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r < 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_gt()
X{
X    VALUE *v1, *v2;
X    int r;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    r = relvalue(v1, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    stack->v_num = itoq((long) (r > 0));
X    stack->v_type = V_NUM;
X}
X
X
Xstatic void
Xo_preinc()
X{
X    NUMBER *q, **np;
X    VALUE *vp, tmp;
X
X    if (stack->v_type != V_ADDR)
X        math_error("Preincrementing non-variable");
X    if (stack->v_addr->v_type == V_NUM) {
X        np = &stack->v_addr->v_num;
X        q = qinc(*np);
X        qfree(*np);
X        *np = q;
X        stack->v_type = V_NUM;
X        stack->v_num = qlink(q);
X        return;
X    }
X    vp = stack->v_addr;
X    incvalue(vp, &tmp);
X    freevalue(vp);
X    *vp = tmp;
X    copyvalue(&tmp, stack);
X}
X
X
Xstatic void
Xo_predec()
X{
X    NUMBER *q, **np;
X    VALUE *vp, tmp;
X
X    if (stack->v_type != V_ADDR)
X        math_error("Predecrementing non-variable");
X    if (stack->v_addr->v_type == V_NUM) {
X        np = &stack->v_addr->v_num;
X        q = qdec(*np);
X        qfree(*np);
X        *np = q;
X        stack->v_type = V_NUM;
X        stack->v_num = qlink(q);
X        return;
X    }
X    vp = stack->v_addr;
X    decvalue(vp, &tmp);
X    freevalue(vp);
X    *vp = tmp;
X    copyvalue(&tmp, stack);
X}
X
X
Xstatic void
Xo_postinc()
X{
X    NUMBER *q, **np;
X    VALUE *vp, tmp;
X
X    if (stack->v_type != V_ADDR)
X        math_error("Postincrementing non-variable");
X    if (stack->v_addr->v_type == V_NUM) {
X        np = &stack->v_addr->v_num;
X        q = *np;
X        *np = qinc(q);
X        stack->v_type = V_NUM;
X        stack->v_num = q;
X        return;
X    }
X    vp = stack->v_addr;
X    tmp = *vp;
X    incvalue(&tmp, vp);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_postdec()
X{
X    NUMBER *q, **np;
X    VALUE *vp, tmp;
X
X    if (stack->v_type != V_ADDR)
X        math_error("Postdecrementing non-variable");
X    if (stack->v_addr->v_type == V_NUM) {
X        np = &stack->v_addr->v_num;
X        q = *np;
X        *np = qdec(q);
X        stack->v_type = V_NUM;
X        stack->v_num = q;
X        return;
X    }
X    vp = stack->v_addr;
X    tmp = *vp;
X    decvalue(&tmp, vp);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_leftshift()
X{
X    VALUE *v1, *v2;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    shiftvalue(v1, v2, FALSE, &tmp);
X    freevalue(stack--);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_rightshift()
X{
X    VALUE *v1, *v2;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    shiftvalue(v1, v2, TRUE, &tmp);
X    freevalue(stack--);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_debug(fp, line)
X    FUNC *fp;
X    long line;
X{
X    funcline = line;
X    if (abortlevel >= ABORT_STATEMENT)
X        math_error("Calculation aborted at statement boundary");
X}
X
X
Xstatic void
Xo_printresult()
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NULL) {
X        math_chr('\t');
X        printvalue(vp, PRINT_UNAMBIG);
X        math_chr('\n');
X        math_flush();
X    }
X    freevalue(stack--);
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_print(fp, flags)
X    FUNC *fp;
X    long flags;
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    printvalue(vp, (int) flags);
X    freevalue(stack--);
X    if (traceflags & TRACE_OPCODES)
X        printf("\n");
X    math_flush();
X}
X
X
Xstatic void
Xo_printeol()
X{
X    math_chr('\n');
X    math_flush();
X}
X
X
Xstatic void
Xo_printspace()
X{
X    math_chr(' ');
X    if (traceflags & TRACE_OPCODES)
X        printf("\n");
X}
X
X
X/*ARGSUSED*/
Xstatic void
Xo_printstring(fp, cp)
X    FUNC *fp;
X    char *cp;
X{
X    math_str(cp);
X    if (traceflags & TRACE_OPCODES)
X        printf("\n");
X    math_flush();
X}
X
X
Xstatic void
Xo_zero()
X{
X    stack++;
X    stack->v_type = V_NUM;
X    stack->v_num = qlink(&_qzero_);
X}
X
X
Xstatic void
Xo_one()
X{
X    stack++;
X    stack->v_type = V_NUM;
X    stack->v_num = qlink(&_qone_);
X}
X
X
Xstatic void
Xo_save(fp)
X    FUNC *fp;
X{
X    VALUE *vp;
X
X    vp = stack;
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    freevalue(&fp->f_savedvalue);
X    copyvalue(vp, &fp->f_savedvalue);
X}
X
X
Xstatic void
Xo_oldvalue()
X{
X    copyvalue(&oldvalue, ++stack);
X}
X
X
Xstatic void
Xo_quit(fp, cp)
X    FUNC *fp;
X    char *cp;
X{
X    if ((fp->f_name[0] == '*') && (fp->f_name[1] == '\0')) {
X        if (cp)
X            printf("%s\n", cp);
X        hist_term();
X        exit(0);
X    }
X    if (cp)
X        math_error("%s", cp);
X    math_error("quit statement executed");
X}
X
X
Xstatic void
Xo_getepsilon()
X{
X    stack++;
X    stack->v_type = V_NUM;
X    stack->v_num = qlink(_epsilon_);
X}
X
X
Xstatic void
Xo_setepsilon()
X{
X    VALUE *vp;
X    NUMBER *newep;
X
X    vp = &stack[0];
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_NUM)
X        math_error("Non-numeric for epsilon");
X    newep = vp->v_num;
X    stack->v_num = qlink(_epsilon_);
X    setepsilon(newep);
X    qfree(newep);
X}
X
X
Xstatic void
Xo_setconfig()
X{
X    int type;
X    VALUE *v1, *v2;
X    VALUE tmp;
X
X    v1 = &stack[-1];
X    v2 = &stack[0];
X    if (v1->v_type == V_ADDR)
X        v1 = v1->v_addr;
X    if (v2->v_type == V_ADDR)
X        v2 = v2->v_addr;
X    if (v1->v_type != V_STR)
X        math_error("Non-string for config");
X    type = configtype(v1->v_str);
X    if (type < 0)
X        math_error("Unknown config name \"%s\"", v1->v_str);
X    getconfig(type, &tmp);
X    setconfig(type, v2);
X    freevalue(stack--);
X    freevalue(stack);
X    *stack = tmp;
X}
X
X
Xstatic void
Xo_getconfig()
X{
X    int type;
X    VALUE *vp;
X
X    vp = &stack[0];
X    if (vp->v_type == V_ADDR)
X        vp = vp->v_addr;
X    if (vp->v_type != V_STR)
X        math_error("Non-string for config");
X    type = configtype(vp->v_str);
X    if (type < 0)
X        math_error("Unknown config name \"%s\"", vp->v_str);
X    freevalue(stack);
X    getconfig(type, stack);
X}
X
X
X/*
X * Set the 'old' value to the last value saved during the calculation.
X */
Xvoid
Xupdateoldvalue(fp)
X    FUNC *fp;
X{
X    if (fp->f_savedvalue.v_type == V_NULL)
X        return;
X    freevalue(&oldvalue);
X    oldvalue = fp->f_savedvalue;
X    fp->f_savedvalue.v_type = V_NULL;
X}
X
X
X/*
X * Routine called on any runtime error, to complain about it (with possible
X * arguments), and then longjump back to the top level command scanner.
X */
X#ifdef VARARGS
X# define VA_ALIST fmt, va_alist
X# define VA_DCL char *fmt; va_dcl
X#else
X# ifdef __STDC__
X#  define VA_ALIST char *fmt, ...
X#  define VA_DCL
X# else
X#  define VA_ALIST fmt
X#  define VA_DCL char *fmt;
X# endif
X#endif
X/*VARARGS*/
Xvoid
Xmath_error(VA_ALIST)
X    VA_DCL
X{
X    va_list ap;
X    char buf[MAXERROR+1];
X
X    if (funcname && (*funcname != '*'))
X        fprintf(stderr, "\"%s\": ", funcname);
X    if (funcline && ((funcname && (*funcname != '*')) || !inputisterminal()))
X        fprintf(stderr, "line %ld: ", funcline);
X#ifdef VARARGS
X    va_start(ap);
X#else
X    va_start(ap, fmt);
SHAR_EOF
echo "End of part 7"
echo "File calc2.9.0/opcodes.c is continued in part 8"
echo "8" > s2_seq_.tmp
exit 0