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