?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
modified: src1/input.c
[GalaxyCodeBases.git] / c_cpp / etc / calc / opcodes.c
blob40ca69295dfbe1b774bc7acde84707ead434eda6
1 /*
2 * opcodes - opcode execution module
3 *
4 * Copyright (C) 1999-2007 David I. Bell and Ernest Bowen
5 *
6 * Primary author: David I. Bell
7 *
8 * Calc is open software; you can redistribute it and/or modify it under
9 * the terms of the version 2.1 of the GNU Lesser General Public License
10 * as published by the Free Software Foundation.
11 *
12 * Calc is distributed in the hope that it will be useful, but WITHOUT
13 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
14 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
15 * Public License for more details.
16 *
17 * A copy of version 2.1 of the GNU Lesser General Public License is
18 * distributed with calc under the filename COPYING-LGPL. You should have
19 * received a copy with calc; if not, write to Free Software Foundation, Inc.
20 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
21 *
22 * @(#) $Revision: 30.5 $
23 * @(#) $Id: opcodes.c,v 30.5 2013/08/11 08:41:38 chongo Exp $
24 * @(#) $Source: /usr/local/src/bin/calc/RCS/opcodes.c,v $
25 *
26 * Under source code control: 1990/02/15 01:48:19
27 * File existed as early as: before 1990
28 *
29 * Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/
30 */
31
32
33 #include <stdio.h>
34 #include <sys/types.h>
35 #include <setjmp.h>
36
37 #include "calc.h"
38 #include "opcodes.h"
39 #include "func.h"
40 #include "symbol.h"
41 #include "hist.h"
42 #include "file.h"
43 #include "zrand.h"
44 #include "zrandom.h"
45 #include "have_fpos.h"
46 #include "custom.h"
47 #include "lib_calc.h"
48 #include "block.h"
49 #include "str.h"
50
51 #include "have_unused.h"
52
53 #define QUICKLOCALS 20 /* local vars to handle quickly */
54
55
56 STATIC VALUE stackarray[MAXSTACK]; /* storage for stack */
57 STATIC VALUE oldvalue; /* previous calculation value */
58 STATIC BOOL saveval = TRUE; /* to enable or disable saving */
59 STATIC int calc_errno; /* most recent error-number */
60 STATIC int errcount; /* counts calls to error_value */
61 STATIC BOOL go;
62 STATIC long calc_depth;
63
64 /*
65 * global symbols
66 */
67 VALUE *stack; /* current location of top of stack */
68 int dumpnames; /* names if TRUE, otherwise indices */
69 char *funcname; /* function being executed */
70 long funcline; /* function line being executed */
71
72
73 /*
74 * forward declarations
75 */
76 S_FUNC void showsizes(void);
77 S_FUNC void o_paramaddr(FUNC *fp, int argcnt, VALUE *args, long index);
78 S_FUNC void o_getvalue(void);
79
80
81 /*
82 * Types of opcodes (depends on arguments saved after the opcode).
83 */
84 #define OPNUL 1 /* opcode has no arguments */
85 #define OPONE 2 /* opcode has one integer argument */
86 #define OPTWO 3 /* opcode has two integer arguments */
87 #define OPJMP 4 /* opcode is a jump (with one pointer argument) */
88 #define OPRET 5 /* opcode is a return (with no argument) */
89 #define OPGLB 6 /* opcode has global symbol pointer argument */
90 #define OPPAR 7 /* opcode has parameter index argument */
91 #define OPLOC 8 /* opcode needs local variable pointer (with one arg) */
92 #define OPSTR 9 /* opcode has a string constant arg */
93 #define OPARG 10 /* opcode is given number of arguments */
94 #define OPSTI 11 /* opcode is static initialization */
95
96
97 /*
98 * opcode - info about each opcode
99 */
100 struct opcode {
101 void (*o_func)(); /* routine to call for opcode */
102 int o_type; /* type of opcode */
103 char *o_name; /* name of opcode */
104 };
105
106
107 /*
108 * external configuration functions
109 */
110 E_FUNC void config_value(CONFIG *cfg, int type, VALUE *ret);
111 E_FUNC void setconfig(int type, VALUE *vp);
112
113
114 /*
115 * Initialize the stack.
116 */
117 void
118 initstack(void)
119 {
120 unsigned int i;
121
122 /* on first init, setup the stack array */
123 if (stack == NULL) {
124 for (i=0; i < sizeof(stackarray)/sizeof(stackarray[0]); ++i) {
125 stackarray[i].v_type = V_NULL;
126 stackarray[i].v_subtype = V_NOSUBTYPE;
127 }
128 stack = stackarray;
129
130 /* on subsequent inits, free the old stack */
131 } else {
132 while (stack > stackarray) {
133 freevalue(stack--);
134 }
135 }
136 /* initialize calc_depth */
137
138 calc_depth = 0;
139 }
140
141
142 /*
143 * The various opcodes
144 */
145 S_FUNC void
146 o_nop(void)
147 {
148 }
149
150
151 S_FUNC void
152 o_localaddr(FUNC *fp, VALUE *locals, long index)
153 {
154 if ((unsigned long)index >= fp->f_localcount) {
155 math_error("Bad local variable index");
156 /*NOTREACHED*/
157 }
158 locals += index;
159 stack++;
160 stack->v_addr = locals;
161 stack->v_type = V_ADDR;
162 stack->v_subtype = V_NOSUBTYPE;
163 }
164
165
166 /*ARGSUSED*/
167 S_FUNC void
168 o_globaladdr(FUNC UNUSED *fp, GLOBAL *sp)
169 {
170 if (sp == NULL) {
171 math_error("Global variable \"%s\" not initialized",
172 sp->g_name);
173 /*NOTREACHED*/
174 }
175 stack++;
176 stack->v_addr = &sp->g_value;
177 stack->v_type = V_ADDR;
178 stack->v_subtype = V_NOSUBTYPE;
179 }
180
181
182 /*ARGSUSED*/
183 S_FUNC void
184 o_paramaddr(FUNC UNUSED *fp, int argcount, VALUE *args, long index)
185 {
186 if ((long)index >= argcount) {
187 math_error("Bad parameter index");
188 /*NOTREACHED*/
189 }
190 args += index;
191 stack++;
192 if (args->v_type == V_OCTET || args->v_type == V_ADDR) {
193 *stack = *args;
194 return;
195 }
196 stack->v_addr = args;
197 stack->v_type = V_ADDR;
198 /* stack->v_subtype = V_NOSUBTYPE; */ /* XXX ??? */
199 }
200
201
202 S_FUNC void
203 o_localvalue(FUNC *fp, VALUE *locals, long index)
204 {
205 if ((unsigned long)index >= fp->f_localcount) {
206 math_error("Bad local variable index");
207 /*NOTREACHED*/
208 }
209 locals += index;
210 copyvalue(locals, ++stack);
211 }
212
213
214 /*ARGSUSED*/
215 S_FUNC void
216 o_globalvalue(FUNC UNUSED *fp, GLOBAL *sp)
217 {
218 if (sp == NULL) {
219 math_error("Global variable not defined");
220 /*NOTREACHED*/
221 }
222 copyvalue(&sp->g_value, ++stack);
223 }
224
225
226 /*ARGSUSED*/
227 S_FUNC void
228 o_paramvalue(FUNC UNUSED *fp, int argcount, VALUE *args, long index)
229 {
230 if ((long)index >= argcount) {
231 math_error("Bad parameter index");
232 /*NOTREACHED*/
233 }
234 args += index;
235 if (args->v_type == V_ADDR)
236 args = args->v_addr;
237 copyvalue(args, ++stack);
238 }
239
240
241 S_FUNC void
242 o_argvalue(FUNC *fp, int argcount, VALUE *args)
243 {
244 VALUE *vp;
245 long index;
246
247 vp = stack;
248 if (vp->v_type == V_ADDR)
249 vp = vp->v_addr;
250 if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
251 qisfrac(vp->v_num)) {
252 math_error("Illegal argument for arg function");
253 /*NOTREACHED*/
254 }
255 if (qiszero(vp->v_num)) {
256 if (stack->v_type == V_NUM)
257 qfree(stack->v_num);
258 stack->v_num = itoq((long) argcount);
259 stack->v_type = V_NUM;
260 stack->v_subtype = V_NOSUBTYPE;
261 return;
262 }
263 index = qtoi(vp->v_num) - 1;
264 if (stack->v_type == V_NUM)
265 qfree(stack->v_num);
266 stack--;
267 (void) o_paramaddr(fp, argcount, args, index);
268 }
269
270
271 /*ARGSUSED*/
272 S_FUNC void
273 o_number(FUNC UNUSED *fp, long arg)
274 {
275 NUMBER *q;
276
277 q = constvalue(arg);
278 if (q == NULL) {
279 math_error("Numeric constant value not found");
280 /*NOTREACHED*/
281 }
282 stack++;
283 stack->v_num = qlink(q);
284 stack->v_type = V_NUM;
285 stack->v_subtype = V_NOSUBTYPE;
286 }
287
288
289 /*ARGSUSED*/
290 S_FUNC void
291 o_imaginary(FUNC UNUSED *fp, long arg)
292 {
293 NUMBER *q;
294 COMPLEX *c;
295
296 q = constvalue(arg);
297 if (q == NULL) {
298 math_error("Numeric constant value not found");
299 /*NOTREACHED*/
300 }
301 stack++;
302 stack->v_subtype = V_NOSUBTYPE;
303 if (qiszero(q)) {
304 stack->v_num = qlink(q);
305 stack->v_type = V_NUM;
306 return;
307 }
308 c = comalloc();
309 qfree(c->imag);
310 c->imag = qlink(q);
311 stack->v_com = c;
312 stack->v_type = V_COM;
313 }
314
315
316 /*ARGSUSED*/
317 S_FUNC void
318 o_string(FUNC UNUSED *fp, long arg)
319 {
320 stack++;
321 stack->v_str = slink(findstring(arg));
322 stack->v_type = V_STR;
323 stack->v_subtype = V_NOSUBTYPE;
324 }
325
326
327 S_FUNC void
328 o_undef(void)
329 {
330 stack++;
331 stack->v_type = V_NULL;
332 stack->v_subtype = V_NOSUBTYPE;
333 }
334
335
336 /*ARGSUSED*/
337 S_FUNC void
338 o_matcreate(FUNC UNUSED *fp, long dim)
339 {
340 register MATRIX *mp; /* matrix being defined */
341 NUMBER *num1; /* first number from stack */
342 NUMBER *num2; /* second number from stack */
343 VALUE *v1, *v2;
344 long min[MAXDIM]; /* minimum range */
345 long max[MAXDIM]; /* maximum range */
346 long i; /* index */
347 long tmp; /* temporary */
348 long size; /* size of matrix */
349
350 if ((dim < 0) || (dim > MAXDIM)) {
351 math_error("Bad dimension %ld for matrix", dim);
352 /*NOTREACHED*/
353 }
354 size = 1;
355 for (i = dim - 1; i >= 0; i--) {
356 v1 = &stack[-1];
357 v2 = &stack[0];
358 if (v1->v_type == V_ADDR)
359 v1 = v1->v_addr;
360 if (v2->v_type == V_ADDR)
361 v2 = v2->v_addr;
362 if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
363 math_error("Non-numeric bounds for matrix");
364 /*NOTREACHED*/
365 }
366 num1 = v1->v_num;
367 num2 = v2->v_num;
368 if (qisfrac(num1) || qisfrac(num2)) {
369 math_error("Non-integral bounds for matrix");
370 /*NOTREACHED*/
371 }
372 if (zge31b(num1->num) || zge31b(num2->num)) {
373 math_error("Very large bounds for matrix");
374 /*NOTREACHED*/
375 }
376 min[i] = qtoi(num1);
377 max[i] = qtoi(num2);
378 if (min[i] > max[i]) {
379 tmp = min[i];
380 min[i] = max[i];
381 max[i] = tmp;
382 }
383 size *= (max[i] - min[i] + 1);
384 if (size > 10000000) {
385 math_error("Very large size for matrix");
386 /*NOTREACHED*/
387 }
388 freevalue(stack--);
389 freevalue(stack--);
390 }
391 mp = matalloc(size);
392 mp->m_dim = dim;
393 for (i = 0; i < dim; i++) {
394 mp->m_min[i] = min[i];
395 mp->m_max[i] = max[i];
396 }
397 stack++;
398 stack->v_type = V_MAT;
399 stack->v_subtype = V_NOSUBTYPE;
400 stack->v_mat = mp;
401 }
402
403
404 /*ARGSUSED*/
405 S_FUNC void
406 o_eleminit(FUNC UNUSED *fp, long index)
407 {
408 VALUE *vp;
409 STATIC VALUE *oldvp;
410 VALUE tmp;
411 OCTET *ptr;
412 BLOCK *blk;
413 unsigned short subtype;
414
415 vp = &stack[-1];
416 if (vp->v_type == V_ADDR)
417 vp = vp->v_addr;
418 if (vp->v_type < 0) {
419 freevalue(stack--);
420 error_value(E_INIT1);
421 return;
422 }
423 if (vp->v_subtype & V_NOCOPYTO) {
424 freevalue(stack--);
425 error_value(E_INIT2);
426 return;
427 }
428 switch (vp->v_type) {
429 case V_MAT:
430 if ((index < 0) || (index >= vp->v_mat->m_size)) {
431 freevalue(stack--);
432 error_value(E_INIT3);
433 return;
434 }
435 oldvp = &vp->v_mat->m_table[index];
436 break;
437 case V_OBJ:
438 if (index < 0 || index >= vp->v_obj->o_actions->oa_count) {
439 freevalue(stack--);
440 error_value(E_INIT3);
441 return;
442 }
443 oldvp = &vp->v_obj->o_table[index];
444 break;
445 case V_LIST:
446 oldvp = listfindex(vp->v_list, index);
447 if (oldvp == NULL) {
448 freevalue(stack--);
449 error_value(E_INIT3);
450 return;
451 }
452 break;
453 case V_STR:
454 if (index < 0 || (size_t)index >= vp->v_str->s_len) {
455 freevalue(stack--);
456 error_value(E_INIT3);
457 return;
458 }
459 ptr = (OCTET *)(&vp->v_str->s_str[index]);
460 vp = stack;
461 if (vp->v_type == V_ADDR)
462 vp = vp->v_addr;
463 copy2octet(vp, ptr);
464 freevalue(stack--);
465 return;
466 case V_NBLOCK:
467 case V_BLOCK:
468 if (vp->v_type == V_NBLOCK) {
469 blk = vp->v_nblock->blk;
470 if (blk->data == NULL) {
471 freevalue(stack--);
472 error_value(E_INIT4);
473 return;
474 }
475 }
476 else
477 blk = vp->v_block;
478 if (index >= blk->maxsize) {
479 freevalue(stack--);
480 error_value(E_INIT3);
481 return;
482 }
483 ptr = blk->data + index;
484 vp = stack;
485 if (vp->v_type == V_ADDR)
486 vp = vp->v_addr;
487 copy2octet(vp, ptr);
488 if (index >= blk->datalen)
489 blk->datalen = index + 1;
490 freevalue(stack--);
491 return;
492 default:
493 freevalue(stack--);
494 error_value(E_INIT5);
495 return;
496 }
497 vp = stack--;
498 subtype = oldvp->v_subtype;
499 if (subtype & V_NOASSIGNTO) {
500 freevalue(vp);
501 error_value(E_INIT6);
502 return;
503 }
504 if (vp->v_type == V_ADDR) {
505 vp = vp->v_addr;
506 if (vp == oldvp)
507 return;
508 copyvalue(vp, &tmp);
509 }
510 else
511 tmp = *vp;
512 if ((subtype & V_NONEWVALUE) && comparevalue(oldvp, &tmp)) {
513 freevalue(&tmp);
514 error_value(E_INIT7);
515 return;
516 }
517 if ((subtype & V_NONEWTYPE) && oldvp->v_type != tmp.v_type) {
518 freevalue(&tmp);
519 error_value(E_INIT8);
520 return;
521 }
522 if ((subtype & V_NOERROR) && tmp.v_type < 0) {
523 error_value(E_INIT9);
524 return;
525 }
526 if (tmp.v_subtype & (V_NOASSIGNFROM | V_NOCOPYFROM)) {
527 freevalue(&tmp);
528 error_value(E_INIT10);
529 return;
530 }
531 tmp.v_subtype |= oldvp->v_subtype;
532 freevalue(oldvp);
533 *oldvp = tmp;
534 }
535
536
537 /*
538 * o_indexaddr
539 *
540 * given:
541 * fp function to calculate
542 * dim dimension of matrix
543 * writeflag nonzero if element will be written
544 */
545 /*ARGSUSED*/
546 S_FUNC void
547 o_indexaddr(FUNC UNUSED *fp, long dim, long writeflag)
548 {
549 int i;
550 BOOL flag;
551 VALUE *val;
552 VALUE *vp;
553 VALUE indices[MAXDIM]; /* index values */
554 long index; /* single dimension index for blocks */
555 VALUE ret; /* OCTET from as indexed from a block */
556 BLOCK *blk;
557
558 flag = (writeflag != 0);
559 if (dim < 0) {
560 math_error("Negative dimension for indexing");
561 /*NOTREACHED*/
562 }
563 val = &stack[-dim];
564 if (val->v_type != V_NBLOCK && val->v_type != V_FILE) {
565 if (val->v_type != V_ADDR) {
566 math_error("Non-pointer for indexaddr");
567 /*NOTREACHED*/
568 }
569 val = val->v_addr;
570 }
571 blk = NULL;
572 vp = &stack[-dim + 1];
573 for (i = 0; i < dim; i++) {
574 if (vp->v_type == V_ADDR)
575 indices[i] = vp->v_addr[0];
576 else
577 indices[i] = vp[0];
578 vp++;
579 }
580
581 switch (val->v_type) {
582 case V_MAT:
583 vp = matindex(val->v_mat, flag, dim, indices);
584 break;
585 case V_ASSOC:
586 vp = associndex(val->v_assoc, flag, dim, indices);
587 break;
588 case V_NBLOCK:
589 case V_BLOCK:
590 if (val->v_type == V_BLOCK)
591 blk = val->v_block;
592 else
593 blk = val->v_nblock->blk;
594 if (blk->data == NULL) {
595 math_error("Freed block");
596 /*NOTREACHED*/
597 }
598
599 /*
600 * obtain single dimensional block index
601 */
602 if (dim != 1) {
603 math_error("block has only one dimension");
604 /*NOTREACHED*/
605 }
606 if (indices[0].v_type != V_NUM) {
607 math_error("Non-numeric index for block");
608 /*NOTREACHED*/
609 }
610 if (qisfrac(indices[0].v_num)) {
611 math_error("Non-integral index for block");
612 /*NOTREACHED*/
613 }
614 if (zge31b(indices[0].v_num->num) ||
615 zisneg(indices[0].v_num->num)) {
616 math_error("Index out of bounds for block");
617 /*NOTREACHED*/
618 }
619 index = ztoi(indices[0].v_num->num);
620
621 if (index >= blk->maxsize) {
622 math_error("Index out of bounds for block");
623 /*NOTREACHED*/
624 }
625 if (index >= blk->datalen)
626 blk->datalen = index + 1;
627 ret.v_type = V_OCTET;
628 ret.v_subtype = val->v_subtype;
629 ret.v_octet = &blk->data[index];
630 freevalue(stack--);
631 *stack = ret;
632 return;
633 case V_STR:
634 if (dim != 1) {
635 math_error("string has only one dimension");
636 /*NOTREACHED*/
637 }
638 if (indices[0].v_type != V_NUM) {
639 math_error("Non-numeric index for string");
640 /*NOTREACHED*/
641 }
642 if (qisfrac(indices[0].v_num)) {
643 math_error("Non-integral index for string");
644 /*NOTREACHED*/
645 }
646 if (zge31b(indices[0].v_num->num) ||
647 zisneg(indices[0].v_num->num)) {
648 math_error("Index out of bounds for string");
649 /*NOTREACHED*/
650 }
651 index = ztoi(indices[0].v_num->num);
652 if (index < 0 || (size_t)index >= val->v_str->s_len) {
653 math_error("Index out of bounds for string");
654 /*NOTREACHED*/
655 }
656 ret.v_type = V_OCTET;
657 ret.v_subtype = val->v_subtype;
658 ret.v_octet = (OCTET *)(val->v_str->s_str + index);
659 freevalue(stack--);
660 *stack = ret;
661 return;
662 case V_LIST:
663 if (dim != 1) {
664 math_error("list has only one dimension");
665 /*NOTREACHED*/
666 }
667 if (indices[0].v_type != V_NUM) {
668 math_error("Non-numeric index for list");
669 /*NOTREACHED*/
670 }
671 if (qisfrac(indices[0].v_num)) {
672 math_error("Non-integral index for list");
673 /*NOTREACHED*/
674 }
675 if (zge31b(indices[0].v_num->num) ||
676 zisneg(indices[0].v_num->num)) {
677 math_error("Index out of bounds for list");
678 /*NOTREACHED*/
679 }
680 index = ztoi(indices[0].v_num->num);
681 vp = listfindex(val->v_list, index);
682 if (vp == NULL) {
683 math_error("Index out of bounds for list");
684 /*NOTREACHED*/
685 }
686 break;
687 default:
688 math_error("Illegal value for indexing");
689 /*NOTREACHED*/
690 }
691 while (dim-- > 0)
692 freevalue(stack--);
693 stack->v_type = V_ADDR;
694 stack->v_addr = vp;
695 }
696
697
698 /*ARGSUSED*/
699 S_FUNC void
700 o_elemaddr(FUNC UNUSED *fp, long index)
701 {
702 VALUE *vp;
703 MATRIX *mp;
704 OBJECT *op;
705 int offset;
706
707 vp = stack;
708 if (vp->v_type == V_ADDR)
709 vp = stack->v_addr;
710 switch (vp->v_type) {
711 case V_MAT:
712 mp = vp->v_mat;
713 if ((index < 0) || (index >= mp->m_size)) {
714 math_error("Non-existent element for matrix");
715 /*NOTREACHED*/
716 }
717 vp = &mp->m_table[index];
718 break;
719 case V_OBJ:
720 op = vp->v_obj;
721 offset = objoffset(op, index);
722 if (offset < 0) {
723 math_error("Non-existent element for object");
724 /*NOTREACHED*/
725 }
726 vp = &op->o_table[offset];
727 break;
728 case V_LIST:
729 vp = listfindex(vp->v_list, index);
730 if (vp == NULL) {
731 math_error("Index out of bounds for list");
732 /*NOTREACHED*/
733 }
734 break;
735 default:
736 math_error("Not initializing matrix, object or list");
737 /*NOTREACHED*/
738 }
739 stack->v_type = V_ADDR;
740 stack->v_addr = vp;
741
742 }
743
744
745 S_FUNC void
746 o_elemvalue(FUNC *fp, long index)
747 {
748 o_elemaddr(fp, index);
749 copyvalue(stack->v_addr, stack);
750 }
751
752
753 /*ARGSUSED*/
754 S_FUNC void
755 o_objcreate(FUNC UNUSED *fp, long arg)
756 {
757 stack++;
758 stack->v_type = V_OBJ;
759 stack->v_subtype = V_NOSUBTYPE;
760 stack->v_obj = objalloc(arg);
761 }
762
763
764 S_FUNC void
765 o_assign(void)
766 {
767 VALUE *var; /* variable value */
768 VALUE *vp;
769 VALUE tmp;
770 unsigned short subtype;
771 USB8 octet;
772
773 /*
774 * get what we will store into
775 */
776 var = &stack[-1];
777
778 /*
779 * If what we will store into is an OCTET, we must
780 * handle this specially. Only the bottom 8 bits of
781 * certain value types will be assigned ... not the
782 * entire value.
783 */
784 if (var->v_type == V_OCTET) {
785 if (var->v_subtype & V_NOCOPYTO) {
786 freevalue(stack--);
787 *stack = error_value(E_ASSIGN1);
788 return;
789 }
790 vp = stack;
791 if (vp->v_type == V_ADDR)
792 vp = vp->v_addr;
793 if (vp->v_subtype & V_NOCOPYFROM || vp->v_type < 0) {
794 freevalue(stack--);
795 *stack = error_value(E_ASSIGN2);
796 return;
797 }
798 copy2octet(vp, &octet);
799 freevalue(stack--);
800 if ((var->v_subtype & V_NONEWVALUE) && *var->v_octet != octet) {
801 *stack = error_value(E_ASSIGN3);
802 return;
803 }
804 *var->v_octet = octet;
805 return;
806 }
807 if (var->v_type != V_ADDR) {
808 freevalue(stack--);
809 *stack = error_value(E_ASSIGN4);
810 return;
811 }
812
813 var = var->v_addr;
814 subtype = var->v_subtype;
815 if (subtype & V_NOASSIGNTO) {
816 freevalue(stack--);
817 *stack = error_value(E_ASSIGN5);
818 return;
819 }
820
821 vp = stack;
822
823 if (var->v_type == V_OBJ) {
824 if (vp->v_type == V_ADDR)
825 vp = vp->v_addr;
826 (void) objcall(OBJ_ASSIGN, var, vp, NULL_VALUE);
827 freevalue(stack--);
828 return;
829 }
830
831 stack--;
832
833 /*
834 * Get what we will store from
835 * If what will store from is an address, make a copy
836 * of the de-referenced address instead.
837 */
838 if (vp->v_type == V_ADDR) {
839 vp = vp->v_addr;
840 if (vp == var)
841 return;
842 if (vp->v_subtype & V_NOASSIGNFROM) {
843 *stack = error_value(E_ASSIGN6);
844 return;
845 }
846 copyvalue(vp, &tmp);
847 } else if (vp->v_type == V_OCTET) {
848 copyvalue(vp, &tmp);
849 } else {
850 tmp = *vp;
851 }
852
853 /*
854 * Check protection
855 */
856 if ((subtype & V_NONEWVALUE) && comparevalue(var, &tmp)) {
857 freevalue(&tmp);
858 *stack = error_value(E_ASSIGN7);
859 return;
860 }
861 if ((subtype & V_NONEWTYPE) && var->v_type != tmp.v_type) {
862 freevalue(&tmp);
863 *stack = error_value(E_ASSIGN8);
864 return;
865 }
866 if ((subtype & V_NOERROR) && tmp.v_type < 0) {
867 *stack = error_value(E_ASSIGN9);
868 return;
869 }
870
871 /*
872 * perform the assignment
873 */
874 freevalue(var);
875 *var = tmp;
876 var->v_subtype |= subtype;
877 }
878
879
880 S_FUNC void
881 o_assignback(void)
882 {
883 VALUE tmp;
884
885 tmp = stack[-1];
886 stack[-1] = stack[0];
887 stack[0] = tmp;
888 o_assign();
889 }
890
891
892 S_FUNC void
893 o_assignpop(void)
894 {
895 o_assign();
896 stack--;
897 }
898
899
900 S_FUNC void
901 o_ptr(void)
902 {
903 switch (stack->v_type) {
904 case V_ADDR:
905 stack->v_type = V_VPTR;
906 break;
907 case V_OCTET:
908 stack->v_type = V_OPTR;
909 break;
910 case V_STR:
911 sfree(stack->v_str);
912 stack->v_type = V_SPTR;
913 break;
914 case V_NUM:
915 qfree(stack->v_num);
916 stack->v_type = V_NPTR;
917 break;
918 default:
919 math_error("Addressing non-addressable type");
920 /*NOTREACHED*/
921 }
922 }
923
924
925 S_FUNC void
926 o_deref(void)
927 {
928 VALUE *vp;
929
930 vp = stack;
931
932 if (stack->v_type == V_OCTET) {
933 stack->v_num = itoq(*vp->v_octet);
934 stack->v_type = V_NUM;
935 return;
936 }
937 if (stack->v_type == V_OPTR) {
938 stack->v_type = V_OCTET;
939 return;
940 }
941 if (stack->v_type == V_VPTR) {
942 stack->v_type = V_ADDR;
943 return;
944 }
945 if (stack->v_type == V_SPTR) {
946 stack->v_type = V_STR;
947 return;
948 }
949 if (stack->v_type == V_NPTR) {
950 if (stack->v_num->links == 0) {
951 stack->v_type = V_NULL;
952 return;
953 }
954 stack->v_type = V_NUM;
955 stack->v_num->links++;
956 return;
957 }
958 if (stack->v_type != V_ADDR) {
959 math_error("Dereferencing a non-variable");
960 /*NOTREACHED*/
961 }
962 vp = vp->v_addr;
963 switch (vp->v_type) {
964 case V_ADDR:
965 case V_OCTET:
966 *stack = *vp;
967 break;
968 case V_OPTR:
969 *stack = *vp;
970 stack->v_type = V_OCTET;
971 break;
972 case V_VPTR:
973 *stack = *vp;
974 stack->v_type = V_ADDR;
975 break;
976 case V_SPTR:
977 *stack = *vp;
978 stack->v_type = V_STR;
979 break;
980 case V_NPTR:
981 if (vp->v_num->links == 0) {
982 stack->v_type = V_NULL;
983 break;
984 }
985 stack->v_type = V_NUM;
986 stack->v_num = vp->v_num;
987 stack->v_num->links++;
988 break;
989 default:
990 copyvalue(vp, stack);
991 }
992 }
993
994
995 S_FUNC void
996 o_swap(void)
997 {
998 VALUE *v1, *v2; /* variables to be swapped */
999 VALUE tmp;
1000 USB8 usb;
1001
1002 v1 = stack--;
1003 v2 = stack;
1004
1005 if (v1->v_type == V_OCTET && v2->v_type == V_OCTET) {
1006 if (v1->v_octet != v2->v_octet &&
1007 ((v1->v_subtype | v2->v_subtype) &
1008 (V_NOCOPYTO | V_NOCOPYFROM))) {
1009 *stack = error_value(E_SWAP1);
1010 return;
1011 }
1012 usb = *v1->v_octet;
1013 *v1->v_octet = *v2->v_octet;
1014 *v2->v_octet = usb;
1015 } else if (v1->v_type == V_ADDR && v2->v_type == V_ADDR) {
1016 v1 = v1->v_addr;
1017 v2 = v2->v_addr;
1018 if (v1 != v2 && ((v1->v_subtype | v2->v_subtype) &
1019 (V_NOASSIGNTO | V_NOASSIGNFROM))) {
1020 *stack = error_value(E_SWAP2);
1021 return;
1022 }
1023 tmp = *v1;
1024 *v1 = *v2;
1025 *v2 = tmp;
1026 } else {
1027 *stack = error_value(E_SWAP3);
1028 return;
1029 }
1030 stack->v_type = V_NULL;
1031 stack->v_subtype = V_NOSUBTYPE;
1032 }
1033
1034
1035 S_FUNC void
1036 o_add(void)
1037 {
1038 VALUE *v1, *v2;
1039 VALUE tmp;
1040 VALUE w1, w2;
1041
1042 v1 = &stack[-1];
1043 v2 = &stack[0];
1044 if (v1->v_type == V_ADDR)
1045 v1 = v1->v_addr;
1046 if (v2->v_type == V_ADDR)
1047 v2 = v2->v_addr;
1048 if (v1->v_type == V_OCTET) {
1049 w1.v_type = V_NUM;
1050 w1.v_subtype = V_NOSUBTYPE;
1051 w1.v_num = itoq(*v1->v_octet);
1052 v1 = &w1;
1053 }
1054 if (v2->v_type == V_OCTET) {
1055 w2.v_type = V_NUM;
1056 w2.v_subtype = V_NOSUBTYPE;
1057 w2.v_num = itoq(*v2->v_octet);
1058 v2 = &w2;
1059 }
1060
1061 addvalue(v1, v2, &tmp);
1062 if (v1 == &w1)
1063 qfree(w1.v_num);
1064 if (v2 == &w2)
1065 qfree(w2.v_num);
1066 freevalue(stack--);
1067 freevalue(stack);
1068 *stack = tmp;
1069 }
1070
1071
1072 S_FUNC void
1073 o_sub(void)
1074 {
1075 VALUE *v1, *v2;
1076 VALUE tmp;
1077 VALUE w1, w2;
1078
1079 v1 = &stack[-1];
1080 v2 = &stack[0];
1081 if (v1->v_type == V_ADDR)
1082 v1 = v1->v_addr;
1083 if (v2->v_type == V_ADDR)
1084 v2 = v2->v_addr;
1085 if (v1->v_type == V_OCTET) {
1086 w1.v_type = V_NUM;
1087 w1.v_subtype = V_NOSUBTYPE;
1088 w1.v_num = itoq((unsigned char) *v1->v_octet);
1089 v1 = &w1;
1090 }
1091 if (v2->v_type == V_OCTET) {
1092 w2.v_type = V_NUM;
1093 w2.v_subtype = V_NOSUBTYPE;
1094 w2.v_num = itoq((unsigned char) *v2->v_octet);
1095 v2 = &w2;
1096 }
1097
1098 subvalue(v1, v2, &tmp);
1099 if (v1 == &w1)
1100 qfree(w1.v_num);
1101 if (v2 == &w2)
1102 qfree(w2.v_num);
1103 freevalue(stack--);
1104 freevalue(stack);
1105 *stack = tmp;
1106 }
1107
1108
1109 S_FUNC void
1110 o_mul(void)
1111 {
1112 VALUE *v1, *v2;
1113 VALUE tmp;
1114 VALUE w1, w2;
1115
1116 v1 = &stack[-1];
1117 v2 = &stack[0];
1118 if (v1->v_type == V_ADDR)
1119 v1 = v1->v_addr;
1120 if (v2->v_type == V_ADDR)
1121 v2 = v2->v_addr;
1122 if (v1->v_type == V_OCTET) {
1123 w1.v_type = V_NUM;
1124 w1.v_subtype = V_NOSUBTYPE;
1125 w1.v_num = itoq(*v1->v_octet);
1126 v1 = &w1;
1127 }
1128 if (v2->v_type == V_OCTET) {
1129 w2.v_type = V_NUM;
1130 w2.v_subtype = V_NOSUBTYPE;
1131 w2.v_num = itoq(*v2->v_octet);
1132 v2 = &w2;
1133 }
1134 mulvalue(v1, v2, &tmp);
1135 if (v1 == &w1)
1136 qfree(w1.v_num);
1137 if (v2 == &w2)
1138 qfree(w2.v_num);
1139 freevalue(stack--);
1140 freevalue(stack);
1141 *stack = tmp;
1142 }
1143
1144
1145 S_FUNC void
1146 o_power(void)
1147 {
1148 VALUE *v1, *v2;
1149 VALUE tmp;
1150
1151 v1 = &stack[-1];
1152 v2 = &stack[0];
1153 if (v1->v_type == V_ADDR)
1154 v1 = v1->v_addr;
1155 if (v2->v_type == V_ADDR)
1156 v2 = v2->v_addr;
1157 powvalue(v1, v2, &tmp);
1158 freevalue(stack--);
1159 freevalue(stack);
1160 *stack = tmp;
1161 }
1162
1163
1164 S_FUNC void
1165 o_div(void)
1166 {
1167 VALUE *v1, *v2;
1168 VALUE tmp;
1169 VALUE w1, w2;
1170
1171 v1 = &stack[-1];
1172 v2 = &stack[0];
1173 if (v1->v_type == V_ADDR)
1174 v1 = v1->v_addr;
1175 if (v2->v_type == V_ADDR)
1176 v2 = v2->v_addr;
1177 if (v1->v_type == V_OCTET) {
1178 w1.v_type = V_NUM;
1179 w1.v_subtype = V_NOSUBTYPE;
1180 w1.v_num = itoq(*v1->v_octet);
1181 v1 = &w1;
1182 }
1183 if (v2->v_type == V_OCTET) {
1184 w2.v_type = V_NUM;
1185 w2.v_subtype = V_NOSUBTYPE;
1186 w2.v_num = itoq(*v2->v_octet);
1187 v2 = &w2;
1188 }
1189 divvalue(v1, v2, &tmp);
1190 if (v1 == &w1)
1191 qfree(w1.v_num);
1192 if (v2 == &w2)
1193 qfree(w2.v_num);
1194 freevalue(stack--);
1195 freevalue(stack);
1196 *stack = tmp;
1197 }
1198
1199
1200 S_FUNC void
1201 o_quo(void)
1202 {
1203 VALUE *v1, *v2;
1204 VALUE tmp, null;
1205
1206 v1 = &stack[-1];
1207 v2 = &stack[0];
1208 if (v1->v_type == V_ADDR)
1209 v1 = v1->v_addr;
1210 if (v2->v_type == V_ADDR)
1211 v2 = v2->v_addr;
1212 null.v_type = V_NULL;
1213 null.v_subtype = V_NOSUBTYPE;
1214 quovalue(v1, v2, &null, &tmp);
1215 freevalue(stack--);
1216 freevalue(stack);
1217 *stack = tmp;
1218 }
1219
1220
1221 S_FUNC void
1222 o_mod(void)
1223 {
1224 VALUE *v1, *v2;
1225 VALUE tmp, null;
1226
1227 v1 = &stack[-1];
1228 v2 = &stack[0];
1229 if (v1->v_type == V_ADDR)
1230 v1 = v1->v_addr;
1231 if (v2->v_type == V_ADDR)
1232 v2 = v2->v_addr;
1233 null.v_type = V_NULL;
1234 null.v_subtype = V_NOSUBTYPE;
1235 modvalue(v1, v2, &null, &tmp);
1236 freevalue(stack--);
1237 freevalue(stack);
1238 *stack = tmp;
1239 }
1240
1241
1242 S_FUNC void
1243 o_and(void)
1244 {
1245 VALUE *v1, *v2;
1246 VALUE tmp;
1247
1248 v1 = &stack[-1];
1249 v2 = &stack[0];
1250 if (v1->v_type == V_ADDR)
1251 v1 = v1->v_addr;
1252 if (v2->v_type == V_ADDR)
1253 v2 = v2->v_addr;
1254
1255 andvalue(v1, v2, &tmp);
1256 freevalue(stack--);
1257 freevalue(stack);
1258 *stack = tmp;
1259 }
1260
1261
1262 S_FUNC void
1263 o_or(void)
1264 {
1265 VALUE *v1, *v2;
1266 VALUE tmp;
1267
1268 v1 = &stack[-1];
1269 v2 = &stack[0];
1270 if (v1->v_type == V_ADDR)
1271 v1 = v1->v_addr;
1272 if (v2->v_type == V_ADDR)
1273 v2 = v2->v_addr;
1274
1275 orvalue(v1, v2, &tmp);
1276 freevalue(stack--);
1277 freevalue(stack);
1278 *stack = tmp;
1279 }
1280
1281 S_FUNC void
1282 o_xor (void)
1283 {
1284 VALUE *v1, *v2;
1285 VALUE tmp;
1286
1287 v1 = &stack[-1];
1288 v2 = &stack[0];
1289
1290 if (v1->v_type == V_ADDR)
1291 v1 = v1->v_addr;
1292 if (v2->v_type == V_ADDR)
1293 v2 = v2->v_addr;
1294
1295 xorvalue(v1, v2, &tmp);
1296 freevalue(stack--);
1297 freevalue(stack);
1298 *stack = tmp;
1299 }
1300
1301
1302 S_FUNC void
1303 o_comp (void)
1304 {
1305 VALUE *vp;
1306 VALUE tmp;
1307
1308 vp = stack;
1309 if (vp->v_type == V_ADDR)
1310 vp = vp->v_addr;
1311 compvalue(vp, &tmp);
1312 freevalue(stack);
1313 *stack = tmp;
1314 }
1315
1316
1317 S_FUNC void
1318 o_not(void)
1319 {
1320 VALUE *vp;
1321 VALUE val;
1322 int r = 0;
1323
1324 vp = stack;
1325 if (vp->v_type == V_ADDR)
1326 vp = vp->v_addr;
1327 if (vp->v_type == V_OBJ) {
1328 val = objcall(OBJ_NOT, vp, NULL_VALUE, NULL_VALUE);
1329 freevalue(stack);
1330 *stack = val;
1331 return;
1332 }
1333 r = testvalue(vp);
1334 freevalue(stack);
1335 stack->v_num = (r ? qlink(&_qzero_) : qlink(&_qone_));
1336 stack->v_type = V_NUM;
1337 stack->v_subtype = V_NOSUBTYPE;
1338 }
1339
1340
1341 S_FUNC void
1342 o_plus (void)
1343 {
1344 VALUE *vp;
1345 VALUE tmp;
1346
1347 vp = stack;
1348 if (vp->v_type == V_ADDR)
1349 vp = vp->v_addr;
1350
1351 tmp.v_type = V_NULL;
1352 tmp.v_subtype = V_NOSUBTYPE;
1353 switch (vp->v_type) {
1354 case V_OBJ:
1355 tmp = objcall(OBJ_PLUS, vp, NULL_VALUE, NULL_VALUE);
1356 break;
1357 case V_LIST:
1358 addlistitems(vp->v_list, &tmp);
1359 break;
1360 default:
1361 return;
1362 }
1363 freevalue(stack);
1364 *stack = tmp;
1365 }
1366
1367
1368 S_FUNC void
1369 o_negate(void)
1370 {
1371 VALUE *vp;
1372 NUMBER *q;
1373 VALUE tmp;
1374
1375 vp = stack;
1376 if (vp->v_type == V_ADDR)
1377 vp = vp->v_addr;
1378 if (vp->v_type == V_NUM) {
1379 q = qneg(vp->v_num);
1380 if (stack->v_type == V_NUM)
1381 qfree(stack->v_num);
1382 stack->v_num = q;
1383 stack->v_type = V_NUM;
1384 stack->v_subtype = V_NOSUBTYPE;
1385 return;
1386 }
1387 negvalue(vp, &tmp);
1388 freevalue(stack);
1389 *stack = tmp;
1390 }
1391
1392
1393 S_FUNC void
1394 o_invert(void)
1395 {
1396 VALUE *vp;
1397 VALUE tmp;
1398
1399 vp = stack;
1400 if (vp->v_type == V_ADDR)
1401 vp = vp->v_addr;
1402
1403 invertvalue(vp, &tmp);
1404 freevalue(stack);
1405 *stack = tmp;
1406 }
1407
1408
1409 S_FUNC void
1410 o_scale(void)
1411 {
1412 VALUE *v1, *v2;
1413 VALUE tmp;
1414
1415 v1 = &stack[0];
1416 v2 = &stack[-1];
1417 if (v1->v_type == V_ADDR)
1418 v1 = v1->v_addr;
1419 if (v2->v_type == V_ADDR)
1420 v2 = v2->v_addr;
1421 scalevalue(v2, v1, &tmp);
1422 freevalue(stack--);
1423 freevalue(stack);
1424 *stack = tmp;
1425 }
1426
1427
1428 S_FUNC void
1429 o_int(void)
1430 {
1431 VALUE *vp;
1432 VALUE tmp;
1433
1434 vp = stack;
1435 if (vp->v_type == V_ADDR)
1436 vp = vp->v_addr;
1437 intvalue(vp, &tmp);
1438 freevalue(stack);
1439 *stack = tmp;
1440 }
1441
1442
1443 S_FUNC void
1444 o_frac(void)
1445 {
1446 VALUE *vp;
1447 VALUE tmp;
1448
1449 vp = stack;
1450 if (vp->v_type == V_ADDR)
1451 vp = vp->v_addr;
1452 fracvalue(vp, &tmp);
1453 freevalue(stack);
1454 *stack = tmp;
1455 }
1456
1457
1458 S_FUNC void
1459 o_abs(void)
1460 {
1461 VALUE *v1, *v2;
1462 NUMBER *q;
1463 VALUE tmp;
1464
1465 v1 = &stack[-1];
1466 v2 = &stack[0];
1467 if (v1->v_type == V_ADDR)
1468 v1 = v1->v_addr;
1469 if (v2->v_type == V_ADDR)
1470 v2 = v2->v_addr;
1471 if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM) ||
1472 !qispos(v2->v_num)) {
1473 absvalue(v1, v2, &tmp);
1474 freevalue(stack--);
1475 freevalue(stack);
1476 *stack = tmp;
1477 return;
1478 }
1479 if (stack->v_type == V_NUM)
1480 qfree(stack->v_num);
1481 stack--;
1482 if ((stack->v_type == V_NUM) && !qisneg(v1->v_num))
1483 return;
1484 q = qqabs(v1->v_num);
1485 if (stack->v_type == V_NUM)
1486 qfree(stack->v_num);
1487 stack->v_num = q;
1488 stack->v_type = V_NUM;
1489 stack->v_subtype = V_NOSUBTYPE;
1490 }
1491
1492
1493 S_FUNC void
1494 o_norm(void)
1495 {
1496 VALUE *vp;
1497 NUMBER *q;
1498 VALUE tmp;
1499
1500 vp = stack;
1501 if (vp->v_type == V_ADDR)
1502 vp = vp->v_addr;
1503 if (vp->v_type == V_NUM) {
1504 q = qsquare(vp->v_num);
1505 if (stack->v_type == V_NUM)
1506 qfree(stack->v_num);
1507 stack->v_num = q;
1508 stack->v_type = V_NUM;
1509 stack->v_subtype = V_NOSUBTYPE;
1510 return;
1511 }
1512 normvalue(vp, &tmp);
1513 freevalue(stack);
1514 *stack = tmp;
1515 }
1516
1517
1518 S_FUNC void
1519 o_square(void)
1520 {
1521 VALUE *vp;
1522 NUMBER *q;
1523 VALUE tmp;
1524
1525 vp = stack;
1526 if (vp->v_type == V_ADDR)
1527 vp = vp->v_addr;
1528 if (vp->v_type == V_NUM) {
1529 q = qsquare(vp->v_num);
1530 if (stack->v_type == V_NUM)
1531 qfree(stack->v_num);
1532 stack->v_num = q;
1533 stack->v_type = V_NUM;
1534 stack->v_subtype = V_NOSUBTYPE;
1535 return;
1536 }
1537 squarevalue(vp, &tmp);
1538 freevalue(stack);
1539 *stack = tmp;
1540 }
1541
1542
1543 S_FUNC void
1544 o_test(void)
1545 {
1546 VALUE *vp;
1547 int i;
1548
1549 vp = stack;
1550 if (vp->v_type == V_ADDR)
1551 vp = vp->v_addr;
1552 i = testvalue(vp);
1553 freevalue(stack);
1554 stack->v_type = V_NUM;
1555 stack->v_subtype = V_NOSUBTYPE;
1556 stack->v_num = i ? qlink(&_qone_) : qlink(&_qzero_);
1557 }
1558
1559
1560 S_FUNC void
1561 o_links(void)
1562 {
1563 VALUE *vp;
1564 long links;
1565 BOOL haveaddress;
1566
1567 vp = stack;
1568 haveaddress = (vp->v_type == V_ADDR);
1569 if (haveaddress)
1570 vp = vp->v_addr;
1571 switch (vp->v_type) {
1572 case V_NUM: links = vp->v_num->links; break;
1573 case V_COM: links = vp->v_com->links; break;
1574 case V_STR: links = vp->v_str->s_links; break;
1575 default:
1576 freevalue(stack);
1577 return;
1578 }
1579 if (links <= 0) {
1580 math_error("Non-positive links!!!");
1581 /*NOTREACHED*/
1582 }
1583 freevalue(stack);
1584 if (!haveaddress)
1585 links--;
1586 stack->v_type = V_NUM;
1587 stack->v_subtype = V_NOSUBTYPE;
1588 stack->v_num = itoq(links);
1589 }
1590
1591
1592 S_FUNC void
1593 o_bit (void)
1594 {
1595 VALUE *v1, *v2;
1596 long index;
1597 int r;
1598
1599 v1 = &stack[-1];
1600 v2 = &stack[0];
1601 if (v1->v_type == V_ADDR)
1602 v1 = v1->v_addr;
1603 if (v2->v_type == V_ADDR)
1604 v2 = v2->v_addr;
1605 if (v2->v_type != V_NUM || qisfrac(v2->v_num)) {
1606 freevalue(stack--);
1607 freevalue(stack);
1608 *stack = error_value(E_BIT1);
1609 return;
1610 }
1611 if (zge31b(v2->v_num->num)) {
1612 freevalue(stack--);
1613 freevalue(stack);
1614 *stack = error_value(E_BIT2);
1615 return;
1616 }
1617 index = qtoi(v2->v_num);
1618 switch (v1->v_type) {
1619 case V_NUM:
1620 r = qisset(v1->v_num, index);
1621 break;
1622 case V_STR:
1623 r = stringbit(v1->v_str, index);
1624 break;
1625 default:
1626 r = 2;
1627 }
1628 freevalue(stack--);
1629 freevalue(stack);
1630 if (r > 1) {
1631 *stack = error_value(E_BIT1);
1632 } else if (r < 0) {
1633 stack->v_type = V_NULL;
1634 } else {
1635 stack->v_type = V_NUM;
1636 stack->v_num = itoq(r);
1637 }
1638 stack->v_subtype = V_NOSUBTYPE;
1639 }
1640
1641 S_FUNC void
1642 o_highbit (void)
1643 {
1644 VALUE *vp;
1645 long index;
1646 unsigned int u;
1647
1648 vp = stack;
1649 if (vp->v_type == V_ADDR)
1650 vp = vp->v_addr;
1651 switch (vp->v_type) {
1652 case V_NUM:
1653 if (qiszero(vp->v_num)) {
1654 index = -1;
1655 break;
1656 }
1657 if (qisfrac(vp->v_num)) {
1658 index = -2;
1659 break;
1660 }
1661 index = zhighbit(vp->v_num->num);
1662 break;
1663 case V_STR:
1664 index = stringhighbit(vp->v_str);
1665 break;
1666 case V_OCTET:
1667 u = *vp->v_octet;
1668 for (index = -1; u; u >>= 1, ++index);
1669 break;
1670 default:
1671 index = -3;
1672 }
1673 freevalue(stack);
1674 switch (index) {
1675 case -3:
1676 *stack = error_value(E_HIGHBIT1);
1677 return;
1678 case -2:
1679 *stack = error_value(E_HIGHBIT2);
1680 return;
1681 default:
1682 stack->v_type = V_NUM;
1683 stack->v_subtype = V_NOSUBTYPE;
1684 stack->v_num = itoq(index);
1685 }
1686 }
1687
1688
1689 S_FUNC void
1690 o_lowbit (void)
1691 {
1692 VALUE *vp;
1693 long index;
1694 unsigned int u;
1695
1696 vp = stack;
1697 if (vp->v_type == V_ADDR)
1698 vp = vp->v_addr;
1699 switch (vp->v_type) {
1700 case V_NUM:
1701 if (qiszero(vp->v_num)) {
1702 index = -1;
1703 break;
1704 }
1705 if (qisfrac(vp->v_num)) {
1706 index = -2;
1707 break;
1708 }
1709 index = zlowbit(vp->v_num->num);
1710 break;
1711 case V_STR:
1712 index = stringlowbit(vp->v_str);
1713 break;
1714 case V_OCTET:
1715 u = *vp->v_octet;
1716 index = -1;
1717 if (u) do {
1718 ++index;
1719 u >>= 1;
1720 } while (!(u & 1));
1721 break;
1722 default:
1723 index = -3;
1724 }
1725 freevalue(stack);
1726 switch (index) {
1727 case -3:
1728 *stack = error_value(E_LOWBIT1);
1729 return;
1730 case -2:
1731 *stack = error_value(E_LOWBIT2);
1732 return;
1733 default:
1734 stack->v_type = V_NUM;
1735 stack->v_subtype = V_NOSUBTYPE;
1736 stack->v_num = itoq(index);
1737 }
1738 }
1739
1740
1741 S_FUNC void
1742 o_content (void)
1743 {
1744 VALUE *vp;
1745 VALUE tmp;
1746
1747 vp = stack;
1748 if (vp->v_type == V_ADDR)
1749 vp = vp->v_addr;
1750 contentvalue(vp, &tmp);
1751 freevalue(stack);
1752 *stack = tmp;
1753 }
1754
1755
1756 S_FUNC void
1757 o_hashop (void)
1758 {
1759 VALUE *v1, *v2;
1760 VALUE tmp;
1761
1762 v1 = &stack[-1];
1763 v2 = &stack[0];
1764 if (v1->v_type == V_ADDR)
1765 v1 = v1->v_addr;
1766 if (v2->v_type == V_ADDR)
1767 v2 = v2->v_addr;
1768 hashopvalue(v1, v2, &tmp);
1769 freevalue(stack--);
1770 freevalue(stack);
1771 *stack = tmp;
1772 }
1773
1774
1775 S_FUNC void
1776 o_backslash (void)
1777 {
1778 VALUE *vp;
1779 VALUE tmp;
1780
1781 vp = stack;
1782 if (vp->v_type == V_ADDR)
1783 vp = vp->v_addr;
1784 backslashvalue(vp, &tmp);
1785 freevalue(stack);
1786 *stack = tmp;
1787 }
1788
1789
1790 S_FUNC void
1791 o_setminus (void)
1792 {
1793 VALUE *v1, *v2;
1794 VALUE tmp;
1795
1796 v1 = &stack[-1];
1797 v2 = &stack[0];
1798 if (v1->v_type == V_ADDR)
1799 v1 = v1->v_addr;
1800 if (v2->v_type == V_ADDR)
1801 v2 = v2->v_addr;
1802 setminusvalue(v1, v2, &tmp);
1803 freevalue(stack--);
1804 freevalue(stack);
1805 *stack = tmp;
1806 }
1807
1808
1809 S_FUNC void
1810 o_istype(void)
1811 {
1812 VALUE *v1, *v2;
1813 int r;
1814
1815 v1 = &stack[-1];
1816 v2 = &stack[0];
1817 if (v1->v_type == V_ADDR)
1818 v1 = v1->v_addr;
1819 if (v2->v_type == V_ADDR)
1820 v2 = v2->v_addr;
1821 if ((v1->v_type != V_OBJ) || (v2->v_type != V_OBJ))
1822 r = (v1->v_type == v2->v_type);
1823 else
1824 r = (v1->v_obj->o_actions == v2->v_obj->o_actions);
1825 freevalue(stack--);
1826 freevalue(stack);
1827 stack->v_num = itoq((long) r);
1828 stack->v_type = V_NUM;
1829 stack->v_subtype = V_NOSUBTYPE;
1830 }
1831
1832
1833 S_FUNC void
1834 o_isint(void)
1835 {
1836 VALUE *vp;
1837 NUMBER *q;
1838
1839 vp = stack;
1840 if (vp->v_type == V_ADDR)
1841 vp = stack->v_addr;
1842 if (vp->v_type != V_NUM) {
1843 freevalue(stack);
1844 stack->v_num = qlink(&_qzero_);
1845 stack->v_type = V_NUM;
1846 stack->v_subtype = V_NOSUBTYPE;
1847 return;
1848 }
1849 if (qisint(vp->v_num))
1850 q = qlink(&_qone_);
1851 else
1852 q = qlink(&_qzero_);
1853 if (stack->v_type == V_NUM)
1854 qfree(stack->v_num);
1855 stack->v_num = q;
1856 stack->v_type = V_NUM;
1857 stack->v_subtype = V_NOSUBTYPE;
1858 }
1859
1860
1861 S_FUNC void
1862 o_isnum(void)
1863 {
1864 VALUE *vp;
1865
1866 vp = stack;
1867 if (vp->v_type == V_ADDR)
1868 vp = vp->v_addr;
1869 switch (vp->v_type) {
1870 case V_NUM:
1871 if (stack->v_type == V_NUM)
1872 qfree(stack->v_num);
1873 break;
1874 case V_COM:
1875 if (stack->v_type == V_COM)
1876 comfree(stack->v_com);
1877 break;
1878 default:
1879 freevalue(stack);
1880 stack->v_num = qlink(&_qzero_);
1881 stack->v_type = V_NUM;
1882 stack->v_subtype = V_NOSUBTYPE;
1883 return;
1884 }
1885 stack->v_num = qlink(&_qone_);
1886 stack->v_type = V_NUM;
1887 stack->v_subtype = V_NOSUBTYPE;
1888 }
1889
1890
1891 S_FUNC void
1892 o_ismat(void)
1893 {
1894 VALUE *vp;
1895
1896 vp = stack;
1897 if (vp->v_type == V_ADDR)
1898 vp = vp->v_addr;
1899 if (vp->v_type != V_MAT) {
1900 freevalue(stack);
1901 stack->v_num = qlink(&_qzero_);
1902 stack->v_type = V_NUM;
1903 stack->v_subtype = V_NOSUBTYPE;
1904 return;
1905 }
1906 freevalue(stack);
1907 stack->v_type = V_NUM;
1908 stack->v_subtype = V_NOSUBTYPE;
1909 stack->v_num = qlink(&_qone_);
1910 }
1911
1912
1913 S_FUNC void
1914 o_islist(void)
1915 {
1916 VALUE *vp;
1917 int r;
1918
1919 vp = stack;
1920 if (vp->v_type == V_ADDR)
1921 vp = vp->v_addr;
1922 r = (vp->v_type == V_LIST);
1923 freevalue(stack);
1924 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
1925 stack->v_type = V_NUM;
1926 stack->v_subtype = V_NOSUBTYPE;
1927 }
1928
1929
1930 S_FUNC void
1931 o_isobj(void)
1932 {
1933 VALUE *vp;
1934 int r;
1935
1936 vp = stack;
1937 if (vp->v_type == V_ADDR)
1938 vp = vp->v_addr;
1939 r = (vp->v_type == V_OBJ);
1940 freevalue(stack);
1941 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
1942 stack->v_type = V_NUM;
1943 stack->v_subtype = V_NOSUBTYPE;
1944 }
1945
1946
1947 S_FUNC void
1948 o_isstr(void)
1949 {
1950 VALUE *vp;
1951 int r;
1952
1953 vp = stack;
1954 if (vp->v_type == V_ADDR)
1955 vp = vp->v_addr;
1956 r = (vp->v_type == V_STR);
1957 freevalue(stack);
1958 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
1959 stack->v_type = V_NUM;
1960 stack->v_subtype = V_NOSUBTYPE;
1961 }
1962
1963
1964 S_FUNC void
1965 o_isfile(void)
1966 {
1967 VALUE *vp;
1968 int r;
1969
1970 vp = stack;
1971 if (vp->v_type == V_ADDR)
1972 vp = vp->v_addr;
1973 r = (vp->v_type == V_FILE);
1974 freevalue(stack);
1975 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
1976 stack->v_type = V_NUM;
1977 stack->v_subtype = V_NOSUBTYPE;
1978 }
1979
1980
1981 S_FUNC void
1982 o_isrand(void)
1983 {
1984 VALUE *vp;
1985 int r;
1986
1987 vp = stack;
1988 if (vp->v_type == V_ADDR)
1989 vp = vp->v_addr;
1990 r = (vp->v_type == V_RAND);
1991 freevalue(stack);
1992 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
1993 stack->v_type = V_NUM;
1994 stack->v_subtype = V_NOSUBTYPE;
1995 }
1996
1997
1998 S_FUNC void
1999 o_israndom(void)
2000 {
2001 VALUE *vp;
2002 int r;
2003
2004 vp = stack;
2005 if (vp->v_type == V_ADDR)
2006 vp = vp->v_addr;
2007 r = (vp->v_type == V_RANDOM);
2008 freevalue(stack);
2009 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
2010 stack->v_type = V_NUM;
2011 stack->v_subtype = V_NOSUBTYPE;
2012 }
2013
2014
2015 S_FUNC void
2016 o_isconfig(void)
2017 {
2018 VALUE *vp;
2019 int r;
2020
2021 vp = stack;
2022 if (vp->v_type == V_ADDR)
2023 vp = vp->v_addr;
2024 r = (vp->v_type == V_CONFIG);
2025 freevalue(stack);
2026 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
2027 stack->v_type = V_NUM;
2028 stack->v_subtype = V_NOSUBTYPE;
2029 }
2030
2031
2032 S_FUNC void
2033 o_ishash(void)
2034 {
2035 VALUE *vp;
2036 int r;
2037
2038 vp = stack;
2039 if (vp->v_type == V_ADDR)
2040 vp = vp->v_addr;
2041 r = (vp->v_type == V_HASH);
2042 if (r != 0)
2043 r = vp->v_hash->hashtype;
2044 freevalue(stack);
2045 stack->v_num = itoq((long) r);
2046 stack->v_type = V_NUM;
2047 stack->v_subtype = V_NOSUBTYPE;
2048 }
2049
2050
2051 S_FUNC void
2052 o_isassoc(void)
2053 {
2054 VALUE *vp;
2055 int r;
2056
2057 vp = stack;
2058 if (vp->v_type == V_ADDR)
2059 vp = vp->v_addr;
2060 r = (vp->v_type == V_ASSOC);
2061 freevalue(stack);
2062 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
2063 stack->v_type = V_NUM;
2064 stack->v_subtype = V_NOSUBTYPE;
2065 }
2066
2067
2068 S_FUNC void
2069 o_isblock(void)
2070 {
2071 VALUE *vp;
2072 long r;
2073
2074 vp = stack;
2075 if (vp->v_type == V_ADDR)
2076 vp = vp->v_addr;
2077 r = 0;
2078 if (vp->v_type == V_NBLOCK)
2079 r = 2;
2080 else if (vp->v_type == V_BLOCK)
2081 r = 1;
2082 freevalue(stack);
2083 stack->v_num = itoq(r);
2084 stack->v_type = V_NUM;
2085 stack->v_subtype = V_NOSUBTYPE;
2086 }
2087
2088
2089 S_FUNC void
2090 o_isoctet(void)
2091 {
2092 VALUE *vp;
2093 long r;
2094
2095 vp = stack;
2096 if (vp->v_type == V_ADDR)
2097 vp = vp->v_addr;
2098 r = (vp->v_type == V_OCTET);
2099 freevalue(stack);
2100 stack->v_num = itoq(r);
2101 stack->v_type = V_NUM;
2102 stack->v_subtype = V_NOSUBTYPE;
2103 }
2104
2105
2106 S_FUNC void
2107 o_isptr(void)
2108 {
2109 VALUE *vp;
2110 long r;
2111
2112 vp = stack;
2113 if (vp->v_type == V_ADDR)
2114 vp = vp->v_addr;
2115 r = 0;
2116 switch(vp->v_type) {
2117 case V_OPTR: r = 1; break;
2118 case V_VPTR: r = 2; break;
2119 case V_SPTR: r = 3; break;
2120 case V_NPTR: r = 4; break;
2121 }
2122 freevalue(stack);
2123 stack->v_num = itoq(r);
2124 stack->v_type = V_NUM;
2125 stack->v_subtype = V_NOSUBTYPE;
2126 }
2127
2128
2129 S_FUNC void
2130 o_isdefined(void)
2131 {
2132 VALUE *vp;
2133 long r;
2134 long index;
2135
2136 vp = stack;
2137 if (vp->v_type == V_ADDR)
2138 vp = vp->v_addr;
2139 if (vp->v_type != V_STR) {
2140 math_error("Non-string argument for isdefined");
2141 /*NOTREACHED*/
2142 }
2143 r = 0;
2144 index = getbuiltinfunc(vp->v_str->s_str);
2145 if (index >= 0) {
2146 r = 1;
2147 } else {
2148 index = getuserfunc(vp->v_str->s_str);
2149 if (index >= 0)
2150 r = 2;
2151 }
2152 freevalue(stack);
2153 stack->v_num = itoq(r);
2154 stack->v_type = V_NUM;
2155 stack->v_subtype = V_NOSUBTYPE;
2156 }
2157
2158
2159 S_FUNC void
2160 o_isobjtype(void)
2161 {
2162 VALUE *vp;
2163 long index;
2164
2165 vp = stack;
2166 if (vp->v_type == V_ADDR)
2167 vp = vp->v_addr;
2168 if (vp->v_type != V_STR) {
2169 math_error("Non-string argument for isobjtype");
2170 /*NOTREACHED*/
2171 }
2172 index = checkobject(vp->v_str->s_str);
2173 freevalue(stack);
2174 stack->v_num = itoq(index >= 0);
2175 stack->v_type = V_NUM;
2176 stack->v_subtype = V_NOSUBTYPE;
2177 }
2178
2179
2180 S_FUNC void
2181 o_issimple(void)
2182 {
2183 VALUE *vp;
2184 int r;
2185
2186 vp = stack;
2187 if (vp->v_type == V_ADDR)
2188 vp = vp->v_addr;
2189 r = 0;
2190 switch (vp->v_type) {
2191 case V_NULL:
2192 case V_NUM:
2193 case V_COM:
2194 case V_STR:
2195 r = 1;
2196 }
2197 freevalue(stack);
2198 stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
2199 stack->v_type = V_NUM;
2200 stack->v_subtype = V_NOSUBTYPE;
2201 }
2202
2203
2204 S_FUNC void
2205 o_isodd(void)
2206 {
2207 VALUE *vp;
2208
2209 vp = stack;
2210 if (vp->v_type == V_ADDR)
2211 vp = vp->v_addr;
2212 if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
2213 if (stack->v_type == V_NUM)
2214 qfree(stack->v_num);
2215 stack->v_num = qlink(&_qone_);
2216 stack->v_type = V_NUM;
2217 stack->v_subtype = V_NOSUBTYPE;
2218 return;
2219 }
2220 freevalue(stack);
2221 stack->v_num = qlink(&_qzero_);
2222 stack->v_type = V_NUM;
2223 stack->v_subtype = V_NOSUBTYPE;
2224 }
2225
2226
2227 S_FUNC void
2228 o_iseven(void)
2229 {
2230 VALUE *vp;
2231
2232 vp = stack;
2233 if (vp->v_type == V_ADDR)
2234 vp = vp->v_addr;
2235 if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
2236 if (stack->v_type == V_NUM)
2237 qfree(stack->v_num);
2238 stack->v_num = qlink(&_qone_);
2239 stack->v_type = V_NUM;
2240 stack->v_subtype = V_NOSUBTYPE;
2241 return;
2242 }
2243 freevalue(stack);
2244 stack->v_num = qlink(&_qzero_);
2245 stack->v_type = V_NUM;
2246 stack->v_subtype = V_NOSUBTYPE;
2247 }
2248
2249
2250 S_FUNC void
2251 o_isreal(void)
2252 {
2253 VALUE *vp;
2254
2255 vp = stack;
2256 if (vp->v_type == V_ADDR)
2257 vp = vp->v_addr;
2258 if (vp->v_type == V_NUM) {
2259 if (stack->v_type == V_NUM)
2260 qfree(stack->v_num);
2261 stack->v_num = qlink(&_qone_);
2262 stack->v_type = V_NUM;
2263 stack->v_subtype = V_NOSUBTYPE;
2264 return;
2265 }
2266 freevalue(stack);
2267 stack->v_num = qlink(&_qzero_);
2268 stack->v_type = V_NUM;
2269 stack->v_subtype = V_NOSUBTYPE;
2270 }
2271
2272
2273 S_FUNC void
2274 o_isnull(void)
2275 {
2276 VALUE *vp;
2277
2278 vp = stack;
2279 if (vp->v_type == V_ADDR)
2280 vp = vp->v_addr;
2281 if (vp->v_type != V_NULL) {
2282 freevalue(stack);
2283 stack->v_num = qlink(&_qzero_);
2284 stack->v_type = V_NUM;
2285 stack->v_subtype = V_NOSUBTYPE;
2286 return;
2287 }
2288 freevalue(stack);
2289 stack->v_num = qlink(&_qone_);
2290 stack->v_type = V_NUM;
2291 stack->v_subtype = V_NOSUBTYPE;
2292 }
2293
2294
2295 S_FUNC void
2296 o_re(void)
2297 {
2298 VALUE *vp;
2299 NUMBER *q;
2300
2301 vp = stack;
2302 if (vp->v_type == V_ADDR)
2303 vp = vp->v_addr;
2304 if (vp->v_type == V_NUM) {
2305 if (stack->v_type == V_ADDR) {
2306 stack->v_num = qlink(vp->v_num);
2307 stack->v_type = V_NUM;
2308 stack->v_subtype = V_NOSUBTYPE;
2309 }
2310 return;
2311 }
2312 if (vp->v_type != V_COM) {
2313 math_error("Taking real part of non-number");
2314 /*NOTREACHED*/
2315 }
2316 q = qlink(vp->v_com->real);
2317 if (stack->v_type == V_COM)
2318 comfree(stack->v_com);
2319 stack->v_num = q;
2320 stack->v_type = V_NUM;
2321 stack->v_subtype = V_NOSUBTYPE;
2322 }
2323
2324
2325 S_FUNC void
2326 o_im(void)
2327 {
2328 VALUE *vp;
2329 NUMBER *q;
2330
2331 vp = stack;
2332 if (vp->v_type == V_ADDR)
2333 vp = vp->v_addr;
2334 if (vp->v_type == V_NUM) {
2335 if (stack->v_type == V_NUM)
2336 qfree(stack->v_num);
2337 stack->v_num = qlink(&_qzero_);
2338 stack->v_type = V_NUM;
2339 stack->v_subtype = V_NOSUBTYPE;
2340 return;
2341 }
2342 if (vp->v_type != V_COM) {
2343 math_error("Taking imaginary part of non-number");
2344 /*NOTREACHED*/
2345 }
2346 q = qlink(vp->v_com->imag);
2347 if (stack->v_type == V_COM)
2348 comfree(stack->v_com);
2349 stack->v_num = q;
2350 stack->v_type = V_NUM;
2351 stack->v_subtype = V_NOSUBTYPE;
2352 }
2353
2354
2355 S_FUNC void
2356 o_conjugate(void)
2357 {
2358 VALUE *vp;
2359 VALUE tmp;
2360
2361 vp = stack;
2362 if (vp->v_type == V_ADDR)
2363 vp = vp->v_addr;
2364 if (vp->v_type == V_NUM) {
2365 if (stack->v_type == V_ADDR) {
2366 stack->v_num = qlink(vp->v_num);
2367 stack->v_type = V_NUM;
2368 stack->v_subtype = V_NOSUBTYPE;
2369 }
2370 return;
2371 }
2372 conjvalue(vp, &tmp);
2373 freevalue(stack);
2374 *stack = tmp;
2375 }
2376
2377
2378 S_FUNC void
2379 o_fiaddr(void)
2380 {
2381 register MATRIX *m; /* current matrix element */
2382 LIST *lp; /* list header */
2383 ASSOC *ap; /* association header */
2384 VALUE *vp; /* stack value */
2385 long index; /* index value as an integer */
2386 VALUE *res;
2387
2388 vp = stack;
2389 res = NULL;
2390 if (vp->v_type == V_ADDR)
2391 vp = vp->v_addr;
2392 if (vp->v_type != V_NUM || qisfrac(vp->v_num)) {
2393 math_error("Fast indexing by non-integer");
2394 /*NOTREACHED*/
2395 }
2396 index = qtoi(vp->v_num);
2397 if (zge31b(vp->v_num->num) || (index < 0)) {
2398 math_error("Index out of range for fast indexing");
2399 /*NOTREACHED*/
2400 }
2401 if (stack->v_type == V_NUM)
2402 qfree(stack->v_num);
2403 stack--;
2404 vp = stack;
2405 if (vp->v_type != V_ADDR) {
2406 math_error("Non-pointer for fast indexing");
2407 /*NOTREACHED*/
2408 }
2409 vp = vp->v_addr;
2410 switch (vp->v_type) {
2411 case V_OBJ:
2412 if (index >= vp->v_obj->o_actions->oa_count) {
2413 math_error("Index out of bounds for object");
2414 /*NOTREACHED*/
2415 }
2416 res = vp->v_obj->o_table + index;
2417 break;
2418 case V_MAT:
2419 m = vp->v_mat;
2420 if (index >= m->m_size) {
2421 math_error("Index out of bounds for matrix");
2422 /*NOTREACHED*/
2423 }
2424 res = m->m_table + index;
2425 break;
2426 case V_LIST:
2427 lp = vp->v_list;
2428 res = listfindex(lp, index);
2429 if (res == NULL) {
2430 math_error("Index out of bounds for list");
2431 /*NOTREACHED*/
2432 }
2433 break;
2434 case V_ASSOC:
2435 ap = vp->v_assoc;
2436 res = assocfindex(ap, index);
2437 if (res == NULL) {
2438 math_error("Index out of bounds for association");
2439 /*NOTREACHED*/
2440 }
2441 break;
2442 default:
2443 math_error("Bad variable type for fast indexing");
2444 /*NOTREACHED*/
2445 }
2446 stack->v_addr = res;
2447 }
2448
2449
2450 S_FUNC void
2451 o_fivalue(void)
2452 {
2453 (void) o_fiaddr();
2454 (void) o_getvalue();
2455 }
2456
2457
2458 S_FUNC void
2459 o_sgn(void)
2460 {
2461 VALUE *vp;
2462 NUMBER *q;
2463 VALUE tmp;
2464
2465 vp = stack;
2466 if (vp->v_type == V_ADDR)
2467 vp = vp->v_addr;
2468 if (vp->v_type == V_NUM) {
2469 q = qsign(vp->v_num);
2470 if (stack->v_type == V_NUM)
2471 qfree(vp->v_num);
2472 stack->v_num = q;
2473 stack->v_type = V_NUM;
2474 stack->v_subtype = V_NOSUBTYPE;
2475 return;
2476 }
2477 sgnvalue(vp, &tmp);
2478 freevalue(stack);
2479 *stack = tmp;
2480 }
2481
2482
2483 S_FUNC void
2484 o_numerator(void)
2485 {
2486 VALUE *vp;
2487 NUMBER *q;
2488
2489 vp = stack;
2490 if (vp->v_type == V_ADDR)
2491 vp = vp->v_addr;
2492 if (vp->v_type != V_NUM) {
2493 math_error("Numerator of non-number");
2494 /*NOTREACHED*/
2495 }
2496 if ((stack->v_type == V_NUM) && qisint(vp->v_num))
2497 return;
2498 q = qnum(vp->v_num);
2499 if (stack->v_type == V_NUM)
2500 qfree(stack->v_num);
2501 stack->v_num = q;
2502 stack->v_type = V_NUM;
2503 stack->v_subtype = V_NOSUBTYPE;
2504 }
2505
2506
2507 S_FUNC void
2508 o_denominator(void)
2509 {
2510 VALUE *vp;
2511 NUMBER *q;
2512
2513 vp = stack;
2514 if (vp->v_type == V_ADDR)
2515 vp = vp->v_addr;
2516 if (vp->v_type != V_NUM) {
2517 math_error("Denominator of non-number");
2518 /*NOTREACHED*/
2519 }
2520 q = qden(vp->v_num);
2521 if (stack->v_type == V_NUM)
2522 qfree(stack->v_num);
2523 stack->v_num = q;
2524 stack->v_type = V_NUM;
2525 stack->v_subtype = V_NOSUBTYPE;
2526 }
2527
2528
2529 S_FUNC void
2530 o_duplicate(void)
2531 {
2532 VALUE *vp;
2533
2534 vp = stack++;
2535 *stack = *vp;
2536 }
2537
2538
2539 S_FUNC void
2540 o_dupvalue(void)
2541 {
2542 if (stack->v_type == V_ADDR)
2543 copyvalue(stack->v_addr, stack + 1);
2544 else
2545 copyvalue(stack, stack + 1);
2546 stack++;
2547 }
2548
2549
2550 S_FUNC void
2551 o_pop(void)
2552 {
2553 freevalue(stack--);
2554 }
2555
2556
2557 S_FUNC void
2558 o_return(void)
2559 {
2560 }
2561
2562
2563 /*ARGSUSED*/
2564 S_FUNC void
2565 o_jumpz(FUNC UNUSED *fp, BOOL *dojump)
2566 {
2567 VALUE *vp;
2568 int i; /* result of comparison */
2569
2570 vp = stack;
2571 if (vp->v_type == V_ADDR)
2572 vp = vp->v_addr;
2573 if (vp->v_type == V_NUM) {
2574 i = !qiszero(vp->v_num);
2575 if (stack->v_type == V_NUM)
2576 qfree(stack->v_num);
2577 } else {
2578 i = testvalue(vp);
2579 freevalue(stack);
2580 }
2581 stack--;
2582 if (!i)
2583 *dojump = TRUE;
2584 }
2585
2586
2587 /*ARGSUSED*/
2588 S_FUNC void
2589 o_jumpnz(FUNC UNUSED *fp, BOOL *dojump)
2590 {
2591 VALUE *vp;
2592 int i; /* result of comparison */
2593
2594 vp = stack;
2595 if (vp->v_type == V_ADDR)
2596 vp = vp->v_addr;
2597 if (vp->v_type == V_NUM) {
2598 i = !qiszero(vp->v_num);
2599 if (stack->v_type == V_NUM)
2600 qfree(stack->v_num);
2601 } else {
2602 i = testvalue(vp);
2603 freevalue(stack);
2604 }
2605 stack--;
2606 if (i)
2607 *dojump = TRUE;
2608 }
2609
2610
2611 /*
2612 * jumpnn invokes a jump if top value points to a null value
2613 */
2614 /*ARGSUSED*/
2615 S_FUNC void
2616 o_jumpnn(FUNC UNUSED *fp, BOOL *dojump)
2617 {
2618 if (stack->v_addr->v_type) {
2619 *dojump = TRUE;
2620 stack--;
2621 }
2622 }
2623
2624
2625 /*ARGSUSED*/
2626 S_FUNC void
2627 o_condorjump(FUNC UNUSED *fp, BOOL *dojump)
2628 {
2629 VALUE *vp;
2630
2631 vp = stack;
2632 if (vp->v_type == V_ADDR)
2633 vp = vp->v_addr;
2634 if (vp->v_type == V_NUM) {
2635 if (!qiszero(vp->v_num)) {
2636 *dojump = TRUE;
2637 return;
2638 }
2639 if (stack->v_type == V_NUM)
2640 qfree(stack->v_num);
2641 stack--;
2642 return;
2643 }
2644 if (testvalue(vp))
2645 *dojump = TRUE;
2646 else
2647 freevalue(stack--);
2648 }
2649
2650
2651 /*ARGSUSED*/
2652 S_FUNC void
2653 o_condandjump(FUNC UNUSED *fp, BOOL *dojump)
2654 {
2655 VALUE *vp;
2656
2657 vp = stack;
2658 if (vp->v_type == V_ADDR)
2659 vp = vp->v_addr;
2660 if (vp->v_type == V_NUM) {
2661 if (qiszero(vp->v_num)) {
2662 *dojump = TRUE;
2663 return;
2664 }
2665 if (stack->v_type == V_NUM)
2666 qfree(stack->v_num);
2667 stack--;
2668 return;
2669 }
2670 if (!testvalue(vp))
2671 *dojump = TRUE;
2672 else
2673 freevalue(stack--);
2674 }
2675
2676
2677 /*
2678 * Compare the top two values on the stack for equality and jump if they are
2679 * different, popping off the top element, leaving the first one on the stack.
2680 * If they are equal, pop both values and do not jump.
2681 */
2682 /*ARGSUSED*/
2683 S_FUNC void
2684 o_casejump(FUNC UNUSED *fp, BOOL *dojump)
2685 {
2686 VALUE *v1, *v2;
2687 int r;
2688
2689 v1 = &stack[-1];
2690 v2 = &stack[0];
2691 if (v1->v_type == V_ADDR)
2692 v1 = v1->v_addr;
2693 if (v2->v_type == V_ADDR)
2694 v2 = v2->v_addr;
2695 r = comparevalue(v1, v2);
2696 freevalue(stack--);
2697 if (r)
2698 *dojump = TRUE;
2699 else
2700 freevalue(stack--);
2701 }
2702
2703
2704 /*ARGSUSED*/
2705 S_FUNC void
2706 o_jump(FUNC UNUSED *fp, BOOL *dojump)
2707 {
2708 *dojump = TRUE;
2709 }
2710
2711
2712 S_FUNC void
2713 o_usercall(FUNC *fp, long index, long argcount)
2714 {
2715 fp = findfunc(index);
2716 if (fp == NULL) {
2717 math_error("Function \"%s\" is undefined", namefunc(index));
2718 /*NOTREACHED*/
2719 }
2720 calculate(fp, (int) argcount);
2721 }
2722
2723
2724 /*ARGSUSED*/
2725 S_FUNC void
2726 o_call(FUNC UNUSED *fp, long index, long argcount)
2727 {
2728 VALUE result;
2729
2730 result = builtinfunc(index, (int) argcount, stack);
2731 while (--argcount >= 0)
2732 freevalue(stack--);
2733 stack++;
2734 *stack = result;
2735 }
2736
2737
2738 S_FUNC void
2739 o_getvalue(void)
2740 {
2741 if (stack->v_type == V_ADDR)
2742 copyvalue(stack->v_addr, stack);
2743 }
2744
2745
2746 S_FUNC void
2747 o_cmp(void)
2748 {
2749 VALUE *v1, *v2;
2750 VALUE tmp;
2751
2752 v1 = &stack[-1];
2753 v2 = &stack[0];
2754 if (v1->v_type == V_ADDR)
2755 v1 = v1->v_addr;
2756 if (v2->v_type == V_ADDR)
2757 v2 = v2->v_addr;
2758 relvalue(v1, v2, &tmp);
2759 freevalue(stack--);
2760 freevalue(stack);
2761 *stack = tmp;
2762 }
2763
2764
2765 S_FUNC void
2766 o_eq(void)
2767 {
2768 VALUE *v1, *v2;
2769 int r;
2770
2771 v1 = &stack[-1];
2772 v2 = &stack[0];
2773 if (v1->v_type == V_ADDR)
2774 v1 = v1->v_addr;
2775 if (v2->v_type == V_ADDR)
2776 v2 = v2->v_addr;
2777 r = comparevalue(v1, v2);
2778 freevalue(stack--);
2779 freevalue(stack);
2780 stack->v_num = itoq((long) (r == 0));
2781 stack->v_type = V_NUM;
2782 stack->v_subtype = V_NOSUBTYPE;
2783 }
2784
2785
2786 S_FUNC void
2787 o_ne(void)
2788 {
2789 VALUE *v1, *v2;
2790 int r;
2791
2792 v1 = &stack[-1];
2793 v2 = &stack[0];
2794 if (v1->v_type == V_ADDR)
2795 v1 = v1->v_addr;
2796 if (v2->v_type == V_ADDR)
2797 v2 = v2->v_addr;
2798 r = comparevalue(v1, v2);
2799 freevalue(stack--);
2800 freevalue(stack);
2801 stack->v_num = itoq((long) (r != 0));
2802 stack->v_type = V_NUM;
2803 stack->v_subtype = V_NOSUBTYPE;
2804 }
2805
2806
2807 S_FUNC void
2808 o_le(void)
2809 {
2810 VALUE *v1, *v2;
2811 VALUE tmp;
2812
2813 v1 = &stack[-1];
2814 v2 = &stack[0];
2815 if (v1->v_type == V_ADDR)
2816 v1 = v1->v_addr;
2817 if (v2->v_type == V_ADDR)
2818 v2 = v2->v_addr;
2819 relvalue(v1, v2, &tmp);
2820 freevalue(stack--);
2821 freevalue(stack);
2822
2823 stack->v_type = V_NUM;
2824 stack->v_subtype = V_NOSUBTYPE;
2825 if (tmp.v_type == V_NUM) {
2826 stack->v_num = !qispos(tmp.v_num) ? qlink(&_qone_):
2827 qlink(&_qzero_);
2828 } else if (tmp.v_type == V_COM) {
2829 stack->v_num = qlink(&_qzero_);
2830 } else {
2831 stack->v_type = V_NULL;
2832 }
2833 freevalue(&tmp);
2834 }
2835
2836
2837 S_FUNC void
2838 o_ge(void)
2839 {
2840 VALUE *v1, *v2;
2841 VALUE tmp;
2842
2843 v1 = &stack[-1];
2844 v2 = &stack[0];
2845 if (v1->v_type == V_ADDR)
2846 v1 = v1->v_addr;
2847 if (v2->v_type == V_ADDR)
2848 v2 = v2->v_addr;
2849 relvalue(v1, v2, &tmp);
2850 freevalue(stack--);
2851 freevalue(stack);
2852 stack->v_type = V_NUM;
2853 stack->v_subtype = V_NOSUBTYPE;
2854 if (tmp.v_type == V_NUM) {
2855 stack->v_num = !qisneg(tmp.v_num) ? qlink(&_qone_):
2856 qlink(&_qzero_);
2857 } else if (tmp.v_type == V_COM) {
2858 stack->v_num = qlink(&_qzero_);
2859 } else {
2860 stack->v_type = V_NULL;
2861 }
2862 freevalue(&tmp);
2863 }
2864
2865
2866 S_FUNC void
2867 o_lt(void)
2868 {
2869 VALUE *v1, *v2;
2870 VALUE tmp;
2871
2872 v1 = &stack[-1];
2873 v2 = &stack[0];
2874 if (v1->v_type == V_ADDR)
2875 v1 = v1->v_addr;
2876 if (v2->v_type == V_ADDR)
2877 v2 = v2->v_addr;
2878 relvalue(v1, v2, &tmp);
2879 freevalue(stack--);
2880 freevalue(stack);
2881 stack->v_type = V_NUM;
2882 stack->v_subtype = V_NOSUBTYPE;
2883 if (tmp.v_type == V_NUM) {
2884 stack->v_num = qisneg(tmp.v_num) ? qlink(&_qone_):
2885 qlink(&_qzero_);
2886 } else if (tmp.v_type == V_COM) {
2887 stack->v_num = qlink(&_qzero_);
2888 } else {
2889 stack->v_type = V_NULL;
2890 }
2891 freevalue(&tmp);
2892 }
2893
2894
2895 S_FUNC void
2896 o_gt(void)
2897 {
2898 VALUE *v1, *v2;
2899 VALUE tmp;
2900
2901 v1 = &stack[-1];
2902 v2 = &stack[0];
2903 if (v1->v_type == V_ADDR)
2904 v1 = v1->v_addr;
2905 if (v2->v_type == V_ADDR)
2906 v2 = v2->v_addr;
2907 relvalue(v1, v2, &tmp);
2908 freevalue(stack--);
2909 freevalue(stack);
2910 stack->v_type = V_NUM;
2911 stack->v_subtype = V_NOSUBTYPE;
2912 if (tmp.v_type == V_NUM) {
2913 stack->v_num = qispos(tmp.v_num) ? qlink(&_qone_):
2914 qlink(&_qzero_);
2915 } else if (tmp.v_type == V_COM) {
2916 stack->v_num = qlink(&_qzero_);
2917 } else {
2918 stack->v_type = V_NULL;
2919 }
2920 freevalue(&tmp);
2921 }
2922
2923
2924 S_FUNC void
2925 o_preinc(void)
2926 {
2927 VALUE *vp, tmp;
2928
2929 if (stack->v_type == V_OCTET) {
2930 if (stack->v_subtype & (V_NONEWVALUE | V_NOCOPYTO)) {
2931 *stack = error_value(E_PREINC1);
2932 return;
2933 }
2934 stack->v_octet[0] = stack->v_octet[0] + 1;
2935 return;
2936 }
2937 if (stack->v_type != V_ADDR) {
2938 freevalue(stack);
2939 *stack = error_value(E_PREINC2);
2940 return;
2941 }
2942 vp = stack->v_addr;
2943
2944 if (vp->v_subtype & (V_NONEWVALUE | V_NOASSIGNTO)) {
2945 *stack = error_value(E_PREINC3);
2946 return;
2947 }
2948 incvalue(vp, &tmp);
2949 freevalue(vp);
2950 *vp = tmp;
2951 }
2952
2953
2954 S_FUNC void
2955 o_predec(void)
2956 {
2957 VALUE *vp, tmp;
2958
2959 if (stack->v_type == V_OCTET) {
2960 if (stack->v_subtype & (V_NONEWVALUE | V_NOCOPYTO)) {
2961 *stack = error_value(E_PREDEC1);
2962 return;
2963 }
2964 --(*stack->v_octet);
2965 return;
2966 }
2967 if (stack->v_type != V_ADDR) {
2968 freevalue(stack);
2969 *stack = error_value(E_PREDEC2);
2970 return;
2971 }
2972 vp = stack->v_addr;
2973 if (vp->v_subtype & (V_NONEWVALUE | V_NOASSIGNTO)) {
2974 *stack = error_value(E_PREDEC3);
2975 return;
2976 }
2977 decvalue(vp, &tmp);
2978 freevalue(vp);
2979 *vp = tmp;
2980 }
2981
2982
2983 S_FUNC void
2984 o_postinc(void)
2985 {
2986 VALUE *vp;
2987 VALUE tmp;
2988
2989 if (stack->v_type == V_OCTET) {
2990 if (stack->v_subtype & (V_NONEWVALUE | V_NOCOPYTO)) {
2991 *stack++ = error_value(E_POSTINC1);
2992 stack->v_type = V_NULL;
2993 return;
2994 }
2995 stack[1] = stack[0];
2996 stack->v_type = V_NUM;
2997 stack->v_subtype = V_NOSUBTYPE;
2998 stack->v_num = itoq((long) stack->v_octet[0]);
2999 stack++;
3000 stack->v_octet[0]++;
3001 return;
3002 }
3003 if (stack->v_type != V_ADDR) {
3004 stack[1] = *stack;
3005 *stack = error_value(E_POSTINC2);
3006 stack++;
3007 return;
3008 }
3009 vp = stack->v_addr;
3010 if (vp->v_subtype & V_NONEWVALUE) {
3011 stack[1] = *stack;
3012 *stack = error_value(E_POSTINC3);
3013 stack++;
3014 return;
3015 }
3016 copyvalue(vp, stack++);
3017 incvalue(vp, &tmp);
3018 freevalue(vp);
3019 *vp = tmp;
3020 stack->v_type = V_ADDR;
3021 stack->v_subtype = V_NOSUBTYPE;
3022 stack->v_addr = vp;
3023 }
3024
3025
3026 S_FUNC void
3027 o_postdec(void)
3028 {
3029 VALUE *vp;
3030 VALUE tmp;
3031
3032 if (stack->v_type == V_OCTET) {
3033 if (stack->v_subtype & (V_NONEWVALUE | V_NOCOPYTO)) {
3034 *stack++ = error_value(E_POSTDEC1);
3035 stack->v_type = V_NULL;
3036 return;
3037 }
3038 stack[1] = stack[0];
3039 stack->v_type = V_NUM;
3040 stack->v_num = itoq((long) stack->v_octet[0]);
3041 stack++;
3042 stack->v_octet[0]--;
3043 return;
3044 }
3045 if (stack->v_type != V_ADDR) {
3046 stack[1] = *stack;
3047 *stack = error_value(E_POSTDEC2);
3048 stack++;
3049 return;
3050 }
3051 vp = stack->v_addr;
3052 if (vp->v_subtype & (V_NONEWVALUE | V_NOASSIGNTO)) {
3053 stack[1] = *stack;
3054 *stack = error_value(E_POSTDEC3);
3055 stack++;
3056 return;
3057 }
3058 copyvalue(vp, stack++);
3059 decvalue(vp, &tmp);
3060 freevalue(vp);
3061 *vp = tmp;
3062 stack->v_type = V_ADDR;
3063 stack->v_subtype = V_NOSUBTYPE;
3064 stack->v_addr = vp;
3065 }
3066
3067
3068 S_FUNC void
3069 o_leftshift(void)
3070 {
3071 VALUE *v1, *v2;
3072 VALUE tmp;
3073
3074 v1 = &stack[-1];
3075 v2 = &stack[0];
3076 if (v1->v_type == V_ADDR)
3077 v1 = v1->v_addr;
3078 if (v2->v_type == V_ADDR)
3079 v2 = v2->v_addr;
3080 shiftvalue(v1, v2, FALSE, &tmp);
3081 freevalue(stack--);
3082 freevalue(stack);
3083 *stack = tmp;
3084 }
3085
3086
3087 S_FUNC void
3088 o_rightshift(void)
3089 {
3090 VALUE *v1, *v2;
3091 VALUE tmp;
3092
3093 v1 = &stack[-1];
3094 v2 = &stack[0];
3095 if (v1->v_type == V_ADDR)
3096 v1 = v1->v_addr;
3097 if (v2->v_type == V_ADDR)
3098 v2 = v2->v_addr;
3099 shiftvalue(v1, v2, TRUE, &tmp);
3100 freevalue(stack--);
3101 freevalue(stack);
3102 *stack = tmp;
3103 }
3104
3105
3106 /*ARGSUSED*/
3107 S_FUNC void
3108 o_debug(FUNC UNUSED *fp, long line)
3109 {
3110 funcline = line;
3111 if (abortlevel >= ABORT_STATEMENT) {
3112 math_error("Calculation aborted at statement boundary");
3113 /*NOTREACHED*/
3114 }
3115 }
3116
3117
3118 S_FUNC void
3119 o_printresult(void)
3120 {
3121 VALUE *vp;
3122
3123 vp = stack;
3124
3125 /* firewall */
3126 if (vp == NULL)
3127 return;
3128
3129 if (vp->v_type == V_ADDR)
3130 vp = vp->v_addr;
3131
3132 /* firewall */
3133 if (vp == NULL)
3134 return;
3135
3136 if (vp->v_type != V_NULL) {
3137 if (conf->tab_ok)
3138 math_chr('\t');
3139 printvalue(vp, PRINT_UNAMBIG);
3140 math_chr('\n');
3141 math_flush();
3142 }
3143 freevalue(stack--);
3144 }
3145
3146
3147 /*ARGSUSED*/
3148 S_FUNC void
3149 o_print(FUNC UNUSED *fp, long flags)
3150 {
3151 VALUE *vp;
3152
3153 vp = stack;
3154 if (vp->v_type == V_ADDR)
3155 vp = vp->v_addr;
3156 printvalue(vp, (int) flags);
3157 freevalue(stack--);
3158 if (conf->traceflags & TRACE_OPCODES)
3159 printf("\n");
3160 math_flush();
3161 }
3162
3163
3164 S_FUNC void
3165 o_printeol(void)
3166 {
3167 math_chr('\n');
3168 math_flush();
3169 }
3170
3171
3172 S_FUNC void
3173 o_printspace(void)
3174 {
3175 math_chr(' ');
3176 if (conf->traceflags & TRACE_OPCODES)
3177 printf("\n");
3178 }
3179
3180
3181 /*ARGSUSED*/
3182 S_FUNC void
3183 o_printstring(FUNC UNUSED *fp, long index)
3184 {
3185 STRING *s;
3186 char *cp;
3187
3188 s = findstring(index);
3189 cp = s->s_str;
3190 math_str(cp);
3191 if (conf->traceflags & TRACE_OPCODES)
3192 printf("\n");
3193 math_flush();
3194 }
3195
3196
3197 S_FUNC void
3198 o_zero(void)
3199 {
3200 stack++;
3201 stack->v_type = V_NUM;
3202 stack->v_subtype = V_NOSUBTYPE;
3203 stack->v_num = qlink(&_qzero_);
3204 }
3205
3206
3207 S_FUNC void
3208 o_one(void)
3209 {
3210 stack++;
3211 stack->v_type = V_NUM;
3212 stack->v_subtype = V_NOSUBTYPE;
3213 stack->v_num = qlink(&_qone_);
3214 }
3215
3216
3217 S_FUNC void
3218 o_save(FUNC *fp)
3219 {
3220 VALUE *vp;
3221
3222 if (saveval || fp->f_name[1] == '*') {
3223 vp = stack;
3224 if (vp->v_type == V_ADDR)
3225 vp = vp->v_addr;
3226 freevalue(&fp->f_savedvalue);
3227 copyvalue(vp, &fp->f_savedvalue);
3228 }
3229 }
3230
3231
3232 S_FUNC void
3233 o_oldvalue(void)
3234 {
3235 ++stack;
3236 stack->v_type = V_ADDR;
3237 stack->v_addr = &oldvalue;
3238 }
3239
3240
3241 void
3242 o_setsaveval(void)
3243 {
3244 VALUE *vp;
3245
3246 vp = stack;
3247 if (vp->v_type == V_ADDR)
3248 vp = vp->v_addr;
3249 saveval = testvalue(vp);
3250 freevalue(stack);
3251 }
3252
3253
3254 S_FUNC void
3255 o_quit(FUNC *fp, long index)
3256 {
3257 STRING *s;
3258 char *cp;
3259
3260 cp = NULL;
3261 if (index >= 0) {
3262 s = findstring(index);
3263 cp = s->s_str;
3264 }
3265 if (inputisterminal() && !strcmp(fp->f_name, "*")) {
3266 if (cp)
3267 printf("%s\n", cp);
3268 hist_term();
3269 while (stack > stackarray) {
3270 freevalue(stack--);
3271 }
3272 freevalue(stackarray);
3273 run_state = RUN_EXIT;
3274 if (calc_use_scanerr_jmpbuf != 0) {
3275 longjmp(calc_scanerr_jmpbuf, 50);
3276 } else {
3277 fprintf(stderr,
3278 "calc_scanerr_jmpbuf not setup, exiting code 50\n");
3279 libcalc_call_me_last();
3280 exit(50);
3281 }
3282 }
3283 if (cp)
3284 printf("%s\n", cp);
3285 else if (conf->verbose_quit)
3286 printf("quit or abort executed\n");
3287 if (!inputisterminal() && !strcmp(fp->f_name, "*"))
3288 closeinput();
3289 go = FALSE;
3290 }
3291
3292
3293 S_FUNC void
3294 o_abort(FUNC *fp, long index)
3295 {
3296 abort_now = TRUE;
3297 o_quit(fp, index);
3298 }
3299
3300
3301 S_FUNC void
3302 o_getepsilon(void)
3303 {
3304 stack++;
3305 stack->v_type = V_NUM;
3306 stack->v_subtype = V_NOSUBTYPE;
3307 stack->v_num = qlink(conf->epsilon);
3308 }
3309
3310
3311 S_FUNC void
3312 o_setepsilon(void)
3313 {
3314 VALUE *vp;
3315 NUMBER *newep;
3316
3317 vp = &stack[0];
3318 if (vp->v_type == V_ADDR)
3319 vp = vp->v_addr;
3320 if (vp->v_type != V_NUM) {
3321 math_error("Non-numeric for epsilon");
3322 /*NOTREACHED*/
3323 }
3324 newep = vp->v_num;
3325 stack->v_num = qlink(conf->epsilon);
3326 setepsilon(newep);
3327 if (stack->v_type == V_NUM)
3328 qfree(newep);
3329 stack->v_type = V_NUM;
3330 stack->v_subtype = V_NOSUBTYPE;
3331 }
3332
3333
3334 S_FUNC void
3335 o_setconfig(void)
3336 {
3337 int type;
3338 VALUE *v1, *v2;
3339 VALUE tmp;
3340
3341 v1 = &stack[-1];
3342 v2 = &stack[0];
3343 if (v1->v_type == V_ADDR)
3344 v1 = v1->v_addr;
3345 if (v2->v_type == V_ADDR)
3346 v2 = v2->v_addr;
3347 if (v1->v_type != V_STR) {
3348 math_error("Non-string for config");
3349 /*NOTREACHED*/
3350 }
3351 type = configtype(v1->v_str->s_str);
3352 if (type < 0) {
3353 math_error("Unknown config name \"%s\"",
3354 v1->v_str->s_str);
3355 /*NOTREACHED*/
3356 }
3357 config_value(conf, type, &tmp);
3358 setconfig(type, v2);
3359 freevalue(stack--);
3360 freevalue(stack);
3361 *stack = tmp;
3362 }
3363
3364
3365 S_FUNC void
3366 o_getconfig(void)
3367 {
3368 int type;
3369 VALUE *vp;
3370
3371 vp = &stack[0];
3372 if (vp->v_type == V_ADDR)
3373 vp = vp->v_addr;
3374 if (vp->v_type != V_STR) {
3375 math_error("Non-string for config");
3376 /*NOTREACHED*/
3377 }
3378 type = configtype(vp->v_str->s_str);
3379 if (type < 0) {
3380 math_error("Unknown config name \"%s\"",
3381 vp->v_str->s_str);
3382 /*NOTREACHED*/
3383 }
3384 freevalue(stack);
3385 config_value(conf, type, stack);
3386 }
3387
3388
3389 /*
3390 * Set the 'old' value to the last value saved during the calculation.
3391 */
3392 void
3393 updateoldvalue(FUNC *fp)
3394 {
3395 if (fp->f_savedvalue.v_type == V_NULL)
3396 return;
3397 freevalue(&oldvalue);
3398 oldvalue = fp->f_savedvalue;
3399 fp->f_savedvalue.v_type = V_NULL;
3400 fp->f_savedvalue.v_subtype = V_NOSUBTYPE;
3401 }
3402
3403
3404 /*
3405 * error_value - return error as a value and store type in calc_errno
3406 */
3407 VALUE
3408 error_value(int e)
3409 {
3410 VALUE res;
3411
3412 if (-e > 0)
3413 e = 0;
3414 calc_errno = e;
3415 if (e > 0)
3416 errcount++;
3417 if (errmax >= 0 && errcount > errmax) {
3418 math_error("Error %d caused errcount to exceed errmax", e);
3419 /*NOTREACHED*/
3420 }
3421 res.v_type = (short) -e;
3422 res.v_subtype = V_NOSUBTYPE;
3423 return res;
3424 }
3425
3426 /*
3427 * set_errno - return and set calc_errno
3428 */
3429 int
3430 set_errno(int e)
3431 {
3432 int res;
3433
3434 res = calc_errno;
3435 if (e >= 0)
3436 calc_errno = e;
3437 return res;
3438 }
3439
3440
3441 /*
3442 * set_errcount - return and set errcount
3443 */
3444 int
3445 set_errcount(int e)
3446 {
3447 int res;
3448
3449 res = errcount;
3450 if (e >= 0)
3451 errcount = e;
3452 return res;
3453 }
3454
3455
3456 /*
3457 * Fill a newly created matrix at v1 with copies of value at v2.
3458 */
3459 S_FUNC void
3460 o_initfill(void)
3461 {
3462 VALUE *v1, *v2;
3463 int s;
3464 VALUE *vp;
3465
3466 v1 = &stack[-1];
3467 v2 = &stack[0];
3468
3469 if (v1->v_type == V_ADDR)
3470 v1 = v1->v_addr;
3471 if (v2->v_type == V_ADDR)
3472 v2 = v2->v_addr;
3473 if (v1->v_type != V_MAT) {
3474 math_error("Non-matrix argument for o_initfill");
3475 /*NOTREACHED*/
3476 }
3477 s = v1->v_mat->m_size;
3478 vp = v1->v_mat->m_table;
3479 while (s-- > 0)
3480 copyvalue(v2, vp++);
3481 freevalue(stack--);
3482 }
3483
3484
3485 /*ARGSUSED*/
3486 S_FUNC void
3487 o_show(FUNC *fp, long arg)
3488 {
3489 unsigned int size;
3490
3491 switch((int) arg) {
3492 case 1: showbuiltins(); return;
3493 case 2: showglobals(); return;
3494 case 3: showfunctions(); return;
3495 case 4: showobjfuncs(); return;
3496 case 5: config_print(conf); putchar('\n'); return;
3497 case 6: showobjtypes(); return;
3498 case 7: showfiles(); return;
3499 case 8: showsizes(); return;
3500 case 9: showerrors(); return;
3501 case 10: showcustom(); return;
3502 case 11: shownblocks(); return;
3503 case 12: showconstants(); return;
3504 case 13: showallglobals(); return;
3505 case 14: showstatics(); return;
3506 case 15: shownumbers(); return;
3507 case 16: showredcdata(); return;
3508 case 17: showstrings(); return;
3509 case 18: showliterals(); return;
3510 }
3511 fp = findfunc(arg - 19);
3512 if (fp == NULL) {
3513 printf("Function not defined\n");
3514 return;
3515 }
3516 dumpnames = FALSE;
3517 for (size = 0; size < fp->f_opcodecount; ) {
3518 printf("%ld: ", (long)size);
3519 size += dumpop(&fp->f_opcodes[size]);
3520 }
3521 }
3522
3523
3524 S_FUNC void
3525 showsizes(void)
3526 {
3527 printf("\tchar\t\t%4ld\n", (long)sizeof(char));
3528 printf("\tshort\t\t%4ld\n", (long)sizeof(short));
3529 printf("\tint\t\t%4ld\n", (long)sizeof(int));
3530 printf("\tlong\t\t%4ld\n", (long)sizeof(long));
3531 printf("\tpointer\t\t%4ld\n", (long)sizeof(void *));
3532 printf("\tFILEPOS\t\t%4ld\n", (long)sizeof(FILEPOS));
3533 printf("\toff_t\t\t%4ld\n", (long)sizeof(off_t));
3534 printf("\tHALF\t\t%4ld\n", (long)sizeof(HALF));
3535 printf("\tFULL\t\t%4ld\n", (long)sizeof(FULL));
3536 printf("\tVALUE\t\t%4ld\n", (long)sizeof(VALUE));
3537 printf("\tNUMBER\t\t%4ld\n", (long)sizeof(NUMBER));
3538 printf("\tZVALUE\t\t%4ld\n", (long)sizeof(ZVALUE));
3539 printf("\tCOMPLEX\t\t%4ld\n", (long)sizeof(COMPLEX));
3540 printf("\tSTRING\t\t%4ld\n", (long)sizeof(STRING));
3541 printf("\tMATRIX\t\t%4ld\n", (long)sizeof(MATRIX));
3542 printf("\tLIST\t\t%4ld\n", (long)sizeof(LIST));
3543 printf("\tLISTELEM\t%4ld\n", (long)sizeof(LISTELEM));
3544 printf("\tOBJECT\t\t%4ld\n", (long)sizeof(OBJECT));
3545 printf("\tOBJECTACTIONS\t%4ld\n", (long)sizeof(OBJECTACTIONS));
3546 printf("\tASSOC\t\t%4ld\n", (long)sizeof(ASSOC));
3547 printf("\tASSOCELEM\t%4ld\n", (long)sizeof(ASSOCELEM));
3548 printf("\tBLOCK\t\t%4ld\n", (long)sizeof(BLOCK));
3549 printf("\tNBLOCK\t\t%4ld\n", (long)sizeof(NBLOCK));
3550 printf("\tCONFIG\t\t%4ld\n", (long)sizeof(CONFIG));
3551 printf("\tFILEIO\t\t%4ld\n", (long)sizeof(FILEIO));
3552 printf("\tRAND\t\t%4ld\n", (long)sizeof(RAND));
3553 printf("\tRANDOM\t\t%4ld\n", (long)sizeof(RANDOM));
3554 }
3555
3556
3557 /*
3558 * Information about each opcode.
3559 */
3560 STATIC struct opcode opcodes[MAX_OPCODE+1] = {
3561 {o_nop, OPNUL,
3562 "NOP"}, /* no operation */
3563 {o_localaddr, OPLOC,
3564 "LOCALADDR"}, /* address of local variable */
3565 {o_globaladdr, OPGLB,
3566 "GLOBALADDR"}, /* address of global variable */
3567 {o_paramaddr, OPPAR,
3568 "PARAMADDR"}, /* address of parameter variable */
3569 {o_localvalue, OPLOC,
3570 "LOCALVALUE"}, /* value of local variable */
3571 {o_globalvalue, OPGLB,
3572 "GLOBALVALUE"}, /* value of global variable */
3573 {o_paramvalue, OPPAR,
3574 "PARAMVALUE"}, /* value of parameter variable */
3575 {o_number, OPONE,
3576 "NUMBER"}, /* constant real numeric value */
3577 {o_indexaddr, OPTWO,
3578 "INDEXADDR"}, /* array index address */
3579 {o_printresult, OPNUL,
3580 "PRINTRESULT"}, /* print result of top-level expression */
3581 {o_assign, OPNUL,
3582 "ASSIGN"}, /* assign value to variable */
3583 {o_add, OPNUL,
3584 "ADD"}, /* add top two values */
3585 {o_sub, OPNUL,
3586 "SUB"}, /* subtract top two values */
3587 {o_mul, OPNUL,
3588 "MUL"}, /* multiply top two values */
3589 {o_div, OPNUL,
3590 "DIV"}, /* divide top two values */
3591 {o_mod, OPNUL,
3592 "MOD"}, /* take mod of top two values */
3593 {o_save, OPNUL,
3594 "SAVE"}, /* save value for later use */
3595 {o_negate, OPNUL,
3596 "NEGATE"}, /* negate top value */
3597 {o_invert, OPNUL,
3598 "INVERT"}, /* invert top value */
3599 {o_int, OPNUL,
3600 "INT"}, /* take integer part */
3601 {o_frac, OPNUL,
3602 "FRAC"}, /* take fraction part */
3603 {o_numerator, OPNUL,
3604 "NUMERATOR"}, /* take numerator */
3605 {o_denominator, OPNUL,
3606 "DENOMINATOR"}, /* take denominator */
3607 {o_duplicate, OPNUL,
3608 "DUPLICATE"}, /* duplicate top value */
3609 {o_pop, OPNUL,
3610 "POP"}, /* pop top value */
3611 {o_return, OPRET,
3612 "RETURN"}, /* return value of function */
3613 {o_jumpz, OPJMP,
3614 "JUMPZ"}, /* jump if value zero */
3615 {o_jumpnz, OPJMP,
3616 "JUMPNZ"}, /* jump if value nonzero */
3617 {o_jump, OPJMP,
3618 "JUMP"}, /* jump unconditionally */
3619 {o_usercall, OPTWO,
3620 "USERCALL"}, /* call a user function */
3621 {o_getvalue, OPNUL,
3622 "GETVALUE"}, /* convert address to value */
3623 {o_eq, OPNUL,
3624 "EQ"}, /* test elements for equality */
3625 {o_ne, OPNUL,
3626 "NE"}, /* test elements for inequality */
3627 {o_le, OPNUL,
3628 "LE"}, /* test elements for <= */
3629 {o_ge, OPNUL,
3630 "GE"}, /* test elements for >= */
3631 {o_lt, OPNUL,
3632 "LT"}, /* test elements for < */
3633 {o_gt, OPNUL,
3634 "GT"}, /* test elements for > */
3635 {o_preinc, OPNUL,
3636 "PREINC"}, /* add one to variable (++x) */
3637 {o_predec, OPNUL,
3638 "PREDEC"}, /* subtract one from variable (--x) */
3639 {o_postinc, OPNUL,
3640 "POSTINC"}, /* add one to variable (x++) */
3641 {o_postdec, OPNUL,
3642 "POSTDEC"}, /* subtract one from variable (x--) */
3643 {o_debug, OPONE,
3644 "DEBUG"}, /* debugging point */
3645 {o_print, OPONE,
3646 "PRINT"}, /* print value */
3647 {o_assignpop, OPNUL,
3648 "ASSIGNPOP"}, /* assign to variable and pop it */
3649 {o_zero, OPNUL,
3650 "ZERO"}, /* put zero on the stack */
3651 {o_one, OPNUL,
3652 "ONE"}, /* put one on the stack */
3653 {o_printeol, OPNUL,
3654 "PRINTEOL"}, /* print end of line */
3655 {o_printspace, OPNUL,
3656 "PRINTSPACE"}, /* print a space */
3657 {o_printstring, OPONE,
3658 "PRINTSTR"}, /* print constant string */
3659 {o_dupvalue, OPNUL,
3660 "DUPVALUE"}, /* duplicate value of top value */
3661 {o_oldvalue, OPNUL,
3662 "OLDVALUE"}, /* old value from previous calc */
3663 {o_quo, OPNUL,
3664 "QUO"}, /* integer quotient of top values */
3665 {o_power, OPNUL,
3666 "POWER"}, /* value raised to a power */
3667 {o_quit, OPONE,
3668 "QUIT"}, /* quit program */
3669 {o_call, OPTWO,
3670 "CALL"}, /* call built-in routine */
3671 {o_getepsilon, OPNUL,
3672 "GETEPSILON"}, /* get allowed error for calculations */
3673 {o_and, OPNUL,
3674 "AND"}, /* arithmetic and or top two values */
3675 {o_or, OPNUL,
3676 "OR"}, /* arithmetic or of top two values */
3677 {o_not, OPNUL,
3678 "NOT"}, /* logical not or top value */
3679 {o_abs, OPNUL,
3680 "ABS"}, /* absolute value of top value */
3681 {o_sgn, OPNUL,
3682 "SGN"}, /* sign of number */
3683 {o_isint, OPNUL,
3684 "ISINT"}, /* whether number is an integer */
3685 {o_condorjump, OPJMP,
3686 "CONDORJUMP"}, /* conditional or jump */
3687 {o_condandjump, OPJMP,
3688 "CONDANDJUMP"}, /* conditional and jump */
3689 {o_square, OPNUL,
3690 "SQUARE"}, /* square top value */
3691 {o_string, OPONE,
3692 "STRING"}, /* string constant value */
3693 {o_isnum, OPNUL,
3694 "ISNUM"}, /* whether value is a number */
3695 {o_undef, OPNUL,
3696 "UNDEF"}, /* load undefined value on stack */
3697 {o_isnull, OPNUL,
3698 "ISNULL"}, /* whether value is the null value */
3699 {o_argvalue, OPARG,
3700 "ARGVALUE"}, /* load value of arg (parameter) n */
3701 {o_matcreate, OPONE,
3702 "MATCREATE"}, /* create matrix */
3703 {o_ismat, OPNUL,
3704 "ISMAT"}, /* whether value is a matrix */
3705 {o_isstr, OPNUL,
3706 "ISSTR"}, /* whether value is a string */
3707 {o_getconfig, OPNUL,
3708 "GETCONFIG"}, /* get value of configuration parameter */
3709 {o_leftshift, OPNUL,
3710 "LEFTSHIFT"}, /* left shift of integer */
3711 {o_rightshift, OPNUL,
3712 "RIGHTSHIFT"}, /* right shift of integer */
3713 {o_casejump, OPJMP,
3714 "CASEJUMP"}, /* test case and jump if not matched */
3715 {o_isodd, OPNUL,
3716 "ISODD"}, /* whether value is odd integer */
3717 {o_iseven, OPNUL,
3718 "ISEVEN"}, /* whether value is even integer */
3719 {o_fiaddr, OPNUL,
3720 "FIADDR"}, /* 'fast index' matrix address */
3721 {o_fivalue, OPNUL,
3722 "FIVALUE"}, /* 'fast index' matrix value */
3723 {o_isreal, OPNUL,
3724 "ISREAL"}, /* whether value is real number */
3725 {o_imaginary, OPONE,
3726 "IMAGINARY"}, /* constant imaginary numeric value */
3727 {o_re, OPNUL,
3728 "RE"}, /* real part of complex number */
3729 {o_im, OPNUL,
3730 "IM"}, /* imaginary part of complex number */
3731 {o_conjugate, OPNUL,
3732 "CONJUGATE"}, /* complex conjugate */
3733 {o_objcreate, OPONE,
3734 "OBJCREATE"}, /* create object */
3735 {o_isobj, OPNUL,
3736 "ISOBJ"}, /* whether value is an object */
3737 {o_norm, OPNUL,
3738 "NORM"}, /* norm of value (square of abs) */
3739 {o_elemaddr, OPONE,
3740 "ELEMADDR"}, /* address of element of object */
3741 {o_elemvalue, OPONE,
3742 "ELEMVALUE"}, /* value of element of object */
3743 {o_istype, OPNUL,
3744 "ISTYPE"}, /* whether types are the same */
3745 {o_scale, OPNUL,
3746 "SCALE"}, /* scale value by a power of two */
3747 {o_islist, OPNUL,
3748 "ISLIST"}, /* whether value is a list */
3749 {o_swap, OPNUL,
3750 "SWAP"}, /* swap values of two variables */
3751 {o_issimple, OPNUL,
3752 "ISSIMPLE"}, /* whether value is simple type */
3753 {o_cmp, OPNUL,
3754 "CMP"}, /* compare values returning -1, 0, 1 */
3755 {o_setconfig, OPNUL,
3756 "SETCONFIG"}, /* set configuration parameter */
3757 {o_setepsilon, OPNUL,
3758 "SETEPSILON"}, /* set allowed error for calculations */
3759 {o_isfile, OPNUL,
3760 "ISFILE"}, /* whether value is a file */
3761 {o_isassoc, OPNUL,
3762 "ISASSOC"}, /* whether value is an association */
3763 {o_nop, OPSTI,
3764 "INITSTATIC"}, /* once only code for static init */
3765 {o_eleminit, OPONE,
3766 "ELEMINIT"}, /* assign element of matrix or object */
3767 {o_isconfig, OPNUL,
3768 "ISCONFIG"}, /* whether value is a configuration state */
3769 {o_ishash, OPNUL,
3770 "ISHASH"}, /* whether value is a hash state */
3771 {o_isrand, OPNUL,
3772 "ISRAND"}, /* whether value is a rand element */
3773 {o_israndom, OPNUL,
3774 "ISRANDOM"}, /* whether value is a random element */
3775 {o_show, OPONE,
3776 "SHOW"}, /* show current state data */
3777 {o_initfill, OPNUL,
3778 "INITFILL"}, /* initially fill matrix */
3779 {o_assignback, OPNUL,
3780 "ASSIGNBACK"}, /* assign in reverse order */
3781 {o_test, OPNUL,
3782 "TEST"}, /* test that value is "nonzero" */
3783 {o_isdefined, OPNUL,
3784 "ISDEFINED"}, /* whether a string names a function */
3785 {o_isobjtype, OPNUL,
3786 "ISOBJTYPE"}, /* whether a string names an object type */
3787 {o_isblock, OPNUL,
3788 "ISBLK"}, /* whether value is a block */
3789 {o_ptr, OPNUL,
3790 "PTR"}, /* octet pointer */
3791 {o_deref, OPNUL,
3792 "DEREF"}, /* dereference an octet pointer */
3793 {o_isoctet, OPNUL,
3794 "ISOCTET"}, /* whether a value is an octet */
3795 {o_isptr, OPNUL,
3796 "ISPTR"}, /* whether a value is a pointer */
3797 {o_setsaveval, OPNUL,
3798 "SAVEVAL"}, /* enable or disable saving */
3799 {o_links, OPNUL,
3800 "LINKS"}, /* links to number or string */
3801 {o_bit, OPNUL,
3802 "BIT"}, /* whether bit is set */
3803 {o_comp, OPNUL,
3804 "COMP"}, /* complement value */
3805 {o_xor, OPNUL,
3806 "XOR"}, /* xor (~) of values */
3807 {o_highbit, OPNUL,
3808 "HIGHBIT"}, /* highbit of value */
3809 {o_lowbit, OPNUL,
3810 "LOWBIT"}, /* lowbit of value */
3811 {o_content, OPNUL,
3812 "CONTENT"}, /* unary hash op */
3813 {o_hashop, OPNUL,
3814 "HASHOP"}, /* binary hash op */
3815 {o_backslash, OPNUL,
3816 "BACKSLASH"}, /* unary backslash op */
3817 {o_setminus, OPNUL,
3818 "SETMINUS"}, /* binary backslash op */
3819 {o_plus, OPNUL,
3820 "PLUS"}, /* unary + op */
3821 {o_jumpnn, OPJMP,
3822 "JUMPNN"}, /* jump if non-null */
3823 {o_abort, OPONE,
3824 "ABORT"} /* abort operation */
3825 };
3826
3827
3828 /*
3829 * Compute the result of a function by interpreting opcodes.
3830 * Arguments have just been pushed onto the evaluation stack.
3831 *
3832 * given:
3833 * fp function to calculate
3834 * argcount number of arguments called with
3835 */
3836 void
3837 calculate(FUNC *fp, int argcount)
3838 {
3839 register unsigned long pc; /* current pc inside function */
3840 register struct opcode *op; /* current opcode pointer */
3841 register VALUE *locals; /* pointer to local variables */
3842 long oldline; /* old value of line counter */
3843 unsigned int opnum; /* current opcode number */
3844 int origargcount; /* original number of arguments */
3845 unsigned int i; /* loop counter */
3846 BOOL dojump; /* TRUE if jump is to occur */
3847 char *oldname; /* old function name being executed */
3848 VALUE *beginstack; /* beginning of stack frame */
3849 VALUE *args; /* pointer to function arguments */
3850 VALUE retval; /* function return value */
3851 VALUE localtable[QUICKLOCALS]; /* some local variables */
3852
3853 oldname = funcname;
3854 oldline = funcline;
3855 funcname = fp->f_name;
3856 funcline = 0;
3857 go = TRUE;
3858 ++calc_depth;
3859 origargcount = argcount;
3860 while ((unsigned)argcount < fp->f_paramcount) {
3861 stack++;
3862 stack->v_type = V_NULL;
3863 stack->v_subtype = V_NOSUBTYPE;
3864 argcount++;
3865 }
3866 locals = localtable;
3867 if (fp->f_localcount > QUICKLOCALS) {
3868 locals = (VALUE *) malloc(sizeof(VALUE) * fp->f_localcount);
3869 if (locals == NULL) {
3870 math_error("No memory for local variables");
3871 /*NOTREACHED*/
3872 }
3873 }
3874 for (i = 0; i < fp->f_localcount; i++) {
3875 locals[i].v_num = qlink(&_qzero_);
3876 locals[i].v_type = V_NUM;
3877 locals[i].v_subtype = V_NOSUBTYPE;
3878 }
3879 pc = 0;
3880 beginstack = stack;
3881 args = beginstack - (argcount - 1);
3882 while (go) {
3883 if (abortlevel >= ABORT_OPCODE) {
3884 math_error("Calculation aborted in opcode");
3885 /*NOTREACHED*/
3886 }
3887 if (pc >= fp->f_opcodecount) {
3888 math_error("Function pc out of range");
3889 /*NOTREACHED*/
3890 }
3891 if (stack > &stackarray[MAXSTACK-3]) {
3892 math_error("Evaluation stack depth exceeded");
3893 /*NOTREACHED*/
3894 }
3895 opnum = fp->f_opcodes[pc];
3896 if (opnum > MAX_OPCODE) {
3897 math_error("Function opcode out of range");
3898 /*NOTREACHED*/
3899 }
3900 op = &opcodes[opnum];
3901 if (conf->traceflags & TRACE_OPCODES) {
3902 dumpnames = FALSE;
3903 printf("%8s, pc %4ld: ", fp->f_name, pc);
3904 (void)dumpop(&fp->f_opcodes[pc]);
3905 }
3906 /*
3907 * Now call the opcode routine appropriately.
3908 */
3909 pc++;
3910 switch (op->o_type) {
3911 case OPNUL: /* no extra arguments */
3912 /* ignore Saber-C warning #65 - has 1 arg, expected 0 */
3913 /* ok to ignore in proc calculate */
3914 (*op->o_func)(fp);
3915 break;
3916
3917 case OPONE: /* one extra integer argument */
3918 (*op->o_func)(fp, fp->f_opcodes[pc++]);
3919 break;
3920
3921 case OPTWO: /* two extra integer arguments */
3922 (*op->o_func)(fp, fp->f_opcodes[pc],
3923 fp->f_opcodes[pc+1]);
3924 pc += 2;
3925 break;
3926
3927 case OPJMP: /* jump opcodes (one extra pointer arg) */
3928 dojump = FALSE;
3929 (*op->o_func)(fp, &dojump);
3930 if (dojump)
3931 pc = fp->f_opcodes[pc];
3932 else
3933 pc++;
3934 break;
3935
3936 case OPGLB: /* global symbol reference (pointer arg) */
3937 /* ignore Saber-C warning #68 - benign type mismatch */
3938 /* ok to ignore in proc calculate */
3939 (*op->o_func)(fp, *((char **) &fp->f_opcodes[pc]));
3940 pc += PTR_SIZE;
3941 break;
3942
3943 case OPLOC: /* local variable reference */
3944 (*op->o_func)(fp, locals, fp->f_opcodes[pc++]);
3945 break;
3946
3947 case OPPAR: /* parameter variable reference */
3948 (*op->o_func)(fp, argcount, args, fp->f_opcodes[pc++]);
3949 break;
3950
3951 case OPARG: /* parameter variable reference */
3952 (*op->o_func)(fp, origargcount, args);
3953 break;
3954
3955 case OPRET: /* return from function */
3956 if (stack->v_type == V_ADDR)
3957 copyvalue(stack->v_addr, stack);
3958 for (i = 0; i < fp->f_localcount; i++)
3959 freevalue(&locals[i]);
3960 if (locals != localtable)
3961 free(locals);
3962 if (stack != &beginstack[1]) {
3963 math_error("Misaligned stack");
3964 /*NOTREACHED*/
3965 }
3966 if (argcount > 0) {
3967 retval = *stack--;
3968 while (--argcount >= 0)
3969 freevalue(stack--);
3970 *++stack = retval;
3971 }
3972 funcname = oldname;
3973 funcline = oldline;
3974 --calc_depth;
3975 return;
3976
3977 case OPSTI: /* static initialization code */
3978 fp->f_opcodes[pc++ - 1] = OP_JUMP;
3979 break;
3980
3981 default:
3982 math_error("Unknown opcode type: %d", op->o_type);
3983 /*NOTREACHED*/
3984 }
3985 }
3986 for (i = 0; i < fp->f_localcount; i++)
3987 freevalue(&locals[i]);
3988 if (locals != localtable)
3989 free(locals);
3990 if (conf->calc_debug & CALCDBG_FUNC_QUIT)
3991 printf("\t\"%s\": line %ld\n", funcname, funcline);
3992 while (stack > beginstack)
3993 freevalue(stack--);
3994 funcname = oldname;
3995 funcline = oldline;
3996 --calc_depth;
3997 return;
3998 }
3999
4000
4001 /*
4002 * Dump an opcode at a particular address.
4003 * Returns the size of the opcode so that it can easily be skipped over.
4004 *
4005 * given:
4006 * pc location of the opcode
4007 */
4008 int
4009 dumpop(unsigned long *pc)
4010 {
4011 GLOBAL *sp;
4012 unsigned long op; /* opcode number */
4013
4014 op = *pc++;
4015 if (op <= MAX_OPCODE)
4016 printf("%s", opcodes[op].o_name);
4017 else
4018 printf("OP%ld", op);
4019 switch (op) {
4020 case OP_LOCALADDR: case OP_LOCALVALUE:
4021 if (dumpnames)
4022 printf(" %s\n", localname((long)*pc));
4023 else
4024 printf(" %ld\n", *pc);
4025 return 2;
4026 case OP_GLOBALADDR: case OP_GLOBALVALUE:
4027 sp = * (GLOBAL **) pc;
4028 printf(" %s", sp->g_name);
4029 if (sp->g_filescope > SCOPE_GLOBAL)
4030 printf(" %p", (void *) &sp->g_value);
4031 putchar('\n');
4032 return (1 + PTR_SIZE);
4033 case OP_PARAMADDR: case OP_PARAMVALUE:
4034 if (dumpnames)
4035 printf(" %s\n", paramname((long)*pc));
4036 else
4037 printf(" %ld\n", *pc);
4038 return 2;
4039 case OP_PRINTSTRING: case OP_STRING:
4040 printf(" \"%s\"\n", findstring((long)(*pc))->s_str);
4041 return 2;
4042 case OP_QUIT: case OP_ABORT:
4043 if ((long)(*pc) >= 0)
4044 printf(" \"%s\"", findstring((long)(*pc))->s_str);
4045 putchar('\n');
4046 return 2;
4047 case OP_INDEXADDR:
4048 printf(" %ld %ld\n", pc[0], pc[1]);
4049 return 3;
4050 case OP_PRINT: case OP_JUMPZ: case OP_JUMPNZ: case OP_JUMP:
4051 case OP_CONDORJUMP: case OP_CONDANDJUMP: case OP_CASEJUMP:
4052 case OP_INITSTATIC: case OP_MATCREATE:
4053 case OP_SHOW: case OP_ELEMINIT: case OP_ELEMADDR:
4054 case OP_ELEMVALUE: case OP_JUMPNN:
4055 printf(" %ld\n", *pc);
4056 return 2;
4057 case OP_OBJCREATE:
4058 printf(" %s\n", objtypename(*pc));
4059 return 2;
4060 case OP_NUMBER: case OP_IMAGINARY:
4061 qprintf(" %r", constvalue(*pc));
4062 printf("\n");
4063 return 2;
4064 case OP_DEBUG:
4065 printf(" line %ld\n", *pc);
4066 return 2;
4067 case OP_CALL:
4068 printf(" %s with %ld args\n",
4069 builtinname((long)pc[0]), (long)pc[1]);
4070 return 3;
4071 case OP_USERCALL:
4072 printf(" %s with %ld args\n",
4073 namefunc((long)pc[0]), (long)pc[1]);
4074 return 3;
4075 default:
4076 printf("\n");
4077 return 1;
4078 }
4079 }
4080
4081
4082 /*
4083 * Free the constant numbers in a function definition
4084 */
4085 void
4086 freenumbers(FUNC *fp)
4087 {
4088 unsigned long pc;
4089 unsigned int opnum;
4090 struct opcode *op;
4091
4092 for (pc = 0; pc < fp->f_opcodecount; ) {
4093 opnum = fp->f_opcodes[pc++];
4094 op = &opcodes[opnum];
4095 switch (op->o_type) {
4096 case OPRET:
4097 case OPARG:
4098 case OPNUL:
4099 continue;
4100 case OPONE:
4101 switch(opnum) {
4102 case OP_NUMBER:
4103 case OP_IMAGINARY:
4104 freeconstant(fp->f_opcodes[pc]);
4105 break;
4106 case OP_PRINTSTRING:
4107 case OP_STRING:
4108 case OP_QUIT:
4109 freestringconstant(
4110 (long)fp->f_opcodes[pc]);
4111 }
4112 /*FALLTHRU*/
4113 case OPLOC:
4114 case OPPAR:
4115 case OPJMP:
4116 case OPSTI:
4117 pc++;
4118 continue;
4119 case OPTWO:
4120 pc += 2;
4121 continue;
4122 case OPGLB:
4123 pc += PTR_SIZE;
4124 continue;
4125 default:
4126 math_error("Unknown opcode type for freeing");
4127 /*NOTREACHED*/
4128 }
4129 }
4130 if (pc != fp->f_opcodecount) {
4131 math_error("Incorrect opcodecount ???");
4132 /*NOTREACHED*/
4133 }
4134 trimconstants();
4135 }
4136
4137
4138 long
4139 calclevel(void)
4140 {
4141 return calc_depth - 1;
4142 }
A place to share codes with mates