home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Utilities / Calc / opcodes.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-10  |  50.4 KB  |  2,658 lines  |  [TEXT/????]
  1. /*
  2.  * Copyright (c) 1992 David I. Bell
  3.  * Permission is granted to use, distribute, or modify this source,
  4.  * provided that this copyright notice remains intact.
  5.  *
  6.  * Opcode execution module
  7.  */
  8.  
  9. #include "xstdarg.h"
  10. #include "calc.h"
  11. #include "opcodes.h"
  12. #include "func.h"
  13. #include "symbol.h"
  14.  
  15. #define    QUICKLOCALS    20        /* local vars to handle quickly */
  16.  
  17.  
  18. VALUE *stack;                /* current location of top of stack */
  19. static VALUE stackarray[MAXSTACK];    /* storage for stack */
  20. static VALUE oldvalue;            /* previous calculation value */
  21. static char *funcname;            /* function being executed */
  22. static long funcline;            /* function line being executed */
  23.  
  24. FLAG traceflags;            /* current trace flags */
  25.  
  26.  
  27. /*
  28.  * Routine definitions
  29.  */
  30. static long o_nop(), o_localaddr(), o_globaladdr(), o_paramaddr();
  31. static long o_globalvalue(), o_paramvalue(), o_number(), o_indexaddr();
  32. static long o_indexvalue(), o_assign(), o_add(), o_sub(), o_mul(), o_div();
  33. static long o_mod(), o_save(), o_negate(), o_invert(), o_int(), o_frac();
  34. static long o_numerator(), o_denominator(), o_duplicate(), o_pop();
  35. static long o_jumpeq(), o_jumpne(), o_jump(), o_usercall(), o_getvalue();
  36. static long o_eq(), o_ne(), o_le(), o_ge(), o_lt(), o_gt(), o_preinc();
  37. static long o_postinc(), o_postdec(), o_debug(), o_print(), o_assignpop();
  38. static long o_zero(), o_one(), o_printeol(), o_printspace(), o_printstring();
  39. static long o_oldvalue(), o_quo(), o_power(), o_quit(), o_call(), o_swap();
  40. static long o_dupvalue(), o_getepsilon(), o_and(), o_or(), o_not();
  41. static long o_abs(), o_sgn(), o_isint(), o_condorjump(), o_condandjump();
  42. static long o_square(), o_string(), o_isnum(), o_undef(), o_isnull();
  43. static long o_matinit(), o_ismat(), o_isstr(), o_getconfig(), o_predec();
  44. static long o_leftshift(), o_rightshift(), o_casejump();
  45. static long o_isodd(), o_iseven(), o_fiaddr(), o_fivalue(), o_argvalue();
  46. static long o_isreal(), o_imaginary(), o_re(), o_im(), o_conjugate();
  47. static long o_objinit(), o_isobj(), o_norm(), o_elemaddr(), o_elemvalue();
  48. static long o_istype(), o_scale(), o_localvalue(), o_return(), o_islist();
  49. static long o_issimple(), o_cmp(), o_quomod(), o_setconfig(), o_setepsilon();
  50. static long o_printresult(), o_isfile();
  51.  
  52.  
  53. /*
  54.  * Types of opcodes (depends on arguments saved after the opcode).
  55.  */
  56. #define OPNUL    1    /* opcode has no arguments */
  57. #define OPONE    2    /* opcode has one integer argument */
  58. #define OPTWO    3    /* opcode has two integer arguments */
  59. #define OPJMP    4    /* opcode is a jump (with one integer argument) */
  60. #define OPRET    5    /* opcode is a return (with no argument) */
  61. #define OPGLB    6    /* opcode has global symbol pointer argument */
  62. #define OPPAR    7    /* opcode has parameter index argument */
  63. #define OPLOC    8    /* opcode needs local variable pointer (with one arg) */
  64. #define OPSTR    9    /* opcode has a string constant arg */
  65. #define OPARG    10    /* opcode is given number of arguments */
  66.  
  67.  
  68. /*
  69.  * Information about each opcode.
  70.  */
  71. static struct opcode {
  72.     long (*o_func)();    /* routine to call for opcode */
  73.     int o_type;        /* type of opcode */
  74.     char *o_name;        /* name of opcode */
  75. } opcodes[MAX_OPCODE+1] = {
  76.     o_nop,        OPNUL,  "NOP",        /* no operation */
  77.     o_localaddr,    OPLOC,  "LOCALADDR",    /* address of local variable */
  78.     o_globaladdr,    OPGLB,  "GLOBALADDR",    /* address of global variable */
  79.     o_paramaddr,    OPPAR,  "PARAMADDR",    /* address of paramater variable */
  80.     o_localvalue,    OPLOC,  "LOCALVALUE",    /* value of local variable */
  81.     o_globalvalue,    OPGLB,  "GLOBALVALUE",    /* value of global variable */
  82.     o_paramvalue,    OPPAR,  "PARAMVALUE",     /* value of paramater variable */
  83.     o_number,    OPONE,  "NUMBER",    /* constant real numeric value */
  84.     o_indexaddr,    OPONE,  "INDEXADDR",    /* array index address */
  85.     o_indexvalue,    OPONE,  "INDEXVALUE",     /* array value */
  86.     o_assign,    OPNUL,  "ASSIGN",    /* assign value to variable */
  87.     o_add,        OPNUL,  "ADD",        /* add top two values */
  88.     o_sub,        OPNUL,  "SUB",        /* subtract top two values */
  89.     o_mul,        OPNUL,  "MUL",        /* multiply top two values */
  90.     o_div,        OPNUL,  "DIV",        /* divide top two values */
  91.     o_mod,        OPNUL,  "MOD",        /* take mod of top two values */
  92.     o_save,        OPNUL,  "SAVE",        /* save value for later use */
  93.     o_negate,    OPNUL,  "NEGATE",    /* negate top value */
  94.     o_invert,    OPNUL,  "INVERT",    /* invert top value */
  95.     o_int,        OPNUL,  "INT",        /* take integer part */
  96.     o_frac,        OPNUL,  "FRAC",        /* take fraction part */
  97.     o_numerator,    OPNUL,  "NUMERATOR",    /* take numerator */
  98.     o_denominator,    OPNUL,  "DENOMINATOR",    /* take denominator */
  99.     o_duplicate,    OPNUL,  "DUPLICATE",    /* duplicate top value */
  100.     o_pop,        OPNUL,  "POP",        /* pop top value */
  101.     o_return,    OPRET,  "RETURN",    /* return value of function */
  102.     o_jumpeq,    OPJMP,  "JUMPEQ",    /* jump if value zero */
  103.     o_jumpne,    OPJMP,  "JUMPNE",    /* jump if value nonzero */
  104.     o_jump,        OPJMP,  "JUMP",        /* jump unconditionally */
  105.     o_usercall,    OPTWO,  "USERCALL",    /* call a user function */
  106.     o_getvalue,    OPNUL,  "GETVALUE",    /* convert address to value */
  107.     o_eq,        OPNUL,  "EQ",        /* test elements for equality */
  108.     o_ne,        OPNUL,  "NE",        /* test elements for inequality */
  109.     o_le,        OPNUL,  "LE",        /* test elements for <= */
  110.     o_ge,        OPNUL,  "GE",        /* test elements for >= */
  111.     o_lt,        OPNUL,  "LT",        /* test elements for < */
  112.     o_gt,        OPNUL,  "GT",        /* test elements for > */
  113.     o_preinc,    OPNUL,  "PREINC",    /* add one to variable (++x) */
  114.     o_predec,    OPNUL,  "PREDEC",    /* subtract one from variable (--x) */
  115.     o_postinc,    OPNUL,  "POSTINC",    /* add one to variable (x++) */
  116.     o_postdec,    OPNUL,  "POSTDEC",    /* subtract one from variable (x--) */
  117.     o_debug,    OPONE,  "DEBUG",    /* debugging point */
  118.     o_print,    OPONE,  "PRINT",    /* print value */
  119.     o_assignpop,    OPNUL,  "ASSIGNPOP",    /* assign to variable and pop it */
  120.     o_zero,        OPNUL,  "ZERO",        /* put zero on the stack */
  121.     o_one,        OPNUL,  "ONE",        /* put one on the stack */
  122.     o_printeol,    OPNUL,  "PRINTEOL",    /* print end of line */
  123.     o_printspace,    OPNUL,  "PRINTSPACE",    /* print a space */
  124.     o_printstring,    OPSTR,  "PRINTSTR",    /* print constant string */
  125.     o_dupvalue,    OPNUL,  "DUPVALUE",    /* duplicate value of top value */
  126.     o_oldvalue,    OPNUL,  "OLDVALUE",    /* old value from previous calc */
  127.     o_quo,        OPNUL,  "QUO",        /* integer quotient of top values */
  128.     o_power,    OPNUL,  "POWER",    /* value raised to a power */
  129.     o_quit,        OPSTR,  "QUIT",        /* quit program */
  130.     o_call,        OPTWO,  "CALL",        /* call built-in routine */
  131.     o_getepsilon,    OPNUL,  "GETEPSILON",    /* get allowed error for calculations */
  132.     o_and,        OPNUL,  "AND",        /* arithmetic and or top two values */
  133.     o_or,        OPNUL,  "OR",        /* arithmetic or of top two values */
  134.     o_not,        OPNUL,  "NOT",        /* logical not or top value */
  135.     o_abs,        OPNUL,  "ABS",        /* absolute value of top value */
  136.     o_sgn,        OPNUL,  "SGN",        /* sign of number */
  137.     o_isint,    OPNUL,  "ISINT",    /* whether number is an integer */
  138.     o_condorjump,    OPJMP,  "CONDORJUMP",    /* conditional or jump */
  139.     o_condandjump,    OPJMP,  "CONDANDJUMP",    /* conditional and jump */
  140.     o_square,    OPNUL,  "SQUARE",    /* square top value */
  141.     o_string,    OPSTR,  "STRING",    /* string constant value */
  142.     o_isnum,    OPNUL,  "ISNUM",    /* whether value is a number */
  143.     o_undef,    OPNUL,  "UNDEF",    /* load undefined value on stack */
  144.     o_isnull,    OPNUL,  "ISNULL",    /* whether value is the null value */
  145.     o_argvalue,    OPARG,  "ARGVALUE",    /* load value of arg (parameter) n */
  146.     o_matinit,    OPONE,  "MATINIT",    /* initialize matrix */
  147.     o_ismat,    OPNUL,  "ISMAT",    /* whether value is a matrix */
  148.     o_isstr,    OPNUL,  "ISSTR",    /* whether value is a string */
  149.     o_getconfig,    OPNUL,  "GETCONFIG",    /* get value of configuration parameter */
  150.     o_leftshift,    OPNUL,  "LEFTSHIFT",    /* left shift of integer */
  151.     o_rightshift,    OPNUL,  "RIGHTSHIFT",    /* right shift of integer */
  152.     o_casejump,    OPJMP,  "CASEJUMP",    /* test case and jump if not matched */
  153.     o_isodd,    OPNUL,  "ISODD",    /* whether value is odd integer */
  154.     o_iseven,    OPNUL,  "ISEVEN",    /* whether value is even integer */
  155.     o_fiaddr,    OPNUL,  "FIADDR",    /* 'fast index' matrix address */
  156.     o_fivalue,    OPNUL,  "FIVALUE",    /* 'fast index' matrix value */
  157.     o_isreal,    OPNUL,  "ISREAL",    /* whether value is real number */
  158.     o_imaginary,    OPONE,  "IMAGINARY",    /* constant imaginary numeric value */
  159.     o_re,        OPNUL,  "RE",        /* real part of complex number */
  160.     o_im,        OPNUL,  "IM",        /* imaginary part of complex number */
  161.     o_conjugate,    OPNUL,  "CONJUGATE",    /* complex conjugate */
  162.     o_objinit,    OPONE,  "OBJINIT",    /* initialize object */
  163.     o_isobj,    OPNUL,  "ISOBJ",    /* whether value is an object */
  164.     o_norm,        OPNUL,  "NORM",        /* norm of value (square of abs) */
  165.     o_elemaddr,    OPONE,  "ELEMADDR",    /* address of element of object */
  166.     o_elemvalue,    OPONE,  "ELEMVALUE",    /* value of element of object */
  167.     o_istype,    OPNUL,  "ISTYPE",    /* whether types are the same */
  168.     o_scale,    OPNUL,  "SCALE",    /* scale value by a power of two */
  169.     o_islist,    OPNUL,    "ISLIST",    /* whether value is a list */
  170.     o_swap,        OPNUL,    "SWAP",        /* swap values of two variables */
  171.     o_issimple,    OPNUL,    "ISSIMPLE",    /* whether value is simple type */
  172.     o_cmp,        OPNUL,    "CMP",        /* compare values returning -1, 0, 1 */
  173.     o_quomod,    OPNUL,    "QUOMOD",    /* calculate quotient and remainder */
  174.     o_setconfig,    OPNUL,    "SETCONFIG",    /* set configuration parameter */
  175.     o_setepsilon,    OPNUL,  "SETEPSILON",    /* set allowed error for calculations */
  176.     o_printresult,    OPNUL,  "PRINTRESULT",    /* print result of top-level expression */
  177.     o_isfile,    OPNUL,  "ISFILE"    /* whether value is a file */
  178. };
  179.  
  180.  
  181.  
  182. /*
  183.  * Initialize the stack.
  184.  */
  185. void
  186. initstack()
  187. {
  188.     if (stack == NULL)
  189.         stack = stackarray;
  190.     while (stack != stackarray)
  191.         freevalue(stack--);
  192. }
  193.  
  194.  
  195. /*
  196.  * Compute the result of a function by interpreting opcodes.
  197.  * Arguments have just been pushed onto the evaluation stack.
  198.  */
  199. void
  200. calculate(fp, argcount)
  201.     register FUNC *fp;        /* function to calculate */
  202.     int argcount;            /* number of arguments called with */
  203. {
  204.     register unsigned long pc;    /* current pc inside function */
  205.     register struct opcode *op;    /* current opcode pointer */
  206.     register VALUE *locals;        /* pointer to local variables */
  207.     long oldline;            /* old value of line counter */
  208.     unsigned int opnum;        /* current opcode number */
  209.     int origargcount;        /* original number of arguments */
  210.     int i;                /* loop counter */
  211.     char *oldname;            /* old function name being executed */
  212.     VALUE *beginstack;        /* beginning of stack frame */
  213.     VALUE *args;            /* pointer to function arguments */
  214.     VALUE retval;            /* function return value */
  215.     VALUE localtable[QUICKLOCALS];    /* some local variables */
  216.  
  217.     oldname = funcname;
  218.     oldline = funcline;
  219.     funcname = fp->f_name;
  220.     funcline = 0;
  221.     origargcount = argcount;
  222.     while (argcount < fp->f_paramcount) {
  223.         stack++;
  224.         stack->v_type = V_NULL;
  225.         argcount++;
  226.     }
  227.     locals = localtable;
  228.     if (fp->f_localcount > QUICKLOCALS) {
  229.         locals = (VALUE *) malloc(sizeof(VALUE) * fp->f_localcount);
  230.         if (locals == NULL)
  231.             error("No memory for local variables");
  232.     }
  233.     for (i = 0; i < fp->f_localcount; i++)
  234.         locals[i].v_type = V_NULL;
  235.     pc = 0;
  236.     beginstack = stack;
  237.     args = beginstack - (argcount - 1);
  238.     for (;;) {
  239.         if (abortlevel >= ABORT_OPCODE)
  240.             error("Calculation aborted in opcode");
  241.         if (pc >= fp->f_opcodecount)
  242.             error("Function pc out of range");
  243.         if (stack > &stackarray[MAXSTACK-3])
  244.             error("Evaluation stack depth exceeded");
  245.         opnum = fp->f_opcodes[pc];
  246.         if (opnum > MAX_OPCODE)
  247.             error("Function opcode out of range");
  248.         op = &opcodes[opnum];
  249.         if (traceflags & TRACE_OPCODES) {
  250.             printf("%8s, pc %4ld:  ", fp->f_name, pc);
  251.             (void)dumpop(&fp->f_opcodes[pc]);
  252.         }
  253.         /*
  254.          * Now call the opcode routine appropriately.
  255.          */
  256.         pc++;
  257.         switch (op->o_type) {
  258.         case OPNUL:    /* no extra arguments */
  259.             (*op->o_func)(fp);
  260.             break;
  261.  
  262.         case OPONE:    /* one extra integer argument */
  263.             (*op->o_func)(fp, fp->f_opcodes[pc++]);
  264.             break;
  265.  
  266.         case OPTWO:    /* two extra integer arguments */
  267.             (*op->o_func)(fp, fp->f_opcodes[pc],
  268.                 fp->f_opcodes[pc+1]);
  269.             pc += 2;
  270.             break;
  271.  
  272.         case OPJMP:    /* jump opcodes (one extra integer arg) */
  273.             pc = (*op->o_func)(fp, pc);
  274.             break;
  275.  
  276.         case OPGLB:    /* global symbol reference (pointer arg) */
  277.         case OPSTR:    /* string constant address */
  278.             (*op->o_func)(fp, *((char **) &fp->f_opcodes[pc]));
  279.             pc += PTR_SIZE;
  280.             break;
  281.  
  282.         case OPLOC:    /* local variable reference */
  283.             (*op->o_func)(fp, locals, fp->f_opcodes[pc++]);
  284.             break;
  285.  
  286.         case OPPAR:    /* parameter variable reference */
  287.             (*op->o_func)(fp, argcount, args, fp->f_opcodes[pc++]);
  288.             break;
  289.  
  290.         case OPARG:    /* parameter variable reference */
  291.             (*op->o_func)(fp, origargcount, args);
  292.             break;
  293.  
  294.         case OPRET:    /* return from function */
  295.             if (stack->v_type == V_ADDR)
  296.                 copyvalue(stack->v_addr, stack);
  297.             for (i = 0; i < fp->f_localcount; i++)
  298.                 freevalue(&locals[i]);
  299.             if (locals != localtable)
  300.                 free(locals);
  301.             if (stack != &beginstack[1])
  302.                 error("Misaligned stack");
  303.             if (argcount <= 0) {
  304.                 funcname = oldname;
  305.                 funcline = oldline;
  306.                 return;
  307.             }
  308.             retval = *stack--;
  309.             while (--argcount >= 0)
  310.                 freevalue(stack--);
  311.             *++stack = retval;
  312.             funcname = oldname;
  313.             funcline = oldline;
  314.             return;
  315.  
  316.         default:
  317.             error("Unknown opcode type");
  318.         }
  319.     }
  320. }
  321.  
  322.  
  323. /*
  324.  * Dump an opcode at a particular address.
  325.  * Returns the size of the opcode so that it can easily be skipped over.
  326.  */
  327. int
  328. dumpop(pc)
  329.     long *pc;        /* location of the opcode */
  330. {
  331.     unsigned long op;    /* opcode number */
  332.  
  333.     op = *pc++;
  334.     if (op <= MAX_OPCODE)
  335.         printf("%s", opcodes[op].o_name);
  336.     else
  337.         printf("OP%ld", op);
  338.     switch (op) {
  339.         case OP_LOCALADDR: case OP_LOCALVALUE:
  340.             printf(" %s\n", localname(*pc));
  341.             return 2;
  342.         case OP_GLOBALADDR: case OP_GLOBALVALUE:
  343.             printf(" %s\n", globalname((GLOBAL *) pc));
  344.             return (1 + PTR_SIZE);
  345.         case OP_PARAMADDR: case OP_PARAMVALUE:
  346.             printf(" %s\n", paramname(*pc));
  347.             return 2;
  348.         case OP_PRINTSTRING: case OP_STRING:
  349.             printf(" \"%s\"\n", *((char **) pc));
  350.             return (1 + PTR_SIZE);
  351.         case OP_QUIT:
  352.             if (*(char **) pc)
  353.                 printf(" \"%s\"\n", *((char **) pc));
  354.             else
  355.                 printf("\n");
  356.             return (1 + PTR_SIZE);
  357.         case OP_MATINIT: case OP_INDEXADDR: case OP_INDEXVALUE:
  358.         case OP_PRINT: case OP_JUMPEQ: case OP_JUMPNE: case OP_JUMP:
  359.         case OP_CONDORJUMP: case OP_CONDANDJUMP: case OP_CASEJUMP:
  360.         case OP_OBJINIT:
  361.             printf(" %ld\n", *pc);
  362.             return 2;
  363.         case OP_NUMBER: case OP_IMAGINARY:
  364.             qprintf(" %r\n", constvalue(*pc));
  365.             return 2;
  366.         case OP_DEBUG:
  367.             printf(" line %ld\n", *pc);
  368.             return 2;
  369.         case OP_CALL:
  370.             printf(" %s with %ld args\n", builtinname(pc[0]), pc[1]);
  371.             return 3;
  372.         case OP_USERCALL:
  373.             printf(" %s with %ld args\n", namefunc(pc[0]), pc[1]);
  374.             return 3;
  375.         default:
  376.             printf("\n");
  377.             return 1;
  378.     }
  379. }
  380.  
  381.  
  382. /*
  383.  * The various opcodes
  384.  */
  385.  
  386. static long
  387. o_nop()
  388. {
  389.     return 0;
  390. }
  391.  
  392.  
  393. static long
  394. o_localaddr(fp, locals, index)
  395.     FUNC *fp;
  396.     VALUE *locals;
  397.     long index;
  398. {
  399.     if ((unsigned long)index >= fp->f_localcount)
  400.         error("Bad local variable index");
  401.     locals += index;
  402.     stack++;
  403.     stack->v_addr = locals;
  404.     stack->v_type = V_ADDR;
  405.     return 0;
  406. }
  407.  
  408.  
  409. /*ARGSUSED*/
  410. static long
  411. o_globaladdr(fp, sp)
  412.     FUNC *fp;
  413.     GLOBAL *sp;
  414. {
  415.     if (sp == NULL)
  416.         error("Global variable \"%s\" not initialized", sp->g_name);
  417.     stack++;
  418.     stack->v_addr = &sp->g_value;
  419.     stack->v_type = V_ADDR;
  420.     return 0;
  421. }
  422.  
  423.  
  424. /*ARGSUSED*/
  425. static long
  426. o_paramaddr(fp, argcount, args, index)
  427.     FUNC *fp;
  428.     int argcount;
  429.     VALUE *args;
  430.     long index;
  431. {
  432.     if ((unsigned long)index >= argcount)
  433.         error("Bad parameter index");
  434.     args += index;
  435.     stack++;
  436.     if (args->v_type == V_ADDR)
  437.         stack->v_addr = args->v_addr;
  438.     else
  439.         stack->v_addr = args;
  440.     stack->v_type = V_ADDR;
  441.     return 0;
  442. }
  443.  
  444.  
  445. static long
  446. o_localvalue(fp, locals, index)
  447.     FUNC *fp;
  448.     VALUE *locals;
  449.     long index;
  450. {
  451.     if ((unsigned long)index >= fp->f_localcount)
  452.         error("Bad local variable index");
  453.     locals += index;
  454.     copyvalue(locals, ++stack);
  455.     return 0;
  456. }
  457.  
  458.  
  459. /*ARGSUSED*/
  460. static long
  461. o_globalvalue(fp, sp)
  462.     FUNC *fp;
  463.     GLOBAL *sp;        /* global symbol */
  464. {
  465.     if (sp == NULL)
  466.         error("Global variable not defined");
  467.     copyvalue(&sp->g_value, ++stack);
  468.     return 0;
  469. }
  470.  
  471.  
  472. /*ARGSUSED*/
  473. static long
  474. o_paramvalue(fp, argcount, args, index)
  475.     FUNC *fp;
  476.     int argcount;
  477.     VALUE *args;
  478.     long index;
  479. {
  480.     if ((unsigned long)index >= argcount)
  481.         error("Bad paramaeter index");
  482.     args += index;
  483.     if (args->v_type == V_ADDR)
  484.         args = args->v_addr;
  485.     copyvalue(args, ++stack);
  486.     return 0;
  487. }
  488.  
  489.  
  490. static long
  491. o_argvalue(fp, argcount, args)
  492.     FUNC *fp;
  493.     int argcount;
  494.     VALUE *args;
  495. {
  496.     VALUE *vp;
  497.     long index;
  498.  
  499.     vp = stack;
  500.     if (vp->v_type == V_ADDR)
  501.         vp = vp->v_addr;
  502.     if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
  503.         qisfrac(vp->v_num))
  504.             error("Illegal argument for arg function");
  505.     if (qiszero(vp->v_num)) {
  506.         if (stack->v_type == V_NUM)
  507.             qfree(stack->v_num);
  508.         stack->v_num = itoq((long) argcount);
  509.         stack->v_type = V_NUM;
  510.         return 0;
  511.     }
  512.     index = qtoi(vp->v_num) - 1;
  513.     if (stack->v_type == V_NUM)
  514.         qfree(stack->v_num);
  515.     stack--;
  516.     (void) o_paramvalue(fp, argcount, args, index);
  517.     return 0;
  518. }
  519.  
  520.  
  521. /*ARGSUSED*/
  522. static long
  523. o_number(fp, arg)
  524.     FUNC *fp;
  525.     long arg;
  526. {
  527.     NUMBER *q;
  528.  
  529.     q = constvalue(arg);
  530.     if (q == NULL)
  531.         error("Numeric constant value not found");
  532.     stack++;
  533.     stack->v_num = qlink(q);
  534.     stack->v_type = V_NUM;
  535.     return 0;
  536. }
  537.  
  538.  
  539. /*ARGSUSED*/
  540. static long
  541. o_imaginary(fp, arg)
  542.     FUNC *fp;
  543.     long arg;
  544. {
  545.     NUMBER *q;
  546.     COMPLEX *c;
  547.  
  548.     q = constvalue(arg);
  549.     if (q == NULL)
  550.         error("Numeric constant value not found");
  551.     stack++;
  552.     if (qiszero(q)) {
  553.         stack->v_num = qlink(q);
  554.         stack->v_type = V_NUM;
  555.         return 0;
  556.     }
  557.     c = comalloc();
  558.     c->real = qlink(&_qzero_);
  559.     c->imag = qlink(q);
  560.     stack->v_com = c;
  561.     stack->v_type = V_COM;
  562.     return 0;
  563. }
  564.  
  565.  
  566. /*ARGSUSED*/
  567. static long
  568. o_string(fp, cp)
  569.     FUNC *fp;
  570.     char *cp;
  571. {
  572.     stack++;
  573.     stack->v_str = cp;
  574.     stack->v_type = V_STR;
  575.     stack->v_subtype = V_STRLITERAL;
  576.     return 0;
  577. }
  578.  
  579.  
  580. static long
  581. o_undef()
  582. {
  583.     stack++;
  584.     stack->v_type = V_NULL;
  585.     return 0;
  586. }
  587.  
  588.  
  589. /*ARGSUSED*/
  590. static long
  591. o_matinit(fp, dim)
  592.     FUNC *fp;
  593.     long dim;
  594. {
  595.     register MATRIX *mp;    /* matrix being defined */
  596.     NUMBER *num1;        /* first number from stack */
  597.     NUMBER *num2;        /* second number from stack */
  598.     VALUE *vp;        /* value being defined */
  599.     VALUE *v1, *v2;
  600.     long min[MAXDIM];    /* minimum range */
  601.     long max[MAXDIM];    /* maximum range */
  602.     long i;            /* index */
  603.     long tmp;        /* temporary */
  604.     long size;        /* size of matrix */
  605.  
  606.     if ((dim <= 0) || (dim > MAXDIM))
  607.         error("Bad dimension %ld for matrix", dim);
  608.     if (stack[-2*dim].v_type != V_ADDR)
  609.         error("Attempting to init matrix for non-address");
  610.     size = 1;
  611.     for (i = dim - 1; i >= 0; i--) {
  612.         v1 = &stack[-1];
  613.         v2 = &stack[0];
  614.         if (v1->v_type == V_ADDR)
  615.             v1 = v1->v_addr;
  616.         if (v2->v_type == V_ADDR)
  617.             v2 = v2->v_addr;
  618.         if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  619.             error("Non-numeric bounds for matrix");
  620.         num1 = v1->v_num;
  621.         num2 = v2->v_num;
  622.         if (qisfrac(num1) || qisfrac(num2))
  623.             error("Non-integral bounds for matrix");
  624.         if (isbig(num1->num) || isbig(num2->num))
  625.             error("Very large bounds for matrix");
  626.         min[i] = qtoi(num1);
  627.         max[i] = qtoi(num2);
  628.         if (min[i] > max[i]) {
  629.             tmp = min[i];
  630.             min[i] = max[i];
  631.             max[i] = tmp;
  632.         }
  633.         size *= (max[i] - min[i] + 1);
  634.         if (size > 1000000)
  635.             error("Very large size for matrix");
  636.         freevalue(stack--);
  637.         freevalue(stack--);
  638.     }
  639.     mp = matalloc(size);
  640.     mp->m_dim = dim;
  641.     for (i = 0; i < dim; i++) {
  642.         mp->m_min[i] = min[i];
  643.         mp->m_max[i] = max[i];
  644.     }
  645.     vp = mp->m_table;
  646.     for (i = 0; i < size; i++) {
  647.         vp->v_type = V_NUM;
  648.         vp->v_num = qlink(&_qzero_);
  649.         vp++;
  650.     }
  651.     vp = stack[0].v_addr;
  652.     vp->v_type = V_MAT;
  653.     vp->v_mat = mp;
  654.     stack--;
  655.     return 0;
  656. }
  657.  
  658.  
  659. /*ARGSUSED*/
  660. static long
  661. o_indexaddr(fp, dim)
  662.     FUNC *fp;
  663.     long dim;        /* dimension of matrix */
  664. {
  665.     register MATRIX *mp;    /* current matrix element */
  666.     VALUE *curvp;        /* current stack address */
  667.     VALUE *vp;        /* real stack value */
  668.     NUMBER *q;        /* index value */
  669.     long index;        /* index value as an integer */
  670.     long offset;        /* current offset into array */
  671.     int i;            /* loop counter */
  672.  
  673.     if ((dim <= 0) || (dim > MAXDIM))
  674.         error("Bad dimension %ld for matrix", dim);
  675.     if (stack[-dim].v_type != V_ADDR)
  676.         error("Non-pointer for index operation");
  677.     if (stack[-dim].v_addr->v_type != V_MAT)
  678.         error("Attempting to index a non-matrix variable");
  679.     mp = stack[-dim].v_addr->v_mat;
  680.     if (mp->m_dim != dim)
  681.         error("Indexing a %ldd matrix as a %ldd matrix", mp->m_dim, dim);
  682.     offset = 0;
  683.     curvp = &stack[-dim + 1];
  684.     for (i = 0; i < dim; i++) {
  685.         vp = curvp;
  686.         if (vp->v_type == V_ADDR)
  687.             vp = vp->v_addr;
  688.         if (vp->v_type != V_NUM)
  689.             error("Non-numeric index for array");
  690.         q = vp->v_num;
  691.         if (qisfrac(q))
  692.             error("Non-integral index for array");
  693.         index = qtoi(q);
  694.         if (isbig(q->num) || (index < mp->m_min[i]) || (index > mp->m_max[i]))
  695.             error("Index out of bounds");
  696.         offset *= (mp->m_max[i] - mp->m_min[i] + 1);
  697.         offset += (index - mp->m_min[i]);
  698.         freevalue(curvp++);
  699.     }
  700.     stack -= dim;
  701.     stack->v_type = V_ADDR;
  702.     stack->v_addr = mp->m_table + offset;
  703.     return 0;
  704. }
  705.  
  706.  
  707. static long
  708. o_indexvalue(fp, dim)
  709.     FUNC *fp;
  710.     long dim;
  711. {
  712.     (void) o_indexaddr(fp, dim);
  713.     (void) o_getvalue();
  714.     return 0;
  715. }
  716.  
  717.  
  718. /*ARGSUSED*/
  719. static long
  720. o_elemaddr(fp, index)
  721.     FUNC *fp;
  722.     long index;
  723. {
  724.     if (stack->v_type != V_ADDR)
  725.         error("Non-pointer for element reference");
  726.     if (stack->v_addr->v_type != V_OBJ)
  727.         error("Referencing element of non-object");
  728.     index = objoffset(stack->v_addr->v_obj, index);
  729.     if (index < 0)
  730.         error("Element does not exist for object");
  731.     stack->v_addr = &stack->v_addr->v_obj->o_table[index];
  732.     return 0;
  733. }
  734.  
  735.  
  736. static long
  737. o_elemvalue(fp, index)
  738.     FUNC *fp;
  739.     long index;
  740. {
  741.     if (stack->v_type != V_OBJ) {
  742.         (void) o_elemaddr(fp, index);
  743.         (void) o_getvalue();
  744.         return 0;
  745.     }
  746.     index = objoffset(stack->v_obj, index);
  747.     if (index < 0)
  748.         error("Element does not exist for object");
  749.     copyvalue(&stack->v_obj->o_table[index], stack);
  750.     return 0;
  751. }
  752.  
  753.  
  754. /*ARGSUSED*/
  755. static long
  756. o_objinit(fp, arg)
  757.     FUNC *fp;
  758.     long arg;
  759. {
  760.     OBJECT *op;        /* object being created */
  761.     VALUE *vp;        /* value being defined */
  762.  
  763.     if (stack->v_type != V_ADDR)
  764.         error("Attempting to init object for non-address");
  765.     op = objalloc(arg);
  766.     vp = stack->v_addr;
  767.     vp->v_type = V_OBJ;
  768.     vp->v_obj = op;
  769.     stack--;
  770.     return 0;
  771. }
  772.  
  773.  
  774. static long
  775. o_assign()
  776. {
  777.     VALUE *var;        /* variable value */
  778.     VALUE *vp;
  779.  
  780.     var = &stack[-1];
  781.     if (var->v_type != V_ADDR)
  782.         error("Assignment into non-variable");
  783.     var = var->v_addr;
  784.     stack[-1] = stack[0];
  785.     stack--;
  786.     vp = stack;
  787.     if (vp->v_type == V_ADDR) {
  788.         vp = vp->v_addr;
  789.         if (vp == var)
  790.             return 0;
  791.     }
  792.     freevalue(var);
  793.     copyvalue(vp, var);
  794.     return 0;
  795. }
  796.  
  797.  
  798. static long
  799. o_assignpop()
  800. {
  801.     VALUE *var;        /* variable value */
  802.     VALUE *vp;
  803.  
  804.     var = &stack[-1];
  805.     if (var->v_type != V_ADDR)
  806.         error("Assignment into non-variable");
  807.     var = var->v_addr;
  808.     vp = &stack[0];
  809.     if ((vp->v_type == V_ADDR) && (vp->v_addr == var)) {
  810.         stack -= 2;
  811.         return 0;
  812.     }
  813.     freevalue(var);
  814.     if (vp->v_type == V_ADDR)
  815.         copyvalue(vp->v_addr, var);
  816.     else
  817.         *var = *vp;
  818.     stack -= 2;
  819.     return 0;
  820. }
  821.  
  822.  
  823. static long
  824. o_swap()
  825. {
  826.     VALUE *v1, *v2;        /* variables to be swapped */
  827.     VALUE tmp;
  828.  
  829.     v1 = &stack[-1];
  830.     v2 = &stack[0];
  831.     if ((v1->v_type != V_ADDR) || (v2->v_type != V_ADDR))
  832.         error("Swapping non-variables");
  833.     tmp = v1->v_addr[0];
  834.     v1->v_addr[0] = v2->v_addr[0];
  835.     v2->v_addr[0] = tmp;
  836.     stack--;
  837.     stack->v_type = V_NULL;
  838.     return 0;
  839. }
  840.  
  841.  
  842. static long
  843. o_add()
  844. {
  845.     VALUE *v1, *v2;
  846.     NUMBER *q;
  847.     VALUE tmp;
  848.  
  849.     v1 = &stack[-1];
  850.     v2 = &stack[0];
  851.     if (v1->v_type == V_ADDR)
  852.         v1 = v1->v_addr;
  853.     if (v2->v_type == V_ADDR)
  854.         v2 = v2->v_addr;
  855.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  856.         addvalue(v1, v2, &tmp);
  857.         freevalue(stack--);
  858.         freevalue(stack);
  859.         *stack = tmp;
  860.         return 0;
  861.     }
  862.     q = qadd(v1->v_num, v2->v_num);
  863.     if (stack->v_type == V_NUM)
  864.         qfree(stack->v_num);
  865.     stack--;
  866.     if (stack->v_type == V_NUM)
  867.         qfree(stack->v_num);
  868.     stack->v_num = q;
  869.     stack->v_type = V_NUM;
  870.     return 0;
  871. }
  872.  
  873.  
  874. static long
  875. o_sub()
  876. {
  877.     VALUE *v1, *v2;
  878.     NUMBER *q;
  879.     VALUE tmp;
  880.  
  881.     v1 = &stack[-1];
  882.     v2 = &stack[0];
  883.     if (v1->v_type == V_ADDR)
  884.         v1 = v1->v_addr;
  885.     if (v2->v_type == V_ADDR)
  886.         v2 = v2->v_addr;
  887.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  888.         subvalue(v1, v2, &tmp);
  889.         freevalue(stack--);
  890.         freevalue(stack);
  891.         *stack = tmp;
  892.         return 0;
  893.     }
  894.     q = qsub(v1->v_num, v2->v_num);
  895.     if (stack->v_type == V_NUM)
  896.         qfree(stack->v_num);
  897.     stack--;
  898.     if (stack->v_type == V_NUM)
  899.         qfree(stack->v_num);
  900.     stack->v_num = q;
  901.     stack->v_type = V_NUM;
  902.     return 0;
  903. }
  904.  
  905.  
  906. static long
  907. o_mul()
  908. {
  909.     VALUE *v1, *v2;
  910.     NUMBER *q;
  911.     VALUE tmp;
  912.  
  913.     v1 = &stack[-1];
  914.     v2 = &stack[0];
  915.     if (v1->v_type == V_ADDR)
  916.         v1 = v1->v_addr;
  917.     if (v2->v_type == V_ADDR)
  918.         v2 = v2->v_addr;
  919.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  920.         mulvalue(v1, v2, &tmp);
  921.         freevalue(stack--);
  922.         freevalue(stack);
  923.         *stack = tmp;
  924.         return 0;
  925.     }
  926.     q = qmul(v1->v_num, v2->v_num);
  927.     if (stack->v_type == V_NUM)
  928.         qfree(stack->v_num);
  929.     stack--;
  930.     if (stack->v_type == V_NUM)
  931.         qfree(stack->v_num);
  932.     stack->v_num = q;
  933.     stack->v_type = V_NUM;
  934.     return 0;
  935. }
  936.  
  937.  
  938. static long
  939. o_power()
  940. {
  941.     VALUE *v1, *v2;
  942.     VALUE tmp;
  943.  
  944.     v1 = &stack[-1];
  945.     v2 = &stack[0];
  946.     if (v1->v_type == V_ADDR)
  947.         v1 = v1->v_addr;
  948.     if (v2->v_type == V_ADDR)
  949.         v2 = v2->v_addr;
  950.     powivalue(v1, v2, &tmp);
  951.     freevalue(stack--);
  952.     freevalue(stack);
  953.     *stack = tmp;
  954.     return 0;
  955. }
  956.  
  957.  
  958. static long
  959. o_div()
  960. {
  961.     VALUE *v1, *v2;
  962.     NUMBER *q;
  963.     VALUE tmp;
  964.  
  965.     v1 = &stack[-1];
  966.     v2 = &stack[0];
  967.     if (v1->v_type == V_ADDR)
  968.         v1 = v1->v_addr;
  969.     if (v2->v_type == V_ADDR)
  970.         v2 = v2->v_addr;
  971.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  972.         divvalue(v1, v2, &tmp);
  973.         freevalue(stack--);
  974.         freevalue(stack);
  975.         *stack = tmp;
  976.         return 0;
  977.     }
  978.     q = qdiv(v1->v_num, v2->v_num);
  979.     if (stack->v_type == V_NUM)
  980.         qfree(stack->v_num);
  981.     stack--;
  982.     if (stack->v_type == V_NUM)
  983.         qfree(stack->v_num);
  984.     stack->v_num = q;
  985.     stack->v_type = V_NUM;
  986.     return 0;
  987. }
  988.  
  989.  
  990. static long
  991. o_quo()
  992. {
  993.     VALUE *v1, *v2;
  994.     NUMBER *q;
  995.     VALUE tmp;
  996.  
  997.     v1 = &stack[-1];
  998.     v2 = &stack[0];
  999.     if (v1->v_type == V_ADDR)
  1000.         v1 = v1->v_addr;
  1001.     if (v2->v_type == V_ADDR)
  1002.         v2 = v2->v_addr;
  1003.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1004.         quovalue(v1, v2, &tmp);
  1005.         freevalue(stack--);
  1006.         freevalue(stack);
  1007.         *stack = tmp;
  1008.         return 0;
  1009.     }
  1010.     q = qquo(v1->v_num, v2->v_num);
  1011.     if (stack->v_type == V_NUM)
  1012.         qfree(stack->v_num);
  1013.     stack--;
  1014.     if (stack->v_type == V_NUM)
  1015.         qfree(stack->v_num);
  1016.     stack->v_num = q;
  1017.     stack->v_type = V_NUM;
  1018.     return 0;
  1019. }
  1020.  
  1021.  
  1022. static long
  1023. o_mod()
  1024. {
  1025.     VALUE *v1, *v2;
  1026.     NUMBER *q;
  1027.     VALUE tmp;
  1028.  
  1029.     v1 = &stack[-1];
  1030.     v2 = &stack[0];
  1031.     if (v1->v_type == V_ADDR)
  1032.         v1 = v1->v_addr;
  1033.     if (v2->v_type == V_ADDR)
  1034.         v2 = v2->v_addr;
  1035.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1036.         modvalue(v1, v2, &tmp);
  1037.         freevalue(stack--);
  1038.         freevalue(stack);
  1039.         *stack = tmp;
  1040.         return 0;
  1041.     }
  1042.     q = qmod(v1->v_num, v2->v_num);
  1043.     if (stack->v_type == V_NUM)
  1044.         qfree(stack->v_num);
  1045.     stack--;
  1046.     if (stack->v_type == V_NUM)
  1047.         qfree(stack->v_num);
  1048.     stack->v_num = q;
  1049.     stack->v_type = V_NUM;
  1050.     return 0;
  1051. }
  1052.  
  1053.  
  1054. static long
  1055. o_quomod()
  1056. {
  1057.     VALUE *v1, *v2, *v3, *v4;
  1058.     VALUE valquo, valmod;
  1059.     BOOL res;
  1060.  
  1061.     v1 = &stack[-3];
  1062.     v2 = &stack[-2];
  1063.     v3 = &stack[-1];
  1064.     v4 = &stack[0];
  1065.     if (v1->v_type == V_ADDR)
  1066.         v1 = v1->v_addr;
  1067.     if (v2->v_type == V_ADDR)
  1068.         v2 = v2->v_addr;
  1069.     if ((v3->v_type != V_ADDR) || (v4->v_type != V_ADDR))
  1070.         error("Non-variable for quomod");
  1071.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1072.         error("Non-reals for quomod");
  1073.     v3 = v3->v_addr;
  1074.     v4 = v4->v_addr;
  1075.     valquo.v_type = V_NUM;
  1076.     valmod.v_type = V_NUM;
  1077.     res = qquomod(v1->v_num, v2->v_num, &valquo.v_num, &valmod.v_num);
  1078.     freevalue(stack--);
  1079.     freevalue(stack--);
  1080.     stack--;
  1081.     stack->v_num = (res ? qlink(&_qone_) : qlink(&_qzero_));
  1082.     stack->v_type = V_NUM;
  1083.     freevalue(v3);
  1084.     freevalue(v4);
  1085.     *v3 = valquo;
  1086.     *v4 = valmod;
  1087.     return 0;
  1088. }
  1089.  
  1090.  
  1091. static long
  1092. o_and()
  1093. {
  1094.     VALUE *v1, *v2;
  1095.     NUMBER *q;
  1096.  
  1097.     v1 = &stack[-1];
  1098.     v2 = &stack[0];
  1099.     if (v1->v_type == V_ADDR)
  1100.         v1 = v1->v_addr;
  1101.     if (v2->v_type == V_ADDR)
  1102.         v2 = v2->v_addr;
  1103.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1104.         error("Non-numerics for and");
  1105.     q = qand(v1->v_num, v2->v_num);
  1106.     if (stack->v_type == V_NUM)
  1107.         qfree(stack->v_num);
  1108.     stack--;
  1109.     if (stack->v_type == V_NUM)
  1110.         qfree(stack->v_num);
  1111.     stack->v_num = q;
  1112.     stack->v_type = V_NUM;
  1113.     return 0;
  1114. }
  1115.  
  1116.  
  1117. static long
  1118. o_or()
  1119. {
  1120.     VALUE *v1, *v2;
  1121.     NUMBER *q;
  1122.  
  1123.     v1 = &stack[-1];
  1124.     v2 = &stack[0];
  1125.     if (v1->v_type == V_ADDR)
  1126.         v1 = v1->v_addr;
  1127.     if (v2->v_type == V_ADDR)
  1128.         v2 = v2->v_addr;
  1129.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
  1130.         error("Non-numerics for or");
  1131.     q = qor(v1->v_num, v2->v_num);
  1132.     if (stack->v_type == V_NUM)
  1133.         qfree(stack->v_num);
  1134.     stack--;
  1135.     if (stack->v_type == V_NUM)
  1136.         qfree(stack->v_num);
  1137.     stack->v_num = q;
  1138.     stack->v_type = V_NUM;
  1139.     return 0;
  1140. }
  1141.  
  1142.  
  1143. static long
  1144. o_not()
  1145. {
  1146.     VALUE *vp;
  1147.     int r;
  1148.  
  1149.     vp = stack;
  1150.     if (vp->v_type == V_ADDR)
  1151.         vp = vp->v_addr;
  1152.     r = testvalue(vp);
  1153.     freevalue(stack);
  1154.     stack->v_num = (r ? qlink(&_qzero_) : qlink(&_qone_));        
  1155.     stack->v_type = V_NUM;
  1156.     return 0;
  1157. }
  1158.  
  1159.  
  1160. static long
  1161. o_negate()
  1162. {
  1163.     VALUE *vp;
  1164.     NUMBER *q;
  1165.     VALUE tmp;
  1166.  
  1167.     vp = stack;
  1168.     if (vp->v_type == V_ADDR)
  1169.         vp = vp->v_addr;
  1170.     if (vp->v_type == V_NUM) {
  1171.         q = qneg(vp->v_num);
  1172.         if (stack->v_type == V_NUM)
  1173.             qfree(stack->v_num);
  1174.         stack->v_num = q;
  1175.         stack->v_type = V_NUM;
  1176.         return 0;
  1177.     }
  1178.     negvalue(vp, &tmp);
  1179.     freevalue(stack);
  1180.     *stack = tmp;
  1181.     return 0;
  1182. }
  1183.  
  1184.  
  1185. static long
  1186. o_invert()
  1187. {
  1188.     VALUE *vp;
  1189.     NUMBER *q;
  1190.     VALUE tmp;
  1191.  
  1192.     vp = stack;
  1193.     if (vp->v_type == V_ADDR)
  1194.         vp = vp->v_addr;
  1195.     if (vp->v_type == V_NUM) {
  1196.         q = qinv(vp->v_num);
  1197.         if (stack->v_type == V_NUM)
  1198.             qfree(stack->v_num);
  1199.         stack->v_num = q;
  1200.         stack->v_type = V_NUM;
  1201.         return 0;
  1202.     }
  1203.     invertvalue(vp, &tmp);
  1204.     freevalue(stack);
  1205.     *stack = tmp;
  1206.     return 0;
  1207. }
  1208.  
  1209.  
  1210. static long
  1211. o_scale()
  1212. {
  1213.     VALUE *v1, *v2;
  1214.     NUMBER *q;
  1215.     VALUE tmp;
  1216.  
  1217.     v1 = &stack[0];
  1218.     v2 = &stack[-1];
  1219.     if (v1->v_type == V_ADDR)
  1220.         v1 = v1->v_addr;
  1221.     if (v2->v_type == V_ADDR)
  1222.         v2 = v2->v_addr;
  1223.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
  1224.         scalevalue(v2, v1, &tmp);
  1225.         freevalue(stack--);
  1226.         freevalue(stack);
  1227.         *stack = tmp;
  1228.         return 0;
  1229.     }
  1230.     q = v1->v_num;
  1231.     if (qisfrac(q))
  1232.         error("Non-integral scaling factor");
  1233.     if (isbig(q->num))
  1234.         error("Very large scaling factor");
  1235.     q = qscale(v2->v_num, qtoi(q));
  1236.     if (stack->v_type == V_NUM)
  1237.         qfree(stack->v_num);
  1238.     stack--;
  1239.     if (stack->v_type == V_NUM)
  1240.         qfree(stack->v_num);
  1241.     stack->v_num = q;
  1242.     stack->v_type = V_NUM;
  1243.     return 0;
  1244. }
  1245.  
  1246.  
  1247. static long
  1248. o_int()
  1249. {
  1250.     VALUE *vp;
  1251.     NUMBER *q;
  1252.     VALUE tmp;
  1253.  
  1254.     vp = stack;
  1255.     if (vp->v_type == V_ADDR)
  1256.         vp = vp->v_addr;
  1257.     if (vp->v_type == V_NUM) {
  1258.         if (qisint(vp->v_num) && (stack->v_type == V_NUM))
  1259.             return 0;
  1260.         q = qint(vp->v_num);
  1261.         if (stack->v_type == V_NUM)
  1262.             qfree(stack->v_num);
  1263.         stack->v_num = q;
  1264.         stack->v_type = V_NUM;
  1265.         return 0;
  1266.     }
  1267.     intvalue(vp, &tmp);
  1268.     freevalue(stack);
  1269.     *stack = tmp;
  1270.     return 0;
  1271. }
  1272.  
  1273.  
  1274. static long
  1275. o_frac()
  1276. {
  1277.     VALUE *vp;
  1278.     NUMBER *q;
  1279.     VALUE tmp;
  1280.  
  1281.     vp = stack;
  1282.     if (vp->v_type == V_ADDR)
  1283.         vp = vp->v_addr;
  1284.     if (vp->v_type == V_NUM) {
  1285.         q = qfrac(vp->v_num);
  1286.         if (stack->v_type == V_NUM)
  1287.             qfree(stack->v_num);
  1288.         stack->v_num = q;
  1289.         stack->v_type = V_NUM;
  1290.         return 0;
  1291.     }
  1292.     fracvalue(vp, &tmp);
  1293.     freevalue(stack);
  1294.     *stack = tmp;
  1295.     return 0;
  1296. }
  1297.  
  1298.  
  1299. static long
  1300. o_abs()
  1301. {
  1302.     VALUE *v1, *v2;
  1303.     NUMBER *q;
  1304.     VALUE tmp;
  1305.  
  1306.     v1 = &stack[-1];
  1307.     v2 = &stack[0];
  1308.     if (v1->v_type == V_ADDR)
  1309.         v1 = v1->v_addr;
  1310.     if (v2->v_type == V_ADDR)
  1311.         v2 = v2->v_addr;
  1312.     if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM) ||
  1313.         !qispos(v2->v_num))
  1314.     {
  1315.         absvalue(v1, v2, &tmp);
  1316.         freevalue(stack--);
  1317.         freevalue(stack);
  1318.         *stack = tmp;
  1319.         return 0;
  1320.     }
  1321.     if (stack->v_type == V_NUM)
  1322.         qfree(stack->v_num);
  1323.     stack--;
  1324.     if ((stack->v_type == V_NUM) && !qisneg(v1->v_num))
  1325.         return 0;
  1326.     q = qabs(v1->v_num);
  1327.     if (stack->v_type == V_NUM)
  1328.         qfree(stack->v_num);
  1329.     stack->v_num = q;
  1330.     stack->v_type = V_NUM;
  1331.     return 0;
  1332. }
  1333.  
  1334.  
  1335. static long
  1336. o_norm()
  1337. {
  1338.     VALUE *vp;
  1339.     NUMBER *q;
  1340.     VALUE tmp;
  1341.  
  1342.     vp = stack;
  1343.     if (vp->v_type == V_ADDR)
  1344.         vp = vp->v_addr;
  1345.     if (vp->v_type == V_NUM) {
  1346.         q = qsquare(vp->v_num);
  1347.         if (stack->v_type == V_NUM)
  1348.             qfree(stack->v_num);
  1349.         stack->v_num = q;
  1350.         stack->v_type = V_NUM;
  1351.         return 0;
  1352.     }
  1353.     normvalue(vp, &tmp);
  1354.     freevalue(stack);
  1355.     *stack = tmp;
  1356.     return 0;
  1357. }
  1358.  
  1359.  
  1360. static long
  1361. o_square()
  1362. {
  1363.     VALUE *vp;
  1364.     NUMBER *q;
  1365.     VALUE tmp;
  1366.  
  1367.     vp = stack;
  1368.     if (vp->v_type == V_ADDR)
  1369.         vp = vp->v_addr;
  1370.     if (vp->v_type == V_NUM) {
  1371.         q = qsquare(vp->v_num);
  1372.         if (stack->v_type == V_NUM)
  1373.             qfree(stack->v_num);
  1374.         stack->v_num = q;
  1375.         stack->v_type = V_NUM;
  1376.         return 0;
  1377.     }
  1378.     squarevalue(vp, &tmp);
  1379.     freevalue(stack);
  1380.     *stack = tmp;
  1381.     return 0;
  1382. }
  1383.  
  1384.  
  1385. static long
  1386. o_istype()
  1387. {
  1388.     VALUE *v1, *v2;
  1389.     int r;
  1390.  
  1391.     v1 = &stack[-1];
  1392.     v2 = &stack[0];
  1393.     if (v1->v_type == V_ADDR)
  1394.         v1 = v1->v_addr;
  1395.     if (v2->v_type == V_ADDR)
  1396.         v2 = v2->v_addr;
  1397.     if ((v1->v_type != V_OBJ) || (v2->v_type != V_OBJ))
  1398.         r = (v1->v_type == v2->v_type);
  1399.     else
  1400.         r = (v1->v_obj->o_actions == v2->v_obj->o_actions);
  1401.     freevalue(stack--);
  1402.     freevalue(stack);
  1403.     stack->v_num = itoq((long) r);
  1404.     stack->v_type = V_NUM;
  1405.     return 0;
  1406. }
  1407.  
  1408.  
  1409. static long
  1410. o_isint()
  1411. {
  1412.     VALUE *vp;
  1413.     NUMBER *q;
  1414.  
  1415.     vp = stack;
  1416.     if (vp->v_type == V_ADDR)
  1417.         vp = stack->v_addr;
  1418.     if (vp->v_type != V_NUM) {
  1419.         freevalue(stack);
  1420.         stack->v_num = qlink(&_qzero_);
  1421.         stack->v_type = V_NUM;
  1422.         return 0;
  1423.     }
  1424.     if (qisint(vp->v_num))
  1425.         q = qlink(&_qone_);
  1426.     else
  1427.         q = qlink(&_qzero_);
  1428.     if (stack->v_type == V_NUM)
  1429.         qfree(stack->v_num);
  1430.     stack->v_num = q;
  1431.     stack->v_type = V_NUM;
  1432.     return 0;
  1433. }
  1434.  
  1435.  
  1436. static long
  1437. o_isnum()
  1438. {
  1439.     VALUE *vp;
  1440.  
  1441.     vp = stack;
  1442.     if (vp->v_type == V_ADDR)
  1443.         vp = vp->v_addr;
  1444.     switch (vp->v_type) {
  1445.         case V_NUM:
  1446.             if (stack->v_type == V_NUM)
  1447.                 qfree(stack->v_num);
  1448.             break;
  1449.         case V_COM:
  1450.             if (stack->v_type == V_COM)
  1451.                 comfree(stack->v_com);
  1452.             break;
  1453.         default:
  1454.             freevalue(stack);
  1455.             stack->v_num = qlink(&_qzero_);
  1456.             stack->v_type = V_NUM;
  1457.             return 0;
  1458.     }
  1459.     stack->v_num = qlink(&_qone_);
  1460.     stack->v_type = V_NUM;
  1461.     return 0;
  1462. }
  1463.  
  1464.  
  1465. static long
  1466. o_ismat()
  1467. {
  1468.     VALUE *vp;
  1469.  
  1470.     vp = stack;
  1471.     if (vp->v_type == V_ADDR)
  1472.         vp = vp->v_addr;
  1473.     if (vp->v_type != V_MAT) {
  1474.         freevalue(stack);
  1475.         stack->v_num = qlink(&_qzero_);
  1476.         stack->v_type = V_NUM;
  1477.         return 0;
  1478.     }
  1479.     freevalue(stack);
  1480.     stack->v_type = V_NUM;
  1481.     stack->v_num = qlink(&_qone_);
  1482.     return 0;
  1483. }
  1484.  
  1485.  
  1486. static long
  1487. o_islist()
  1488. {
  1489.     VALUE *vp;
  1490.     int r;
  1491.  
  1492.     vp = stack;
  1493.     if (vp->v_type == V_ADDR)
  1494.         vp = vp->v_addr;
  1495.     r = (vp->v_type == V_LIST);
  1496.     freevalue(stack);
  1497.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1498.     stack->v_type = V_NUM;
  1499.     return 0;
  1500. }
  1501.  
  1502.  
  1503. static long
  1504. o_isobj()
  1505. {
  1506.     VALUE *vp;
  1507.     int r;
  1508.  
  1509.     vp = stack;
  1510.     if (vp->v_type == V_ADDR)
  1511.         vp = vp->v_addr;
  1512.     r = (vp->v_type == V_OBJ);
  1513.     freevalue(stack);
  1514.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1515.     stack->v_type = V_NUM;
  1516.     return 0;
  1517. }
  1518.  
  1519.  
  1520. static long
  1521. o_isstr()
  1522. {
  1523.     VALUE *vp;
  1524.     int r;
  1525.  
  1526.     vp = stack;
  1527.     if (vp->v_type == V_ADDR)
  1528.         vp = vp->v_addr;
  1529.     r = (vp->v_type == V_STR);
  1530.     freevalue(stack);
  1531.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1532.     stack->v_type = V_NUM;
  1533.     return 0;
  1534. }
  1535.  
  1536.  
  1537. static long
  1538. o_isfile()
  1539. {
  1540.     VALUE *vp;
  1541.     int r;
  1542.  
  1543.     vp = stack;
  1544.     if (vp->v_type == V_ADDR)
  1545.         vp = vp->v_addr;
  1546.     r = (vp->v_type == V_FILE);
  1547.     freevalue(stack);
  1548.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1549.     stack->v_type = V_NUM;
  1550.     return 0;
  1551. }
  1552.  
  1553.  
  1554. static long
  1555. o_issimple()
  1556. {
  1557.     VALUE *vp;
  1558.     int r;
  1559.  
  1560.     vp = stack;
  1561.     if (vp->v_type == V_ADDR)
  1562.         vp = vp->v_addr;
  1563.     r = 0;
  1564.     switch (vp->v_type) {
  1565.         case V_NULL:
  1566.         case V_NUM:
  1567.         case V_COM:
  1568.         case V_STR:
  1569.             r = 1;
  1570.     }
  1571.     freevalue(stack);
  1572.     stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
  1573.     stack->v_type = V_NUM;
  1574.     return 0;
  1575. }
  1576.  
  1577.  
  1578. static long
  1579. o_isodd()
  1580. {
  1581.     VALUE *vp;
  1582.  
  1583.     vp = stack;
  1584.     if (vp->v_type == V_ADDR)
  1585.         vp = vp->v_addr;
  1586.     if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
  1587.         if (stack->v_type == V_NUM)
  1588.             qfree(stack->v_num);
  1589.         stack->v_num = qlink(&_qone_);
  1590.         stack->v_type = V_NUM;
  1591.         return 0;
  1592.     }
  1593.     freevalue(stack);
  1594.     stack->v_num = qlink(&_qzero_);
  1595.     stack->v_type = V_NUM;
  1596.     return 0;
  1597. }
  1598.  
  1599.  
  1600. static long
  1601. o_iseven()
  1602. {
  1603.     VALUE *vp;
  1604.  
  1605.     vp = stack;
  1606.     if (vp->v_type == V_ADDR)
  1607.         vp = vp->v_addr;
  1608.     if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
  1609.         if (stack->v_type == V_NUM)
  1610.             qfree(stack->v_num);
  1611.         stack->v_num = qlink(&_qone_);
  1612.         stack->v_type = V_NUM;
  1613.         return 0;
  1614.     }
  1615.     freevalue(stack);
  1616.     stack->v_num = qlink(&_qzero_);
  1617.     stack->v_type = V_NUM;
  1618.     return 0;
  1619. }
  1620.  
  1621.  
  1622. static long
  1623. o_isreal()
  1624. {
  1625.     VALUE *vp;
  1626.  
  1627.     vp = stack;
  1628.     if (vp->v_type == V_ADDR)
  1629.         vp = vp->v_addr;
  1630.     if (vp->v_type == V_NUM) {
  1631.         if (stack->v_type == V_NUM)
  1632.             qfree(stack->v_num);
  1633.         stack->v_num = qlink(&_qone_);
  1634.         stack->v_type = V_NUM;
  1635.         return 0;
  1636.     }
  1637.     freevalue(stack);
  1638.     stack->v_num = qlink(&_qzero_);
  1639.     stack->v_type = V_NUM;
  1640.     return 0;
  1641. }
  1642.  
  1643.  
  1644. static long
  1645. o_isnull()
  1646. {
  1647.     VALUE *vp;
  1648.  
  1649.     vp = stack;
  1650.     if (vp->v_type == V_ADDR)
  1651.         vp = vp->v_addr;
  1652.     if (vp->v_type != V_NULL) {
  1653.         freevalue(stack);
  1654.         stack->v_num = qlink(&_qzero_);
  1655.         stack->v_type = V_NUM;
  1656.         return 0;
  1657.     }
  1658.     freevalue(stack);
  1659.     stack->v_num = qlink(&_qone_);
  1660.     stack->v_type = V_NUM;
  1661.     return 0;
  1662. }
  1663.  
  1664.  
  1665. static long
  1666. o_re()
  1667. {
  1668.     VALUE *vp;
  1669.     NUMBER *q;
  1670.  
  1671.     vp = stack;
  1672.     if (vp->v_type == V_ADDR)
  1673.         vp = vp->v_addr;
  1674.     if (vp->v_type == V_NUM) {
  1675.         if (stack->v_type == V_ADDR) {
  1676.             stack->v_num = qlink(vp->v_num);
  1677.             stack->v_type = V_NUM;
  1678.         }
  1679.         return 0;
  1680.     }
  1681.     if (vp->v_type != V_COM)
  1682.         error("Taking real part of non-number");
  1683.     q = qlink(vp->v_com->real);
  1684.     if (stack->v_type == V_COM)
  1685.         comfree(stack->v_com);
  1686.     stack->v_num = q;
  1687.     stack->v_type = V_NUM;
  1688.     return 0;
  1689. }
  1690.  
  1691.  
  1692. static long
  1693. o_im()
  1694. {
  1695.     VALUE *vp;
  1696.     NUMBER *q;
  1697.  
  1698.     vp = stack;
  1699.     if (vp->v_type == V_ADDR)
  1700.         vp = vp->v_addr;
  1701.     if (vp->v_type == V_NUM) {
  1702.         if (stack->v_type == V_NUM)
  1703.             qfree(stack->v_num);
  1704.         stack->v_num = qlink(&_qzero_);
  1705.         stack->v_type = V_NUM;
  1706.         return 0;
  1707.     }
  1708.     if (vp->v_type != V_COM)
  1709.         error("Taking imaginary part of non-number");
  1710.     q = qlink(vp->v_com->imag);
  1711.     if (stack->v_type == V_COM)
  1712.         comfree(stack->v_com);
  1713.     stack->v_num = q;
  1714.     stack->v_type = V_NUM;
  1715.     return 0;
  1716. }
  1717.  
  1718.  
  1719. static long
  1720. o_conjugate()
  1721. {
  1722.     VALUE *vp;
  1723.     VALUE tmp;
  1724.  
  1725.     vp = stack;
  1726.     if (vp->v_type == V_ADDR)
  1727.         vp = vp->v_addr;
  1728.     if (vp->v_type == V_NUM) {
  1729.         if (stack->v_type == V_ADDR) {
  1730.             stack->v_num = qlink(vp->v_num);
  1731.             stack->v_type = V_NUM;
  1732.         }
  1733.         return 0;
  1734.     }
  1735.     conjvalue(vp, &tmp);
  1736.     freevalue(stack);
  1737.     *stack = tmp;
  1738.     return 0;
  1739. }
  1740.  
  1741.  
  1742. static long
  1743. o_fiaddr()
  1744. {
  1745.     register MATRIX *m;    /* current matrix element */
  1746.     NUMBER *q;        /* index value */
  1747.     LIST *lp;        /* list header */
  1748.     VALUE *vp;        /* stack value */
  1749.     long index;        /* index value as an integer */
  1750.  
  1751.     vp = stack;
  1752.     if (vp->v_type == V_ADDR)
  1753.         vp = vp->v_addr;
  1754.     if (vp->v_type != V_NUM)
  1755.         error("Fast indexing by non-number");
  1756.     q = vp->v_num;
  1757.     if (qisfrac(q))
  1758.         error("Fast indexing by non-integer");
  1759.     index = qtoi(q);
  1760.     if (isbig(q->num) || (index < 0))
  1761.         error("Index out of range for fast indexing");
  1762.     if (stack->v_type == V_NUM)
  1763.         qfree(q);
  1764.     stack--;
  1765.     vp = stack;
  1766.     if (vp->v_type != V_ADDR)
  1767.         error("Bad value for fast indexing");
  1768.     switch (vp->v_addr->v_type) {
  1769.         case V_OBJ:
  1770.             if (index >= vp->v_addr->v_obj->o_actions->count)
  1771.                 error("Index out of bounds for object");
  1772.             vp->v_addr = vp->v_addr->v_obj->o_table + index;
  1773.             break;
  1774.         case V_MAT:
  1775.             m = vp->v_addr->v_mat;
  1776.             if (index >= m->m_size)
  1777.                 error("Index out of bounds for matrix");
  1778.             vp->v_addr = m->m_table + index;
  1779.             break;
  1780.         case V_LIST:
  1781.             lp = vp->v_addr->v_list;
  1782.             vp->v_addr = listindex(lp, index);
  1783.             if (vp->v_addr == NULL)
  1784.                 error("Index out of bounds for list");
  1785.             break;
  1786.         default:
  1787.             error("Bad variable type for fast indexing");
  1788.     }
  1789.     return 0;
  1790. }
  1791.  
  1792.  
  1793. static long
  1794. o_fivalue()
  1795. {
  1796.     (void) o_fiaddr();
  1797.     (void) o_getvalue();
  1798.     return 0;
  1799. }
  1800.  
  1801.  
  1802. static long
  1803. o_sgn()
  1804. {
  1805.     VALUE *vp;
  1806.     NUMBER *q;
  1807.     VALUE val;
  1808.  
  1809.     vp = stack;
  1810.     if (vp->v_type == V_ADDR)
  1811.         vp = vp->v_addr;
  1812.     switch (vp->v_type) {
  1813.         case V_NUM:
  1814.             q = qsign(vp->v_num);
  1815.             if (stack->v_type == V_NUM)
  1816.                 qfree(vp->v_num);
  1817.             stack->v_num = q;
  1818.             stack->v_type = V_NUM;
  1819.             break;
  1820.         case V_OBJ:
  1821.             val = objcall(OBJ_SGN, vp);
  1822.             q = itoq(val.v_int);
  1823.             freevalue(stack);
  1824.             stack->v_num = q;
  1825.             stack->v_type = V_NUM;
  1826.             break;
  1827.         default:
  1828.             error("Bad value for sgn");
  1829.     }
  1830.     return 0;
  1831. }
  1832.  
  1833.  
  1834. static long
  1835. o_numerator()
  1836. {
  1837.     VALUE *vp;
  1838.     NUMBER *q;
  1839.  
  1840.     vp = stack;
  1841.     if (vp->v_type == V_ADDR)
  1842.         vp = vp->v_addr;
  1843.     if (vp->v_type != V_NUM)
  1844.         error("Numerator of non-number");
  1845.     if ((stack->v_type == V_NUM) && qisint(vp->v_num))
  1846.         return 0;
  1847.     q = qnum(vp->v_num);
  1848.     if (stack->v_type == V_NUM)
  1849.         qfree(stack->v_num);
  1850.     stack->v_num = q;
  1851.     stack->v_type = V_NUM;
  1852.     return 0;
  1853. }
  1854.  
  1855.  
  1856. static long
  1857. o_denominator()
  1858. {
  1859.     VALUE *vp;
  1860.     NUMBER *q;
  1861.  
  1862.     vp = stack;
  1863.     if (vp->v_type == V_ADDR)
  1864.         vp = vp->v_addr;
  1865.     if (vp->v_type != V_NUM)
  1866.         error("Denominator of non-number");
  1867.     q = qden(vp->v_num);
  1868.     if (stack->v_type == V_NUM)
  1869.         qfree(stack->v_num);
  1870.     stack->v_num = q;
  1871.     stack->v_type = V_NUM;
  1872.     return 0;
  1873. }
  1874.  
  1875.  
  1876. static long
  1877. o_duplicate()
  1878. {
  1879.     copyvalue(stack, stack + 1);
  1880.     stack++;
  1881.     return 0;
  1882. }
  1883.  
  1884.  
  1885. static long
  1886. o_dupvalue()
  1887. {
  1888.     if (stack->v_type == V_ADDR)
  1889.         copyvalue(stack->v_addr, stack + 1);
  1890.     else
  1891.         copyvalue(stack, stack + 1);
  1892.     stack++;
  1893.     return 0;
  1894. }
  1895.  
  1896.  
  1897. static long
  1898. o_pop()
  1899. {
  1900.     freevalue(stack--);
  1901.     return 0;
  1902. }
  1903.  
  1904.  
  1905. static long
  1906. o_return()
  1907. {
  1908.     return 0;
  1909. }
  1910.  
  1911.  
  1912. static long
  1913. o_jumpeq(fp, pc)
  1914.     FUNC *fp;
  1915.     long pc;
  1916. {
  1917.     VALUE *vp;
  1918.     int i;            /* result of comparison */
  1919.  
  1920.     vp = stack;
  1921.     if (vp->v_type == V_ADDR)
  1922.         vp = vp->v_addr;
  1923.     if (vp->v_type == V_NUM) {
  1924.         i = !qiszero(vp->v_num);
  1925.         if (stack->v_type == V_NUM)
  1926.             qfree(stack->v_num);
  1927.     } else {
  1928.         i = testvalue(vp);
  1929.         freevalue(stack);
  1930.     }
  1931.     stack--;
  1932.     if (i)
  1933.         return (pc + 1);
  1934.     return fp->f_opcodes[pc];
  1935. }
  1936.  
  1937.  
  1938. static long
  1939. o_jumpne(fp, pc)
  1940.     FUNC *fp;
  1941.     long pc;
  1942. {
  1943.     VALUE *vp;
  1944.     int i;            /* result of comparison */
  1945.  
  1946.     vp = stack;
  1947.     if (vp->v_type == V_ADDR)
  1948.         vp = vp->v_addr;
  1949.     if (vp->v_type == V_NUM) {
  1950.         i = !qiszero(vp->v_num);
  1951.         if (stack->v_type == V_NUM)
  1952.             qfree(stack->v_num);
  1953.     } else {
  1954.         i = testvalue(vp);
  1955.         freevalue(stack);
  1956.     }
  1957.     stack--;
  1958.     if (i)
  1959.         return fp->f_opcodes[pc];
  1960.     return (pc + 1);
  1961. }
  1962.  
  1963.  
  1964. static long
  1965. o_condorjump(fp, pc)
  1966.     FUNC *fp;
  1967.     long pc;
  1968. {
  1969.     VALUE *vp;
  1970.  
  1971.     vp = stack;
  1972.     if (vp->v_type == V_ADDR)
  1973.         vp = vp->v_addr;
  1974.     if (vp->v_type == V_NUM) {
  1975.         if (!qiszero(vp->v_num))
  1976.             return fp->f_opcodes[pc];
  1977.         if (stack->v_type == V_NUM)
  1978.             qfree(stack->v_num);
  1979.         stack--;
  1980.         return pc + 1;
  1981.     }
  1982.     if (testvalue(vp))
  1983.         return fp->f_opcodes[pc];
  1984.     freevalue(stack--);
  1985.     return pc + 1;
  1986. }
  1987.  
  1988.  
  1989. static long
  1990. o_condandjump(fp, pc)
  1991.     FUNC *fp;
  1992.     long pc;
  1993. {
  1994.     VALUE *vp;
  1995.  
  1996.     vp = stack;
  1997.     if (vp->v_type == V_ADDR)
  1998.         vp = vp->v_addr;
  1999.     if (vp->v_type == V_NUM) {
  2000.         if (qiszero(vp->v_num))
  2001.             return fp->f_opcodes[pc];
  2002.         if (stack->v_type == V_NUM)
  2003.             qfree(stack->v_num);
  2004.         stack--;
  2005.         return pc + 1;
  2006.     }
  2007.     if (!testvalue(vp))
  2008.         return fp->f_opcodes[pc];
  2009.     freevalue(stack--);
  2010.     return pc + 1;
  2011. }
  2012.  
  2013.  
  2014. /*
  2015.  * Compare the top two values on the stack for equality and jump if they are
  2016.  * different, popping off the top element, leaving the first one on the stack.
  2017.  * If they are equal, pop both values and do not jump.
  2018.  */
  2019. static long
  2020. o_casejump(fp, pc)
  2021.     FUNC *fp;
  2022.     long pc;
  2023. {
  2024.     VALUE *v1, *v2;
  2025.     int r;
  2026.  
  2027.     v1 = &stack[-1];
  2028.     v2 = &stack[0];
  2029.     if (v1->v_type == V_ADDR)
  2030.         v1 = v1->v_addr;
  2031.     if (v2->v_type == V_ADDR)
  2032.         v2 = v2->v_addr;
  2033.     r = comparevalue(v1, v2);
  2034.     freevalue(stack--);
  2035.     if (r)
  2036.         return (fp->f_opcodes[pc]);
  2037.     freevalue(stack--);
  2038.     return (pc + 1);
  2039. }
  2040.  
  2041.  
  2042. static long
  2043. o_jump(fp, pc)
  2044.     FUNC *fp;
  2045.     long pc;
  2046. {
  2047.     return fp->f_opcodes[pc];
  2048. }
  2049.  
  2050.  
  2051. static long
  2052. o_usercall(fp, index, argcount)
  2053.     FUNC *fp;
  2054.     long index, argcount;
  2055. {
  2056.     fp = findfunc(index);
  2057.     if (fp == NULL)
  2058.         error("Function \"%s\" is undefined", namefunc(index));
  2059.     calculate(fp, (int) argcount);
  2060.     return 0;
  2061. }
  2062.  
  2063.  
  2064. /*ARGSUSED*/
  2065. static long
  2066. o_call(fp, index, argcount)
  2067.     FUNC *fp;
  2068.     long index, argcount;
  2069. {
  2070.     VALUE result;
  2071.  
  2072.     result = builtinfunc(index, (int) argcount, stack);
  2073.     while (--argcount >= 0)
  2074.         freevalue(stack--);
  2075.     stack++;
  2076.     *stack = result;
  2077.     return 0;
  2078. }
  2079.  
  2080.  
  2081. static long
  2082. o_getvalue()
  2083. {
  2084.     if (stack->v_type == V_ADDR)
  2085.         copyvalue(stack->v_addr, stack);
  2086.     return 0;
  2087. }
  2088.  
  2089.  
  2090. static long
  2091. o_cmp()
  2092. {
  2093.     VALUE *v1, *v2;
  2094.     int r;
  2095.  
  2096.     v1 = &stack[-1];
  2097.     v2 = &stack[0];
  2098.     if (v1->v_type == V_ADDR)
  2099.         v1 = v1->v_addr;
  2100.     if (v2->v_type == V_ADDR)
  2101.         v2 = v2->v_addr;
  2102.     r = relvalue(v1, v2);
  2103.     freevalue(stack--);
  2104.     freevalue(stack);
  2105.     stack->v_num = itoq((long) r);
  2106.     stack->v_type = V_NUM;
  2107.     return 0;
  2108. }
  2109.  
  2110.  
  2111. static long
  2112. o_eq()
  2113. {
  2114.     VALUE *v1, *v2;
  2115.     int r;
  2116.  
  2117.     v1 = &stack[-1];
  2118.     v2 = &stack[0];
  2119.     if (v1->v_type == V_ADDR)
  2120.         v1 = v1->v_addr;
  2121.     if (v2->v_type == V_ADDR)
  2122.         v2 = v2->v_addr;
  2123.     r = comparevalue(v1, v2);
  2124.     freevalue(stack--);
  2125.     freevalue(stack);
  2126.     stack->v_num = itoq((long) (r == 0));
  2127.     stack->v_type = V_NUM;
  2128.     return 0;
  2129. }
  2130.  
  2131.  
  2132. static long
  2133. o_ne()
  2134. {
  2135.     VALUE *v1, *v2;
  2136.     int r;
  2137.  
  2138.     v1 = &stack[-1];
  2139.     v2 = &stack[0];
  2140.     if (v1->v_type == V_ADDR)
  2141.         v1 = v1->v_addr;
  2142.     if (v2->v_type == V_ADDR)
  2143.         v2 = v2->v_addr;
  2144.     r = comparevalue(v1, v2);
  2145.     freevalue(stack--);
  2146.     freevalue(stack);
  2147.     stack->v_num = itoq((long) (r != 0));
  2148.     stack->v_type = V_NUM;
  2149.     return 0;
  2150. }
  2151.  
  2152.  
  2153. static long
  2154. o_le()
  2155. {
  2156.     VALUE *v1, *v2;
  2157.     int r;
  2158.  
  2159.     v1 = &stack[-1];
  2160.     v2 = &stack[0];
  2161.     if (v1->v_type == V_ADDR)
  2162.         v1 = v1->v_addr;
  2163.     if (v2->v_type == V_ADDR)
  2164.         v2 = v2->v_addr;
  2165.     r = relvalue(v1, v2);
  2166.     freevalue(stack--);
  2167.     freevalue(stack);
  2168.     stack->v_num = itoq((long) (r <= 0));
  2169.     stack->v_type = V_NUM;
  2170.     return 0;
  2171. }
  2172.  
  2173.  
  2174. static long
  2175. o_ge()
  2176. {
  2177.     VALUE *v1, *v2;
  2178.     int r;
  2179.  
  2180.     v1 = &stack[-1];
  2181.     v2 = &stack[0];
  2182.     if (v1->v_type == V_ADDR)
  2183.         v1 = v1->v_addr;
  2184.     if (v2->v_type == V_ADDR)
  2185.         v2 = v2->v_addr;
  2186.     r = relvalue(v1, v2);
  2187.     freevalue(stack--);
  2188.     freevalue(stack);
  2189.     stack->v_num = itoq((long) (r >= 0));
  2190.     stack->v_type = V_NUM;
  2191.     return 0;
  2192. }
  2193.  
  2194.  
  2195. static long
  2196. o_lt()
  2197. {
  2198.     VALUE *v1, *v2;
  2199.     int r;
  2200.  
  2201.     v1 = &stack[-1];
  2202.     v2 = &stack[0];
  2203.     if (v1->v_type == V_ADDR)
  2204.         v1 = v1->v_addr;
  2205.     if (v2->v_type == V_ADDR)
  2206.         v2 = v2->v_addr;
  2207.     r = relvalue(v1, v2);
  2208.     freevalue(stack--);
  2209.     freevalue(stack);
  2210.     stack->v_num = itoq((long) (r < 0));
  2211.     stack->v_type = V_NUM;
  2212.     return 0;
  2213. }
  2214.  
  2215.  
  2216. static long
  2217. o_gt()
  2218. {
  2219.     VALUE *v1, *v2;
  2220.     int r;
  2221.  
  2222.     v1 = &stack[-1];
  2223.     v2 = &stack[0];
  2224.     if (v1->v_type == V_ADDR)
  2225.         v1 = v1->v_addr;
  2226.     if (v2->v_type == V_ADDR)
  2227.         v2 = v2->v_addr;
  2228.     r = relvalue(v1, v2);
  2229.     freevalue(stack--);
  2230.     freevalue(stack);
  2231.     stack->v_num = itoq((long) (r > 0));
  2232.     stack->v_type = V_NUM;
  2233.     return 0;
  2234. }
  2235.  
  2236.  
  2237. static long
  2238. o_preinc()
  2239. {
  2240.     NUMBER *q, **np;
  2241.     VALUE *vp, tmp;
  2242.  
  2243.     if (stack->v_type != V_ADDR)
  2244.         error("Preincrementing non-variable");
  2245.     if (stack->v_addr->v_type == V_NUM) {
  2246.         np = &stack->v_addr->v_num;
  2247.         q = qinc(*np);
  2248.         qfree(*np);
  2249.         *np = q;
  2250.         stack->v_type = V_NUM;
  2251.         stack->v_num = qlink(q);
  2252.         return 0;
  2253.     }
  2254.     vp = stack->v_addr;
  2255.     incvalue(vp, &tmp);
  2256.     freevalue(vp);
  2257.     *vp = tmp;
  2258.     copyvalue(&tmp, stack);
  2259.     return 0;
  2260. }
  2261.  
  2262.  
  2263. static long
  2264. o_predec()
  2265. {
  2266.     NUMBER *q, **np;
  2267.     VALUE *vp, tmp;
  2268.  
  2269.     if (stack->v_type != V_ADDR)
  2270.         error("Predecrementing non-variable");
  2271.     if (stack->v_addr->v_type == V_NUM) {
  2272.         np = &stack->v_addr->v_num;
  2273.         q = qdec(*np);
  2274.         qfree(*np);
  2275.         *np = q;
  2276.         stack->v_type = V_NUM;
  2277.         stack->v_num = qlink(q);
  2278.         return 0;
  2279.     }
  2280.     vp = stack->v_addr;
  2281.     decvalue(vp, &tmp);
  2282.     freevalue(vp);
  2283.     *vp = tmp;
  2284.     copyvalue(&tmp, stack);
  2285.     return 0;
  2286. }
  2287.  
  2288.  
  2289. static long
  2290. o_postinc()
  2291. {
  2292.     NUMBER *q, **np;
  2293.     VALUE *vp, tmp;
  2294.  
  2295.     if (stack->v_type != V_ADDR)
  2296.         error("Postincrementing non-variable");
  2297.     if (stack->v_addr->v_type == V_NUM) {
  2298.         np = &stack->v_addr->v_num;
  2299.         q = *np;
  2300.         *np = qinc(q);
  2301.         stack->v_type = V_NUM;
  2302.         stack->v_num = q;
  2303.         return 0;
  2304.     }
  2305.     vp = stack->v_addr;
  2306.     tmp = *vp;
  2307.     incvalue(&tmp, vp);
  2308.     *stack = tmp;
  2309.     return 0;
  2310. }
  2311.  
  2312.  
  2313. static long
  2314. o_postdec()
  2315. {
  2316.     NUMBER *q, **np;
  2317.     VALUE *vp, tmp;
  2318.  
  2319.     if (stack->v_type != V_ADDR)
  2320.         error("Postdecrementing non-variable");
  2321.     if (stack->v_addr->v_type == V_NUM) {
  2322.         np = &stack->v_addr->v_num;
  2323.         q = *np;
  2324.         *np = qdec(q);
  2325.         stack->v_type = V_NUM;
  2326.         stack->v_num = q;
  2327.         return 0;
  2328.     }
  2329.     vp = stack->v_addr;
  2330.     tmp = *vp;
  2331.     decvalue(&tmp, vp);
  2332.     *stack = tmp;
  2333.     return 0;
  2334. }
  2335.  
  2336.  
  2337. static long
  2338. o_leftshift()
  2339. {
  2340.     VALUE *v1, *v2;
  2341.     VALUE tmp;
  2342.  
  2343.     v1 = &stack[-1];
  2344.     v2 = &stack[0];
  2345.     if (v1->v_type == V_ADDR)
  2346.         v1 = v1->v_addr;
  2347.     if (v2->v_type == V_ADDR)
  2348.         v2 = v2->v_addr;
  2349.     shiftvalue(v1, v2, FALSE, &tmp);
  2350.     freevalue(stack--);
  2351.     freevalue(stack);
  2352.     *stack = tmp;
  2353.     return 0;
  2354. }
  2355.  
  2356.  
  2357. static long
  2358. o_rightshift()
  2359. {
  2360.     VALUE *v1, *v2;
  2361.     VALUE tmp;
  2362.  
  2363.     v1 = &stack[-1];
  2364.     v2 = &stack[0];
  2365.     if (v1->v_type == V_ADDR)
  2366.         v1 = v1->v_addr;
  2367.     if (v2->v_type == V_ADDR)
  2368.         v2 = v2->v_addr;
  2369.     shiftvalue(v1, v2, TRUE, &tmp);
  2370.     freevalue(stack--);
  2371.     freevalue(stack);
  2372.     *stack = tmp;
  2373.     return 0;
  2374. }
  2375.  
  2376.  
  2377. /*ARGSUSED*/
  2378. static long
  2379. o_debug(fp, line)
  2380.     FUNC *fp;
  2381.     long line;
  2382. {
  2383.     funcline = line;
  2384.     if (abortlevel >= ABORT_STATEMENT)
  2385.         error("Calculation aborted at statement boundary");
  2386.     return 0;
  2387. }
  2388.  
  2389.  
  2390. static long
  2391. o_printresult()
  2392. {
  2393.     VALUE *vp;
  2394.  
  2395.     vp = stack;
  2396.     if (vp->v_type == V_ADDR)
  2397.         vp = vp->v_addr;
  2398.     if (vp->v_type != V_NULL) {
  2399.         printf("\t");
  2400.         printvalue(vp, PRINT_UNAMBIG);
  2401.         printf("\n");
  2402.         fflush(stdout);
  2403.     }
  2404.     freevalue(stack--);
  2405.     return 0;
  2406. }
  2407.  
  2408.  
  2409. /*ARGSUSED*/
  2410. static long
  2411. o_print(fp, flags)
  2412.     FUNC *fp;
  2413.     long flags;
  2414. {
  2415.     VALUE *vp;
  2416.  
  2417.     vp = stack;
  2418.     if (vp->v_type == V_ADDR)
  2419.         vp = vp->v_addr;
  2420.     printvalue(vp, (int) flags);
  2421.     freevalue(stack--);
  2422.     if (traceflags & TRACE_OPCODES)
  2423.         printf("\n");
  2424.     fflush(stdout);
  2425.     return 0;
  2426. }
  2427.  
  2428.  
  2429. static long
  2430. o_printeol()
  2431. {
  2432.     putchar('\n');
  2433.     fflush(stdout);
  2434.     return 0;
  2435. }
  2436.  
  2437.  
  2438. static long
  2439. o_printspace()
  2440. {
  2441.     putchar(' ');
  2442.     if (traceflags & TRACE_OPCODES)
  2443.         printf("\n");
  2444.     return 0;
  2445. }
  2446.  
  2447.  
  2448. /*ARGSUSED*/
  2449. static long
  2450. o_printstring(fp, cp)
  2451.     FUNC *fp;
  2452.     char *cp;
  2453. {
  2454.     fputs(cp, stdout);
  2455.     if (traceflags & TRACE_OPCODES)
  2456.         printf("\n");
  2457.     fflush(stdout);
  2458.     return 0;
  2459. }
  2460.  
  2461.  
  2462. static long
  2463. o_zero()
  2464. {
  2465.     stack++;
  2466.     stack->v_type = V_NUM;
  2467.     stack->v_num = qlink(&_qzero_);
  2468.     return 0;
  2469. }
  2470.  
  2471.  
  2472. static long
  2473. o_one()
  2474. {
  2475.     stack++;
  2476.     stack->v_type = V_NUM;
  2477.     stack->v_num = qlink(&_qone_);
  2478.     return 0;
  2479. }
  2480.  
  2481.  
  2482. static long
  2483. o_save(fp)
  2484.     FUNC *fp;
  2485. {
  2486.     VALUE *vp;
  2487.  
  2488.     vp = stack;
  2489.     if (vp->v_type == V_ADDR)
  2490.         vp = vp->v_addr;
  2491.     freevalue(&fp->f_savedvalue);
  2492.     copyvalue(vp, &fp->f_savedvalue);
  2493.     return 0;
  2494. }
  2495.  
  2496.  
  2497. /*ARGSUSED*/
  2498. static long
  2499. o_oldvalue(fp)
  2500.     FUNC *fp;
  2501. {
  2502.     copyvalue(&oldvalue, ++stack);
  2503.     return 0;
  2504. }
  2505.  
  2506.  
  2507. static long
  2508. o_quit(fp, cp)
  2509.     FUNC *fp;
  2510.     char *cp;
  2511. {
  2512.     if ((fp->f_name[0] == '*') && (fp->f_name[1] == '\0')) {
  2513.         if (cp)
  2514.             printf("%s\n", cp);
  2515.         exit(0);
  2516.     }
  2517.     if (cp)
  2518.         error("%s", cp);
  2519.     error("quit statement executed");
  2520.     return 0;
  2521. }
  2522.  
  2523.  
  2524. static long
  2525. o_getepsilon()
  2526. {
  2527.     stack++;
  2528.     stack->v_type = V_NUM;
  2529.     stack->v_num = qlink(_epsilon_);
  2530.     return 0;
  2531. }
  2532.  
  2533.  
  2534. static long
  2535. o_setepsilon()
  2536. {
  2537.     VALUE *vp;
  2538.     NUMBER *new;
  2539.  
  2540.     vp = &stack[0];
  2541.     if (vp->v_type == V_ADDR)
  2542.         vp = vp->v_addr;
  2543.     if (vp->v_type != V_NUM)
  2544.         error("Non-numeric for epsilon");
  2545.     new = vp->v_num;
  2546.     stack->v_num = qlink(_epsilon_);
  2547.     setepsilon(new);
  2548.     qfree(new);
  2549.     return 0;
  2550. }
  2551.  
  2552.  
  2553. static long
  2554. o_setconfig()
  2555. {
  2556.     int type;
  2557.     VALUE *v1, *v2;
  2558.     VALUE tmp;
  2559.  
  2560.     v1 = &stack[-1];
  2561.     v2 = &stack[0];
  2562.     if (v1->v_type == V_ADDR)
  2563.         v1 = v1->v_addr;
  2564.     if (v2->v_type == V_ADDR)
  2565.         v2 = v2->v_addr;
  2566.     if (v1->v_type != V_STR)
  2567.         error("Non-string for config");
  2568.     type = configtype(v1->v_str);
  2569.     if (type < 0)
  2570.         error("Unknown config name \"%s\"", v1->v_str);
  2571.     getconfig(type, &tmp);
  2572.     setconfig(type, v2);
  2573.     freevalue(stack--);
  2574.     freevalue(stack);
  2575.     *stack = tmp;
  2576.     return 0;
  2577. }
  2578.  
  2579.  
  2580. static long
  2581. o_getconfig()
  2582. {
  2583.     int type;
  2584.     VALUE *vp;
  2585.  
  2586.     vp = &stack[0];
  2587.     if (vp->v_type == V_ADDR)
  2588.         vp = vp->v_addr;
  2589.     if (vp->v_type != V_STR)
  2590.         error("Non-string for config");
  2591.     type = configtype(vp->v_str);
  2592.     if (type < 0)
  2593.         error("Unknown config name \"%s\"", vp->v_str);
  2594.     freevalue(stack);
  2595.     getconfig(type, stack);
  2596.     return 0;
  2597. }
  2598.  
  2599.  
  2600. /*
  2601.  * Set the 'old' value to the last value saved during the calculation.
  2602.  */
  2603. void
  2604. updateoldvalue(fp)
  2605.     FUNC *fp;
  2606. {
  2607.     if (fp->f_savedvalue.v_type == V_NULL)
  2608.         return;
  2609.     freevalue(&oldvalue);
  2610.     oldvalue = fp->f_savedvalue;
  2611.     fp->f_savedvalue.v_type = V_NULL;
  2612.     return;
  2613. }
  2614.  
  2615.  
  2616. /*
  2617.  * Routine called on any runtime error, to complain about it (with possible
  2618.  * arguments), and then longjump back to the top level command scanner.
  2619.  */
  2620. #ifdef VARARGS
  2621. # define VA_ALIST fmt, va_alist
  2622. # define VA_DCL char *fmt; va_dcl
  2623. #else
  2624. # ifdef __STDC__
  2625. #  define VA_ALIST char *fmt, ...
  2626. #  define VA_DCL
  2627. # else
  2628. #  define VA_ALIST fmt
  2629. #  define VA_DCL char *fmt;
  2630. # endif
  2631. #endif
  2632. /*VARARGS*/
  2633. void
  2634. error(VA_ALIST)
  2635.     VA_DCL
  2636. {
  2637.     va_list ap;
  2638.     char buf[MAXERROR+1];
  2639.  
  2640.     if (funcname && (*funcname != '*'))
  2641.         fprintf(stderr, "\"%s\": ", funcname);
  2642.     if (funcline && ((funcname && (*funcname != '*')) || !inputisterminal()))
  2643.         fprintf(stderr, "line %ld: ", funcline);
  2644. #ifdef VARARGS
  2645.     va_start(ap);
  2646. #else
  2647.     va_start(ap, fmt);
  2648. #endif
  2649.     vsprintf(buf, fmt, ap);
  2650.     va_end(ap);
  2651.     fprintf(stderr, "%s\n", buf);
  2652.     funcname = NULL;
  2653.     longjmp(jmpbuf, 1);
  2654.     return;
  2655. }
  2656.  
  2657. /* END CODE */
  2658.