?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
modified: SpatialOmicsCoord.py
[GalaxyCodeBases.git] / c_cpp / etc / calc / value.c
blobadf27f21d483727335348bdd57981900b4625491
1 /*
2 * value - generic value manipulation routines
3 *
4 * Copyright (C) 1999-2007 David I. Bell
5 *
6 * Calc is open software; you can redistribute it and/or modify it under
7 * the terms of the version 2.1 of the GNU Lesser General Public License
8 * as published by the Free Software Foundation.
9 *
10 * Calc is distributed in the hope that it will be useful, but WITHOUT
11 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
13 * Public License for more details.
14 *
15 * A copy of version 2.1 of the GNU Lesser General Public License is
16 * distributed with calc under the filename COPYING-LGPL. You should have
17 * received a copy with calc; if not, write to Free Software Foundation, Inc.
18 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
19 *
20 * @(#) $Revision: 30.5 $
21 * @(#) $Id: value.c,v 30.5 2013/08/11 08:41:38 chongo Exp $
22 * @(#) $Source: /usr/local/src/bin/calc/RCS/value.c,v $
23 *
24 * Under source code control: 1990/02/15 01:48:25
25 * File existed as early as: before 1990
26 *
27 * Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/
28 */
29
30
31 #include <stdio.h>
32 #include <sys/types.h>
33 #include "value.h"
34 #include "opcodes.h"
35 #include "func.h"
36 #include "symbol.h"
37 #include "str.h"
38 #include "zrand.h"
39 #include "zrandom.h"
40 #include "cmath.h"
41 #include "nametype.h"
42 #include "file.h"
43 #include "config.h"
44
45 #define LINELEN 80 /* length of a typical tty line */
46
47 /*
48 * Free a value and set its type to undefined.
49 *
50 * given:
51 * vp value to be freed
52 */
53 void
54 freevalue(VALUE *vp)
55 {
56 int type; /* type of value being freed */
57
58 type = vp->v_type;
59 vp->v_type = V_NULL;
60 vp->v_subtype = V_NOSUBTYPE;
61 if (type <= 0)
62 return;
63 switch (type) {
64 case V_ADDR:
65 case V_OCTET:
66 case V_NBLOCK:
67 case V_FILE:
68 case V_VPTR:
69 case V_OPTR:
70 case V_SPTR:
71 case V_NPTR:
72 /* nothing to free */
73 break;
74 case V_STR:
75 sfree(vp->v_str);
76 break;
77 case V_NUM:
78 qfree(vp->v_num);
79 break;
80 case V_COM:
81 comfree(vp->v_com);
82 break;
83 case V_MAT:
84 matfree(vp->v_mat);
85 break;
86 case V_LIST:
87 listfree(vp->v_list);
88 break;
89 case V_ASSOC:
90 assocfree(vp->v_assoc);
91 break;
92 case V_OBJ:
93 objfree(vp->v_obj);
94 break;
95 case V_RAND:
96 randfree(vp->v_rand);
97 break;
98 case V_RANDOM:
99 randomfree(vp->v_random);
100 break;
101 case V_CONFIG:
102 config_free(vp->v_config);
103 break;
104 case V_HASH:
105 hash_free(vp->v_hash);
106 break;
107 case V_BLOCK:
108 blk_free(vp->v_block);
109 break;
110 default:
111 math_error("Freeing unknown value type");
112 /*NOTREACHED*/
113 }
114 }
115
116
117 /*
118 * Set protection status for a value and all of its components
119 */
120 void
121 protecttodepth(VALUE *vp, int sts, int depth)
122 {
123 VALUE *vq;
124 int i;
125 LISTELEM *ep;
126 ASSOC *ap;
127
128 if (vp->v_type == V_NBLOCK) {
129 if (sts > 0)
130 vp->v_nblock->subtype |= sts;
131 else if (sts < 0)
132 vp->v_nblock->subtype &= ~(-sts);
133 else vp->v_nblock->subtype = 0;
134 return;
135 }
136 if (sts > 0)
137 vp->v_subtype |= sts;
138 else if (sts < 0)
139 vp->v_subtype &= ~(-sts);
140 else
141 vp->v_subtype = 0;
142
143
144 if (depth > 0) {
145 switch(vp->v_type) {
146 case V_MAT:
147 vq = vp->v_mat->m_table;
148 i = vp->v_mat->m_size;
149 while (i-- > 0)
150 protecttodepth(vq++, sts, depth - 1);
151 break;
152 case V_LIST:
153 for (ep = vp->v_list->l_first; ep; ep = ep->e_next)
154 protecttodepth(&ep->e_value, sts, depth - 1);
155 break;
156 case V_OBJ:
157 vq = vp->v_obj->o_table;
158 i = vp->v_obj->o_actions->oa_count;
159 while (i-- > 0)
160 protecttodepth(vq++, sts, depth - 1);
161 break;
162 case V_ASSOC:
163 ap = vp->v_assoc;
164 for (i = 0; i < ap->a_count; i++)
165 protecttodepth(assocfindex(ap, i), sts, depth - 1);
166 }
167 }
168 }
169
170
171 /*
172 * Copy a value from one location to another.
173 * This overwrites the specified new value without checking it.
174 *
175 * given:
176 * oldvp value to be copied from
177 * newvp value to be copied into
178 */
179 void
180 copyvalue(VALUE *oldvp, VALUE *newvp)
181 {
182 /* firewall */
183 if (oldvp == NULL)
184 return;
185
186 newvp->v_type = oldvp->v_type;
187 if (oldvp->v_type >= 0) {
188 switch (oldvp->v_type) {
189 case V_NULL:
190 case V_ADDR:
191 case V_VPTR:
192 case V_OPTR:
193 case V_SPTR:
194 case V_NPTR:
195 *newvp = *oldvp;
196 break;
197 case V_FILE:
198 newvp->v_file = oldvp->v_file;
199 break;
200 case V_NUM:
201 newvp->v_num = qlink(oldvp->v_num);
202 break;
203 case V_COM:
204 newvp->v_com = clink(oldvp->v_com);
205 break;
206 case V_STR:
207 newvp->v_str = slink(oldvp->v_str);
208 break;
209 case V_MAT:
210 newvp->v_mat = matcopy(oldvp->v_mat);
211 break;
212 case V_LIST:
213 newvp->v_list = listcopy(oldvp->v_list);
214 break;
215 case V_ASSOC:
216 newvp->v_assoc = assoccopy(oldvp->v_assoc);
217 break;
218 case V_OBJ:
219 newvp->v_obj = objcopy(oldvp->v_obj);
220 break;
221 case V_RAND:
222 newvp->v_rand = randcopy(oldvp->v_rand);
223 break;
224 case V_RANDOM:
225 newvp->v_random = randomcopy(oldvp->v_random);
226 break;
227 case V_CONFIG:
228 newvp->v_config = config_copy(oldvp->v_config);
229 break;
230 case V_HASH:
231 newvp->v_hash = hash_copy(oldvp->v_hash);
232 break;
233 case V_BLOCK:
234 newvp->v_block = blk_copy(oldvp->v_block);
235 break;
236 case V_OCTET:
237 newvp->v_type = V_NUM;
238 newvp->v_num = itoq((long) *oldvp->v_octet);
239 break;
240 case V_NBLOCK:
241 newvp->v_nblock = oldvp->v_nblock;
242 break;
243 default:
244 math_error("Copying unknown value type");
245 /*NOTREACHED*/
246 }
247 }
248 newvp->v_subtype = oldvp->v_subtype;
249 }
250
251
252 /*
253 * copy the low order 8 bits of a value to an octet
254 */
255 void
256 copy2octet(VALUE *vp, OCTET *op)
257 {
258 USB8 oval; /* low order 8 bits to store into OCTET */
259 NUMBER *q;
260 HALF h;
261
262 if (vp->v_type == V_ADDR)
263 vp = vp->v_addr;
264
265 oval = 0;
266
267 /*
268 * we can (at the moment) only store certain types
269 * values into an OCTET, so get the low order 8 bits
270 * of these particular value types
271 */
272 h = 0;
273 switch(vp->v_type) {
274 case V_NULL:
275 /* nothing to store ... so do nothing */
276 return;
277 case V_INT:
278 oval = (USB8)(vp->v_int & 0xff);
279 break;
280 case V_NUM:
281 if (qisint(vp->v_num)) {
282 /* use low order 8 bits of integer value */
283 h = vp->v_num->num.v[0];
284 } else {
285 /* use low order 8 bits of int(value) */
286 q = qint(vp->v_num);
287 h = q->num.v[0];
288 qfree(q);
289 }
290 if (qisneg(vp->v_num))
291 h = -h;
292 oval = (USB8) h;
293 break;
294 case V_COM:
295 if (cisint(vp->v_com)) {
296 /* use low order 8 bits of integer value */
297 h = vp->v_com->real->num.v[0];
298 } else {
299 /* use low order 8 bits of int(value) */
300 q = qint(vp->v_com->real);
301 h = q->num.v[0];
302 qfree(q);
303 }
304 if (qisneg(vp->v_com->real))
305 h = -h;
306 oval = (USB8) h;
307 break;
308 case V_STR:
309 oval = (USB8) vp->v_str->s_str[0];
310 break;
311 case V_BLOCK:
312 oval = (USB8) vp->v_block->data[0];
313 break;
314 case V_OCTET:
315 oval = *vp->v_octet;
316 break;
317 case V_NBLOCK:
318 if (vp->v_nblock->blk->data == NULL)
319 return;
320 oval = (USB8) vp->v_nblock->blk->data[0];
321 break;
322 default:
323 math_error("invalid assignment into an OCTET");
324 break;
325 }
326 *op = oval;
327 }
328
329
330 /*
331 * Negate an arbitrary value.
332 * Result is placed in the indicated location.
333 */
334 void
335 negvalue(VALUE *vp, VALUE *vres)
336 {
337 vres->v_type = vp->v_type;
338 vres->v_subtype = V_NOSUBTYPE;
339 switch (vp->v_type) {
340 case V_NUM:
341 vres->v_num = qneg(vp->v_num);
342 return;
343 case V_COM:
344 vres->v_com = c_neg(vp->v_com);
345 return;
346 case V_MAT:
347 vres->v_mat = matneg(vp->v_mat);
348 return;
349 case V_STR:
350 vres->v_str = stringneg(vp->v_str);
351 if (vres->v_str == NULL)
352 *vres = error_value(E_STRNEG);
353 return;
354 case V_OCTET:
355 vres->v_type = V_NUM;
356 vres->v_subtype = V_NOSUBTYPE;
357 vres->v_num = itoq(- (long) *vp->v_octet);
358 return;
359
360 case V_OBJ:
361 *vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
362 return;
363 default:
364 if (vp->v_type <= 0)
365 return;
366 *vres = error_value(E_NEG);
367 return;
368 }
369 }
370
371
372 /*
373 * Add two arbitrary values together.
374 * Result is placed in the indicated location.
375 */
376 void
377 addvalue(VALUE *v1, VALUE *v2, VALUE *vres)
378 {
379 COMPLEX *c;
380 VALUE tmp;
381 NUMBER *q;
382 long i;
383
384 vres->v_subtype = V_NOSUBTYPE;
385 if (v1->v_type == V_LIST) {
386 tmp.v_type = V_NULL;
387 addlistitems(v1->v_list, &tmp);
388 addvalue(&tmp, v2, vres);
389 return;
390 }
391 if (v2->v_type == V_LIST) {
392 copyvalue(v1, vres);
393 addlistitems(v2->v_list, vres);
394 return;
395 }
396 if (v1->v_type == V_NULL) {
397 copyvalue(v2, vres);
398 return;
399 }
400 if (v2->v_type == V_NULL) {
401 copyvalue(v1, vres);
402 return;
403 }
404 vres->v_type = v1->v_type;
405 switch (TWOVAL(v1->v_type, v2->v_type)) {
406 case TWOVAL(V_NUM, V_NUM):
407 vres->v_num = qqadd(v1->v_num, v2->v_num);
408 return;
409 case TWOVAL(V_COM, V_NUM):
410 vres->v_com = c_addq(v1->v_com, v2->v_num);
411 return;
412 case TWOVAL(V_NUM, V_COM):
413 vres->v_com = c_addq(v2->v_com, v1->v_num);
414 vres->v_type = V_COM;
415 return;
416 case TWOVAL(V_COM, V_COM):
417 vres->v_com = c_add(v1->v_com, v2->v_com);
418 c = vres->v_com;
419 if (!cisreal(c))
420 return;
421 vres->v_num = qlink(c->real);
422 vres->v_type = V_NUM;
423 comfree(c);
424 return;
425 case TWOVAL(V_MAT, V_MAT):
426 vres->v_mat = matadd(v1->v_mat, v2->v_mat);
427 return;
428 case TWOVAL(V_STR, V_STR):
429 vres->v_str = stringadd(v1->v_str, v2->v_str);
430 if (vres->v_str == NULL)
431 *vres = error_value(E_STRADD);
432 return;
433 case TWOVAL(V_VPTR, V_NUM):
434 q = v2->v_num;
435 if (qisfrac(q)) {
436 math_error("Adding non-integer to address");
437 /*NOTREACHED*/
438 }
439 i = qtoi(q);
440 vres->v_addr = v1->v_addr + i;
441 vres->v_type = V_VPTR;
442 return;
443 case TWOVAL(V_OPTR, V_NUM):
444 q = v2->v_num;
445 if (qisfrac(q)) {
446 math_error("Adding non-integer to address");
447 /*NOTREACHED*/
448 }
449 i = qtoi(q);
450 vres->v_octet = v1->v_octet + i;
451 vres->v_type = V_OPTR;
452 return;
453 default:
454 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
455 if (v1->v_type < 0)
456 return;
457 if (v2->v_type > 0)
458 *vres = error_value(E_ADD);
459 else
460 vres->v_type = v2->v_type;
461 return;
462 }
463 *vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
464 return;
465 }
466 }
467
468
469 /*
470 * Subtract one arbitrary value from another one.
471 * Result is placed in the indicated location.
472 */
473 void
474 subvalue(VALUE *v1, VALUE *v2, VALUE *vres)
475 {
476 COMPLEX *c;
477 NUMBER *q;
478 int i;
479
480 vres->v_type = v1->v_type;
481 vres->v_subtype = V_NOSUBTYPE;
482 switch (TWOVAL(v1->v_type, v2->v_type)) {
483 case TWOVAL(V_NUM, V_NUM):
484 vres->v_num = qsub(v1->v_num, v2->v_num);
485 return;
486 case TWOVAL(V_COM, V_NUM):
487 vres->v_com = c_subq(v1->v_com, v2->v_num);
488 return;
489 case TWOVAL(V_NUM, V_COM):
490 c = c_subq(v2->v_com, v1->v_num);
491 vres->v_type = V_COM;
492 vres->v_com = c_neg(c);
493 comfree(c);
494 return;
495 case TWOVAL(V_COM, V_COM):
496 vres->v_com = c_sub(v1->v_com, v2->v_com);
497 c = vres->v_com;
498 if (!cisreal(c))
499 return;
500 vres->v_num = qlink(c->real);
501 vres->v_type = V_NUM;
502 comfree(c);
503 return;
504 case TWOVAL(V_MAT, V_MAT):
505 vres->v_mat = matsub(v1->v_mat, v2->v_mat);
506 return;
507 case TWOVAL(V_STR, V_STR):
508 vres->v_str = stringsub(v1->v_str, v2->v_str);
509 if (vres->v_str == NULL)
510 *vres = error_value(E_STRSUB);
511 return;
512 case TWOVAL(V_VPTR, V_NUM):
513 q = v2->v_num;
514 if (qisfrac(q)) {
515 math_error("Subtracting non-integer from address");
516 /*NOTREACHED*/
517 }
518 i = qtoi(q);
519 vres->v_addr = v1->v_addr - i;
520 vres->v_type = V_VPTR;
521 return;
522 case TWOVAL(V_OPTR, V_NUM):
523 q = v2->v_num;
524 if (qisfrac(q)) {
525 math_error("Adding non-integer to address");
526 /*NOTREACHED*/
527 }
528 i = qtoi(q);
529 vres->v_octet = v1->v_octet - i;
530 vres->v_type = V_OPTR;
531 return;
532 case TWOVAL(V_VPTR, V_VPTR):
533 vres->v_type = V_NUM;
534 vres->v_num = itoq(v1->v_addr - v2->v_addr);
535 return;
536 case TWOVAL(V_OPTR, V_OPTR):
537 vres->v_type = V_NUM;
538 vres->v_num = itoq(v1->v_octet - v2->v_octet);
539 return;
540 default:
541 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
542 if (v1->v_type <= 0)
543 return;
544 if (v2->v_type <= 0) {
545 vres->v_type = v2->v_type;
546 return;
547 }
548 *vres = error_value(E_SUB);
549 return;
550 }
551 *vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
552 return;
553 }
554 }
555
556
557 /*
558 * Multiply two arbitrary values together.
559 * Result is placed in the indicated location.
560 */
561 void
562 mulvalue(VALUE *v1, VALUE *v2, VALUE *vres)
563 {
564 COMPLEX *c;
565
566 vres->v_type = v1->v_type;
567 vres->v_subtype = V_NOSUBTYPE;
568 switch (TWOVAL(v1->v_type, v2->v_type)) {
569 case TWOVAL(V_NUM, V_NUM):
570 vres->v_num = qmul(v1->v_num, v2->v_num);
571 return;
572 case TWOVAL(V_COM, V_NUM):
573 vres->v_com = c_mulq(v1->v_com, v2->v_num);
574 break;
575 case TWOVAL(V_NUM, V_COM):
576 vres->v_com = c_mulq(v2->v_com, v1->v_num);
577 vres->v_type = V_COM;
578 break;
579 case TWOVAL(V_COM, V_COM):
580 vres->v_com = c_mul(v1->v_com, v2->v_com);
581 break;
582 case TWOVAL(V_MAT, V_MAT):
583 vres->v_mat = matmul(v1->v_mat, v2->v_mat);
584 return;
585 case TWOVAL(V_MAT, V_NUM):
586 case TWOVAL(V_MAT, V_COM):
587 vres->v_mat = matmulval(v1->v_mat, v2);
588 return;
589 case TWOVAL(V_NUM, V_MAT):
590 case TWOVAL(V_COM, V_MAT):
591 vres->v_mat = matmulval(v2->v_mat, v1);
592 vres->v_type = V_MAT;
593 return;
594 case TWOVAL(V_NUM, V_STR):
595 vres->v_type = V_STR;
596 vres->v_str = stringmul(v1->v_num, v2->v_str);
597 if (vres->v_str == NULL)
598 *vres = error_value(E_STRMUL);
599 return;
600 case TWOVAL(V_STR, V_NUM):
601 vres->v_str= stringmul(v2->v_num, v1->v_str);
602 if (vres->v_str == NULL)
603 *vres = error_value(E_STRMUL);
604 return;
605 default:
606 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
607 if (v1->v_type <= 0)
608 return;
609 if (v2->v_type <= 0) {
610 vres->v_type = v2->v_type;
611 return;
612 }
613 *vres = error_value(E_MUL);
614 return;
615 }
616 *vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
617 return;
618 }
619 c = vres->v_com;
620 if (cisreal(c)) {
621 vres->v_num = qlink(c->real);
622 vres->v_type = V_NUM;
623 comfree(c);
624 }
625 }
626
627
628 /*
629 * Square an arbitrary value.
630 * Result is placed in the indicated location.
631 */
632 void
633 squarevalue(VALUE *vp, VALUE *vres)
634 {
635 COMPLEX *c;
636
637 vres->v_type = vp->v_type;
638 vres->v_subtype = V_NOSUBTYPE;
639 switch (vp->v_type) {
640 case V_NUM:
641 vres->v_num = qsquare(vp->v_num);
642 return;
643 case V_COM:
644 vres->v_com = c_square(vp->v_com);
645 c = vres->v_com;
646 if (!cisreal(c))
647 return;
648 vres->v_num = qlink(c->real);
649 vres->v_type = V_NUM;
650 comfree(c);
651 return;
652 case V_MAT:
653 vres->v_mat = matsquare(vp->v_mat);
654 return;
655 case V_OBJ:
656 *vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
657 return;
658 default:
659 if (vp->v_type <= 0) {
660 vres->v_type = vp->v_type;
661 return;
662 }
663 *vres = error_value(E_SQUARE);
664 return;
665 }
666 }
667
668
669 /*
670 * Invert an arbitrary value.
671 * Result is placed in the indicated location.
672 */
673 void
674 invertvalue(VALUE *vp, VALUE *vres)
675 {
676 NUMBER *q1, *q2;
677
678 vres->v_type = vp->v_type;
679 vres->v_subtype = V_NOSUBTYPE;
680 switch (vp->v_type) {
681 case V_NUM:
682 if (qiszero(vp->v_num))
683 *vres = error_value(E_1OVER0);
684 else
685 vres->v_num = qinv(vp->v_num);
686 return;
687 case V_COM:
688 vres->v_com = c_inv(vp->v_com);
689 return;
690 case V_MAT:
691 vres->v_mat = matinv(vp->v_mat);
692 return;
693 case V_OCTET:
694 if (*vp->v_octet == 0) {
695 *vres = error_value(E_1OVER0);
696 return;
697 }
698 q1 = itoq((long) *vp->v_octet);
699 q2 = qinv(q1);
700 qfree(q1);
701 vres->v_num = q2;
702 vres->v_type = V_NUM;
703 return;
704 case V_OBJ:
705 *vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
706 return;
707 default:
708 if (vp->v_type == -E_1OVER0) {
709 vres->v_type = V_NUM;
710 vres->v_num = qlink(&_qzero_);
711 return;
712 }
713 if (vp->v_type <= 0)
714 return;
715 *vres = error_value(E_INV);
716 return;
717 }
718 }
719
720
721
722 /*
723 * "AND" two arbitrary values together.
724 * Result is placed in the indicated location.
725 */
726 void
727 andvalue(VALUE *v1, VALUE *v2, VALUE *vres)
728 {
729 vres->v_subtype = V_NOSUBTYPE;
730 if (v1->v_type == V_NULL) {
731 copyvalue(v2, vres);
732 return;
733 }
734 if (v2->v_type == V_NULL) {
735 copyvalue(v1, vres);
736 return;
737 }
738 vres->v_type = v1->v_type;
739 switch (TWOVAL(v1->v_type, v2->v_type)) {
740 case TWOVAL(V_NUM, V_NUM):
741 vres->v_num = qand(v1->v_num, v2->v_num);
742 return;
743 case TWOVAL(V_STR, V_STR):
744 vres->v_str = stringand(v1->v_str, v2->v_str);
745 if (vres->v_str == NULL)
746 *vres = error_value(E_STRAND);
747 return;
748 case TWOVAL(V_OCTET, V_OCTET):
749 vres->v_type = V_STR;
750 vres->v_str = charstring(*v1->v_octet & *v2->v_octet);
751 return;
752 case TWOVAL(V_STR, V_OCTET):
753 vres->v_str = charstring(*v1->v_str->s_str &
754 *v2->v_octet);
755 return;
756 case TWOVAL(V_OCTET, V_STR):
757 vres->v_type = V_STR;
758 vres->v_str = charstring(*v1->v_octet &
759 *v2->v_str->s_str);
760 return;
761 default:
762 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
763 if (v1->v_type < 0)
764 return;
765 if (v2->v_type < 0) {
766 vres->v_type = v2->v_type;
767 return;
768 }
769 *vres = error_value(E_AND);
770 return;
771 }
772 *vres = objcall(OBJ_AND, v1, v2, NULL_VALUE);
773 return;
774 }
775 }
776
777
778 /*
779 * "OR" two arbitrary values together.
780 * Result is placed in the indicated location.
781 */
782 void
783 orvalue(VALUE *v1, VALUE *v2, VALUE *vres)
784 {
785 if (v1->v_type == V_NULL) {
786 copyvalue(v2, vres);
787 return;
788 }
789 if (v2->v_type == V_NULL) {
790 copyvalue(v1, vres);
791 return;
792 }
793 vres->v_type = v1->v_type;
794 vres->v_subtype = V_NOSUBTYPE;
795 switch (TWOVAL(v1->v_type, v2->v_type)) {
796 case TWOVAL(V_NUM, V_NUM):
797 vres->v_num = qor(v1->v_num, v2->v_num);
798 return;
799 case TWOVAL(V_STR, V_STR):
800 vres->v_str = stringor(v1->v_str, v2->v_str);
801 if (vres->v_str == NULL)
802 *vres = error_value(E_STROR);
803 return;
804 case TWOVAL(V_OCTET, V_OCTET):
805 vres->v_type = V_STR;
806 vres->v_str = charstring(*v1->v_octet | *v2->v_octet);
807 return;
808 case TWOVAL(V_STR, V_OCTET):
809 vres->v_str = charstring(*v1->v_str->s_str |
810 *v2->v_octet);
811 return;
812 case TWOVAL(V_OCTET, V_STR):
813 vres->v_type = V_STR;
814 vres->v_str = charstring(*v1->v_octet |
815 *v2->v_str->s_str);
816 return;
817 default:
818 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
819 if (v1->v_type < 0)
820 return;
821 if (v2->v_type < 0) {
822 vres->v_type = v2->v_type;
823 return;
824 }
825 *vres = error_value(E_OR);
826 return;
827 }
828 *vres = objcall(OBJ_OR, v1, v2, NULL_VALUE);
829 return;
830 }
831 }
832
833
834 /*
835 * "~" two values, returns the "symmetric difference" bitwise xor(v1, v2) for
836 * strings, octets and real numbers, and a user-defined function if at least
837 * one of v1 and v2 is an object.
838 */
839 void
840 xorvalue(VALUE *v1, VALUE *v2, VALUE *vres)
841 {
842 vres->v_type = v1->v_type;
843 vres->v_subtype = V_NOSUBTYPE;
844 switch (TWOVAL(v1->v_type, v2->v_type)) {
845 case (TWOVAL(V_NUM, V_NUM)):
846 vres->v_num = qxor(v1->v_num, v2->v_num);
847 return;
848 case (TWOVAL(V_STR, V_STR)):
849 vres->v_str = stringxor(v1->v_str, v2->v_str);
850 if (vres->v_str == NULL)
851 *vres = error_value(E_STRDIFF);
852 return;
853 case (TWOVAL(V_STR, V_OCTET)):
854 if (v1->v_str->s_len) {
855 vres->v_str = stringcopy(v1->v_str);
856 *vres->v_str->s_str ^= *v2->v_octet;
857 } else {
858 vres->v_str = charstring(*v2->v_octet);
859 }
860 return;
861 case (TWOVAL(V_OCTET, V_STR)):
862 if (v2->v_str->s_len) {
863 vres->v_str = stringcopy(v2->v_str);
864 *vres->v_str->s_str ^= *v1->v_octet;
865 } else {
866 vres->v_str = charstring(*v1->v_octet);
867 }
868 return;
869 case (TWOVAL(V_OCTET, V_OCTET)):
870 vres->v_type = V_STR;
871 vres->v_str = charstring(*v1->v_octet ^ *v2->v_octet);
872 return;
873 default:
874 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
875 *vres = objcall(OBJ_XOR, v1, v2, NULL_VALUE);
876 else
877 *vres = error_value(E_XOR);
878 }
879 }
880
881
882 /*
883 * "#" two values - abs(v1-v2) for numbers, user-defined for objects
884 */
885 void
886 hashopvalue(VALUE *v1, VALUE *v2, VALUE *vres)
887 {
888 NUMBER *q;
889
890 vres->v_type = v1->v_type;
891 vres->v_subtype = V_NOSUBTYPE;
892 switch (TWOVAL(v1->v_type, v2->v_type)) {
893 case TWOVAL(V_NUM, V_NUM):
894 q = qsub(v1->v_num, v2->v_num);
895 vres->v_num = qqabs(q);
896 qfree(q);
897 return;
898 default:
899 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
900 *vres = objcall(OBJ_HASHOP, v1, v2, NULL_VALUE);
901 else
902 *vres = error_value(E_HASHOP);
903 }
904 }
905
906
907 void
908 compvalue(VALUE *vp, VALUE *vres)
909 {
910
911 vres->v_type = vp->v_type;
912 vres->v_subtype = V_NOSUBTYPE;
913 switch (vp->v_type) {
914 case V_NUM:
915 vres->v_num = qcomp(vp->v_num);
916 return;
917 case V_STR:
918 vres->v_str = stringcomp(vp->v_str);
919 if (vres->v_str == NULL)
920 *vres = error_value(E_STRCOMP);
921 return;
922 case V_OCTET:
923 vres->v_type = V_STR;
924 vres->v_str = charstring(~*vp->v_octet);
925 return;
926 case V_OBJ:
927 *vres = objcall(OBJ_COMP, vp, NULL_VALUE, NULL_VALUE);
928 return;
929 default:
930 *vres = error_value(E_COMP);
931 }
932 }
933
934 /*
935 * "\" a value, user-defined only
936 */
937 void
938 backslashvalue(VALUE *vp, VALUE *vres)
939 {
940 if (vp->v_type == V_OBJ)
941 *vres = objcall(OBJ_BACKSLASH, vp, NULL_VALUE, NULL_VALUE);
942 else
943 *vres = error_value(E_BACKSLASH);
944 }
945
946
947 /*
948 * "\" two values, for strings performs bitwise "AND-NOT" operation
949 * User defined for objects
950 */
951 void
952 setminusvalue(VALUE *v1, VALUE *v2, VALUE *vres)
953 {
954 vres->v_type = v1->v_type;
955 vres->v_subtype = V_NOSUBTYPE;
956 switch (TWOVAL(v1->v_type, v2->v_type)) {
957 case TWOVAL(V_NUM, V_NUM):
958 vres->v_num = qandnot(v1->v_num, v2->v_num);
959 return;
960 case TWOVAL(V_STR, V_STR):
961 vres->v_str = stringdiff(v1->v_str, v2->v_str);
962 return;
963 case TWOVAL(V_STR, V_OCTET):
964 vres->v_str = charstring(*v1->v_str->s_str &
965 ~*v2->v_octet);
966 return;
967 case TWOVAL(V_OCTET, V_STR):
968 vres->v_type = V_STR;
969 vres->v_str = charstring(*v1->v_octet &
970 ~*v2->v_str->s_str);
971 return;
972 case TWOVAL(V_OCTET, V_OCTET):
973 vres->v_type = V_STR;
974 vres->v_str = charstring(*v1->v_octet &
975 ~*v2->v_octet);
976 return;
977 default:
978 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ)
979 *vres = objcall(OBJ_SETMINUS, v1, v2,
980 NULL_VALUE);
981 else
982 *vres = error_value(E_SETMINUS);
983 }
984 }
985
986
987 /*
988 * "#" a value, for strings and octets returns the number of nonzero bits
989 * in the value; user-defined for an object
990 */
991 void
992 contentvalue(VALUE *vp, VALUE *vres)
993 {
994 long count;
995 unsigned char u;
996
997 vres->v_type = V_NUM;
998 vres->v_subtype = V_NOSUBTYPE;
999 count = 0;
1000 switch (vp->v_type) {
1001 case V_STR:
1002 count = stringcontent(vp->v_str);
1003 break;
1004 case V_OCTET:
1005 for (u = *vp->v_octet; u; u >>= 1)
1006 count += (u & 1);
1007 break;
1008 case V_NUM:
1009 count = zpopcnt(vp->v_num->num, 1);
1010 break;
1011 case V_OBJ:
1012 *vres = objcall(OBJ_CONTENT, vp, NULL_VALUE,
1013 NULL_VALUE);
1014 return;
1015 default:
1016 *vres = error_value(E_CONTENT);
1017 return;
1018 }
1019 vres->v_num = itoq(count);
1020 }
1021
1022
1023 /*
1024 * Approximate numbers by multiples of v2 using rounding criterion v3.
1025 * Result is placed in the indicated location.
1026 */
1027 void
1028 apprvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
1029 {
1030 NUMBER *e;
1031 long R = 0;
1032 NUMBER *q1, *q2;
1033 COMPLEX *c;
1034
1035 vres->v_type = v1->v_type;
1036 vres->v_subtype = V_NOSUBTYPE;
1037 if (v1->v_type <= 0)
1038 return;
1039
1040 e = NULL;
1041 switch(v2->v_type) {
1042 case V_NUM: e = v2->v_num;
1043 break;
1044 case V_NULL: e = conf->epsilon;
1045 break;
1046 default:
1047 *vres = error_value(E_APPR2);
1048 return;
1049 }
1050 switch(v3->v_type) {
1051 case V_NUM: if (qisfrac(v3->v_num)) {
1052 *vres = error_value(E_APPR3);
1053 return;
1054 }
1055 R = qtoi(v3->v_num);
1056 break;
1057 case V_NULL: R = conf->appr;
1058 break;
1059 default:
1060 *vres = error_value(E_APPR3);
1061 return;
1062 }
1063
1064 if (qiszero(e)) {
1065 copyvalue(v1, vres);
1066 return;
1067 }
1068 switch (v1->v_type) {
1069 case V_NUM:
1070 vres->v_num = qmappr(v1->v_num, e, R);
1071 return;
1072 case V_MAT:
1073 vres->v_mat = matappr(v1->v_mat, v2, v3);
1074 return;
1075 case V_LIST:
1076 vres->v_list = listappr(v1->v_list, v2, v3);
1077 return;
1078 case V_COM:
1079 q1 = qmappr(v1->v_com->real, e, R);
1080 q2 = qmappr(v1->v_com->imag, e, R);
1081 if (qiszero(q2)) {
1082 vres->v_type = V_NUM;
1083 vres->v_num = q1;
1084 qfree(q2);
1085 return;
1086 }
1087 c = comalloc();
1088 qfree(c->real);
1089 qfree(c->imag);
1090 c->real = q1;
1091 c->imag = q2;
1092 vres->v_com = c;
1093 return;
1094 default:
1095 *vres = error_value(E_APPR);
1096 return;
1097 }
1098 }
1099
1100
1101 /*
1102 * Round numbers to number of decimals specified by v2, type of rounding
1103 * specified by v3. Result placed in location vres.
1104 */
1105 void
1106 roundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
1107 {
1108 NUMBER *q1, *q2;
1109 COMPLEX *c;
1110 long places, rnd;
1111
1112 vres->v_type = v1->v_type;
1113 vres->v_subtype = V_NOSUBTYPE;
1114 if (v1->v_type == V_MAT) {
1115 vres->v_mat = matround(v1->v_mat, v2, v3);
1116 return;
1117 }
1118 if (v1->v_type == V_LIST) {
1119 vres->v_list = listround(v1->v_list, v2, v3);
1120 return;
1121 }
1122 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
1123 *vres = objcall(OBJ_ROUND, v1, v2, v3);
1124 return;
1125 }
1126 places = 0;
1127 switch (v2->v_type) {
1128 case V_NUM:
1129 if (qisfrac(v2->v_num)) {
1130 *vres = error_value(E_ROUND2);
1131 return;
1132 }
1133 places = qtoi(v2->v_num);
1134 break;
1135 case V_NULL:
1136 break;
1137 default:
1138 *vres = error_value(E_ROUND2);
1139 return;
1140 }
1141 rnd = 0;
1142 switch (v3->v_type) {
1143 case V_NUM:
1144 if (qisfrac(v3->v_num)) {
1145 *vres = error_value(E_ROUND3);
1146 return;
1147 }
1148 rnd = qtoi(v3->v_num);
1149 break;
1150 case V_NULL:
1151 rnd = conf->round;
1152 break;
1153 default:
1154 *vres = error_value(E_ROUND3);
1155 return;
1156 }
1157 switch(v1->v_type) {
1158 case V_NUM:
1159 vres->v_num = qround(v1->v_num, places, rnd);
1160 return;
1161 case V_COM:
1162 q1 = qround(v1->v_com->real, places, rnd);
1163 q2 = qround(v1->v_com->imag, places, rnd);
1164 if (qiszero(q2)) {
1165 vres->v_type = V_NUM;
1166 vres->v_num = q1;
1167 qfree(q2);
1168 return;
1169 }
1170 c = comalloc();
1171 qfree(c->real);
1172 qfree(c->imag);
1173 c->real = q1;
1174 c->imag = q2;
1175 vres->v_com = c;
1176 return;
1177 default:
1178 if (v1->v_type <= 0)
1179 return;
1180 *vres = error_value(E_ROUND);
1181 return;
1182 }
1183 }
1184
1185
1186
1187 /*
1188 * Round numbers to number of binary digits specified by v2, type of rounding
1189 * specified by v3. Result placed in location vres.
1190 */
1191 void
1192 broundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
1193 {
1194 NUMBER *q1, *q2;
1195 COMPLEX *c;
1196 long places, rnd;
1197
1198 vres->v_type = v1->v_type;
1199 vres->v_subtype = V_NOSUBTYPE;
1200 if (v1->v_type == V_MAT) {
1201 vres->v_mat = matbround(v1->v_mat, v2, v3);
1202 return;
1203 }
1204 if (v1->v_type == V_LIST) {
1205 vres->v_list = listbround(v1->v_list, v2, v3);
1206 return;
1207 }
1208 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
1209 *vres = objcall(OBJ_BROUND, v1, v2, v3);
1210 return;
1211 }
1212 places = 0;
1213 switch (v2->v_type) {
1214 case V_NUM:
1215 if (qisfrac(v2->v_num)) {
1216 *vres = error_value(E_BROUND2);
1217 return;
1218 }
1219 places = qtoi(v2->v_num);
1220 break;
1221 case V_NULL:
1222 break;
1223 default:
1224 *vres = error_value(E_BROUND2);
1225 return;
1226 }
1227 rnd = 0;
1228 switch (v3->v_type) {
1229 case V_NUM:
1230 if (qisfrac(v3->v_num)) {
1231 *vres = error_value(E_BROUND3);
1232 return;
1233 }
1234 rnd = qtoi(v3->v_num);
1235 break;
1236 case V_NULL:
1237 rnd = conf->round;
1238 break;
1239 default:
1240 *vres = error_value(E_BROUND3);
1241 return;
1242 }
1243 switch(v1->v_type) {
1244 case V_NUM:
1245 vres->v_num = qbround(v1->v_num, places, rnd);
1246 return;
1247 case V_COM:
1248 q1 = qbround(v1->v_com->real, places, rnd);
1249 q2 = qbround(v1->v_com->imag, places, rnd);
1250 if (qiszero(q2)) {
1251 vres->v_type = V_NUM;
1252 vres->v_num = q1;
1253 qfree(q2);
1254 return;
1255 }
1256 c = comalloc();
1257 qfree(c->real);
1258 qfree(c->imag);
1259 c->real = q1;
1260 c->imag = q2;
1261 vres->v_com = c;
1262 return;
1263 default:
1264 if (v1->v_type <= 0)
1265 return;
1266 *vres = error_value(E_BROUND);
1267 return;
1268 }
1269 }
1270
1271 /*
1272 * Take the integer part of an arbitrary value.
1273 * Result is placed in the indicated location.
1274 */
1275 void
1276 intvalue(VALUE *vp, VALUE *vres)
1277 {
1278 COMPLEX *c;
1279
1280 vres->v_type = vp->v_type;
1281 vres->v_subtype = V_NOSUBTYPE;
1282 switch (vp->v_type) {
1283 case V_NUM:
1284 if (qisint(vp->v_num))
1285 vres->v_num = qlink(vp->v_num);
1286 else
1287 vres->v_num = qint(vp->v_num);
1288 return;
1289 case V_COM:
1290 if (cisint(vp->v_com)) {
1291 vres->v_com = clink(vp->v_com);
1292 return;
1293 }
1294 vres->v_com = c_int(vp->v_com);
1295 c = vres->v_com;
1296 if (cisreal(c)) {
1297 vres->v_num = qlink(c->real);
1298 vres->v_type = V_NUM;
1299 comfree(c);
1300 }
1301 return;
1302 case V_MAT:
1303 vres->v_mat = matint(vp->v_mat);
1304 return;
1305 case V_OBJ:
1306 *vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
1307 return;
1308 default:
1309 if (vp->v_type <= 0)
1310 return;
1311 *vres = error_value(E_INT);
1312 return;
1313 }
1314 }
1315
1316
1317 /*
1318 * Take the fractional part of an arbitrary value.
1319 * Result is placed in the indicated location.
1320 */
1321 void
1322 fracvalue(VALUE *vp, VALUE *vres)
1323 {
1324 COMPLEX *c;
1325
1326 vres->v_type = vp->v_type;
1327 vres->v_subtype = V_NOSUBTYPE;
1328 switch (vp->v_type) {
1329 case V_NUM:
1330 if (qisint(vp->v_num))
1331 vres->v_num = qlink(&_qzero_);
1332 else
1333 vres->v_num = qfrac(vp->v_num);
1334 return;
1335 case V_COM:
1336 if (cisint(vp->v_com)) {
1337 vres->v_num = clink(&_qzero_);
1338 vres->v_type = V_NUM;
1339 return;
1340 }
1341 vres->v_com = c_frac(vp->v_com);
1342 c = vres->v_com;
1343 if (cisreal(c)) {
1344 vres->v_num = qlink(c->real);
1345 vres->v_type = V_NUM;
1346 comfree(c);
1347 }
1348 return;
1349 case V_MAT:
1350 vres->v_mat = matfrac(vp->v_mat);
1351 return;
1352 case V_OBJ:
1353 *vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
1354 return;
1355 default:
1356 if (vp->v_type < 0)
1357 return;
1358 *vres = error_value(E_FRAC);
1359 return;
1360 }
1361 }
1362
1363
1364 /*
1365 * Increment an arbitrary value by one.
1366 * Result is placed in the indicated location.
1367 */
1368 void
1369 incvalue(VALUE *vp, VALUE *vres)
1370 {
1371 vres->v_type = vp->v_type;
1372 switch (vp->v_type) {
1373 case V_NUM:
1374 vres->v_num = qinc(vp->v_num);
1375 break;
1376 case V_COM:
1377 vres->v_com = c_addq(vp->v_com, &_qone_);
1378 break;
1379 case V_OBJ:
1380 *vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
1381 break;
1382 case V_OCTET:
1383 *vres->v_octet = *vp->v_octet + 1;
1384 break;
1385 case V_OPTR:
1386 vres->v_octet = vp->v_octet + 1;
1387 break;
1388 case V_VPTR:
1389 vres->v_addr = vp->v_addr + 1;
1390 break;
1391 default:
1392 if (vp->v_type > 0)
1393 *vres = error_value(E_INCV);
1394 break;
1395 }
1396 vres->v_subtype = vp->v_subtype;
1397 }
1398
1399
1400 /*
1401 * Decrement an arbitrary value by one.
1402 * Result is placed in the indicated location.
1403 */
1404 void
1405 decvalue(VALUE *vp, VALUE *vres)
1406 {
1407 vres->v_type = vp->v_type;
1408 switch (vp->v_type) {
1409 case V_NUM:
1410 vres->v_num = qdec(vp->v_num);
1411 break;
1412 case V_COM:
1413 vres->v_com = c_addq(vp->v_com, &_qnegone_);
1414 break;
1415 case V_OBJ:
1416 *vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
1417 break;
1418 case V_OCTET:
1419 *vres->v_octet = *vp->v_octet - 1;
1420 break;
1421 case V_OPTR:
1422 vres->v_octet = vp->v_octet - 1;
1423 break;
1424 case V_VPTR:
1425 vres->v_addr = vp->v_addr - 1;
1426 break;
1427 default:
1428 if (vp->v_type >= 0)
1429 *vres = error_value(E_DECV);
1430 break;
1431 }
1432 vres->v_subtype = vp->v_subtype;
1433 }
1434
1435
1436 /*
1437 * Produce the 'conjugate' of an arbitrary value.
1438 * Result is placed in the indicated location.
1439 * (Example: complex conjugate.)
1440 */
1441 void
1442 conjvalue(VALUE *vp, VALUE *vres)
1443 {
1444 vres->v_type = vp->v_type;
1445 vres->v_subtype = V_NOSUBTYPE;
1446 switch (vp->v_type) {
1447 case V_NUM:
1448 vres->v_num = qlink(vp->v_num);
1449 return;
1450 case V_COM:
1451 vres->v_com = comalloc();
1452 qfree(vres->v_com->real);
1453 qfree(vres->v_com->imag)
1454 vres->v_com->real = qlink(vp->v_com->real);
1455 vres->v_com->imag = qneg(vp->v_com->imag);
1456 return;
1457 case V_MAT:
1458 vres->v_mat = matconj(vp->v_mat);
1459 return;
1460 case V_OBJ:
1461 *vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
1462 return;
1463 default:
1464 if (vp->v_type <= 0) {
1465 vres->v_type = vp->v_type;
1466 return;
1467 }
1468 *vres = error_value(E_CONJ);
1469 return;
1470 }
1471 }
1472
1473
1474 /*
1475 * Take the square root of an arbitrary value within the specified error.
1476 * Result is placed in the indicated location.
1477 */
1478 void
1479 sqrtvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
1480 {
1481 NUMBER *q, *tmp;
1482 COMPLEX *c;
1483 long R;
1484
1485 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
1486 *vres = objcall(OBJ_SQRT, v1, v2, v3);
1487 return;
1488 }
1489 vres->v_type = v1->v_type;
1490 vres->v_subtype = V_NOSUBTYPE;
1491 if (v1->v_type <= 0) {
1492 vres->v_type = v1->v_type;
1493 return;
1494 }
1495 if (v2->v_type == V_NULL) {
1496 q = conf->epsilon;
1497 } else {
1498 if (v2->v_type != V_NUM || qiszero(v2->v_num)) {
1499 *vres = error_value(E_SQRT2);
1500 return;
1501 }
1502 q = v2->v_num;
1503 }
1504 if (v3->v_type == V_NULL) {
1505 R = conf->sqrt;
1506 } else {
1507 if (v3->v_type != V_NUM || qisfrac(v3->v_num)) {
1508 *vres = error_value(E_SQRT3);
1509 return;
1510 }
1511 R = qtoi(v3->v_num);
1512 }
1513 switch (v1->v_type) {
1514 case V_NUM:
1515 if (!qisneg(v1->v_num)) {
1516 vres->v_num = qsqrt(v1->v_num, q, R);
1517 return;
1518 }
1519 tmp = qneg(v1->v_num);
1520 c = comalloc();
1521 qfree(c->imag);
1522 c->imag = qsqrt(tmp, q, R);
1523 qfree(tmp);
1524 vres->v_com = c;
1525 vres->v_type = V_COM;
1526 break;
1527 case V_COM:
1528 vres->v_com = c_sqrt(v1->v_com, q, R);
1529 break;
1530 default:
1531 *vres = error_value(E_SQRT);
1532 return;
1533 }
1534 c = vres->v_com;
1535 if (cisreal(c)) {
1536 vres->v_num = qlink(c->real);
1537 vres->v_type = V_NUM;
1538 comfree(c);
1539 }
1540 }
1541
1542
1543 /*
1544 * Take the Nth root of an arbitrary value within the specified error.
1545 * Result is placed in the indicated location.
1546 *
1547 * given:
1548 * v1 value to take root of
1549 * v2 value specifying root to take
1550 * v3 value specifying error
1551 * vres result
1552 */
1553 void
1554 rootvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
1555 {
1556 NUMBER *q2, *q3;
1557 COMPLEX ctmp;
1558 COMPLEX *c;
1559
1560 vres->v_subtype = V_NOSUBTYPE;
1561 if (v1->v_type <= 0) {
1562 vres->v_type = v1->v_type;
1563 return;
1564 }
1565 if (v2->v_type != V_NUM) {
1566 *vres = error_value(E_ROOT2);
1567 return;
1568 }
1569 q2 = v2->v_num;
1570 if (qisneg(q2) || qiszero(q2) || qisfrac(q2)) {
1571 *vres = error_value(E_ROOT2);
1572 return;
1573 }
1574 if (v3->v_type != V_NUM || qiszero(v3->v_num)) {
1575 *vres = error_value(E_ROOT3);
1576 return;
1577 }
1578 q3 = v3->v_num;
1579 switch (v1->v_type) {
1580 case V_NUM:
1581 if (!qisneg(v1->v_num)) {
1582 vres->v_num = qroot(v1->v_num, q2, q3);
1583 if (vres->v_num == NULL)
1584 *vres = error_value(E_ROOT4);
1585 vres->v_type = V_NUM;
1586 return;
1587 }
1588 ctmp.real = v1->v_num;
1589 ctmp.imag = &_qzero_;
1590 ctmp.links = 1;
1591 c = c_root(&ctmp, q2, q3);
1592 break;
1593 case V_COM:
1594 c = c_root(v1->v_com, q2, q3);
1595 break;
1596 case V_OBJ:
1597 *vres = objcall(OBJ_ROOT, v1, v2, v3);
1598 return;
1599 default:
1600 *vres = error_value(E_ROOT);
1601 return;
1602 }
1603 if (c == NULL) {
1604 *vres = error_value(E_ROOT4);
1605 return;
1606 }
1607 vres->v_com = c;
1608 vres->v_type = V_COM;
1609 if (cisreal(c)) {
1610 vres->v_num = qlink(c->real);
1611 vres->v_type = V_NUM;
1612 comfree(c);
1613 }
1614 }
1615
1616
1617 /*
1618 * Take the absolute value of an arbitrary value within the specified error.
1619 * Result is placed in the indicated location.
1620 */
1621 void
1622 absvalue(VALUE *v1, VALUE *v2, VALUE *vres)
1623 {
1624 STATIC NUMBER *q;
1625
1626 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
1627 *vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
1628 return;
1629 }
1630 vres->v_subtype = V_NOSUBTYPE;
1631 if (v1->v_type <= 0) {
1632 vres->v_type = v1->v_type;
1633 return;
1634 }
1635 switch (v1->v_type) {
1636 case V_NUM:
1637 if (qisneg(v1->v_num))
1638 q = qneg(v1->v_num);
1639 else
1640 q = qlink(v1->v_num);
1641 break;
1642 case V_COM:
1643 if (v2->v_type != V_NUM || qiszero(v2->v_num)) {
1644 *vres = error_value(E_ABS2);
1645 return;
1646 }
1647 q = qhypot(v1->v_com->real, v1->v_com->imag, v2->v_num);
1648 break;
1649 default:
1650 *vres = error_value(E_ABS);
1651 return;
1652 }
1653 vres->v_num = q;
1654 vres->v_type = V_NUM;
1655 }
1656
1657
1658 /*
1659 * Calculate the norm of an arbitrary value.
1660 * Result is placed in the indicated location.
1661 * The norm is the square of the absolute value.
1662 */
1663 void
1664 normvalue(VALUE *vp, VALUE *vres)
1665 {
1666 NUMBER *q1, *q2;
1667
1668 vres->v_type = vp->v_type;
1669 vres->v_subtype = V_NOSUBTYPE;
1670 if (vp->v_type <= 0) {
1671 vres->v_type = vp->v_type;
1672 return;
1673 }
1674 switch (vp->v_type) {
1675 case V_NUM:
1676 vres->v_num = qsquare(vp->v_num);
1677 return;
1678 case V_COM:
1679 q1 = qsquare(vp->v_com->real);
1680 q2 = qsquare(vp->v_com->imag);
1681 vres->v_num = qqadd(q1, q2);
1682 vres->v_type = V_NUM;
1683 qfree(q1);
1684 qfree(q2);
1685 return;
1686 case V_OBJ:
1687 *vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
1688 return;
1689 default:
1690 *vres = error_value(E_NORM);
1691 return;
1692 }
1693 }
1694
1695
1696 /*
1697 * Shift a value left or right by the specified number of bits.
1698 * Negative shift value means shift the direction opposite the selected dir.
1699 * Right shifts are defined to lose bits off the low end of the number.
1700 * Result is placed in the indicated location.
1701 *
1702 * given:
1703 * v1 value to shift
1704 * v2 shift amount
1705 * rightshift TRUE if shift right instead of left
1706 * vres result
1707 */
1708 void
1709 shiftvalue(VALUE *v1, VALUE *v2, BOOL rightshift, VALUE *vres)
1710 {
1711 COMPLEX *c;
1712 long n = 0;
1713 unsigned int ch;
1714 VALUE tmp;
1715
1716 vres->v_subtype = V_NOSUBTYPE;
1717 if (v1->v_type <= 0) {
1718 vres->v_type = v1->v_type;
1719 return;
1720 }
1721 if ((v2->v_type != V_NUM) || (qisfrac(v2->v_num))) {
1722 *vres = error_value(E_SHIFT2);
1723 return;
1724 }
1725 if (v1->v_type != V_OBJ) {
1726 if (zge31b(v2->v_num->num)) {
1727 *vres = error_value(E_SHIFT2);
1728 return;
1729 }
1730 n = qtoi(v2->v_num);
1731 }
1732 if (rightshift)
1733 n = -n;
1734 vres->v_type = v1->v_type;
1735 switch (v1->v_type) {
1736 case V_NUM:
1737 if (qisfrac(v1->v_num)) {
1738 *vres = error_value(E_SHIFT);
1739 return;
1740 }
1741 vres->v_num = qshift(v1->v_num, n);
1742 return;
1743 case V_COM:
1744 if (qisfrac(v1->v_com->real) ||
1745 qisfrac(v1->v_com->imag)) {
1746 *vres = error_value(E_SHIFT);
1747 return;
1748 }
1749 c = c_shift(v1->v_com, n);
1750 if (!cisreal(c)) {
1751 vres->v_com = c;
1752 return;
1753 }
1754 vres->v_num = qlink(c->real);
1755 vres->v_type = V_NUM;
1756 comfree(c);
1757 return;
1758 case V_MAT:
1759 vres->v_mat = matshift(v1->v_mat, n);
1760 return;
1761 case V_STR:
1762 vres->v_str = stringshift(v1->v_str, n);
1763 if (vres->v_str == NULL)
1764 *vres = error_value(E_STRSHIFT);
1765 return;
1766 case V_OCTET:
1767 vres->v_type = V_STR;
1768 if (n >= 8 || n <= -8)
1769 ch = 0;
1770 else if (n >= 0)
1771 ch = (unsigned int) *v1->v_octet << n;
1772 else
1773 ch = (unsigned int) *v1->v_octet >> -n;
1774 vres->v_str = charstring(ch);
1775 return;
1776 case V_OBJ:
1777 if (!rightshift) {
1778 *vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
1779 return;
1780 }
1781 tmp.v_num = qneg(v2->v_num);
1782 tmp.v_type = V_NUM;
1783 *vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
1784 qfree(tmp.v_num);
1785 return;
1786 default:
1787 *vres = error_value(E_SHIFT);
1788 return;
1789 }
1790 }
1791
1792
1793 /*
1794 * Scale a value by a power of two.
1795 * Result is placed in the indicated location.
1796 */
1797 void
1798 scalevalue(VALUE *v1, VALUE *v2, VALUE *vres)
1799 {
1800 long n = 0;
1801
1802 vres->v_subtype = V_NOSUBTYPE;
1803 if (v1->v_type <= 0) {
1804 vres->v_type = v1->v_type;
1805 return;
1806 }
1807 if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) {
1808 *vres = error_value(E_SCALE2);
1809 return;
1810 }
1811 if (v1->v_type != V_OBJ) {
1812 if (zge31b(v2->v_num->num)) {
1813 *vres = error_value(E_SCALE2);
1814 return;
1815 }
1816 n = qtoi(v2->v_num);
1817 }
1818 vres->v_type = v1->v_type;
1819 switch (v1->v_type) {
1820 case V_NUM:
1821 vres->v_num = qscale(v1->v_num, n);
1822 return;
1823 case V_COM:
1824 vres->v_com = c_scale(v1->v_com, n);
1825 return;
1826 case V_MAT:
1827 vres->v_mat = matscale(v1->v_mat, n);
1828 return;
1829 case V_OBJ:
1830 *vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
1831 return;
1832 default:
1833 *vres = error_value(E_SCALE);
1834 return;
1835 }
1836 }
1837
1838
1839 /*
1840 * Raise a value to an power.
1841 * Result is placed in the indicated location.
1842 */
1843 void
1844 powvalue(VALUE *v1, VALUE *v2, VALUE *vres)
1845 {
1846 NUMBER *real_v2; /* real part of v2 */
1847 COMPLEX *c;
1848
1849 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
1850 *vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
1851 return;
1852 }
1853 vres->v_type = v1->v_type;
1854 vres->v_subtype = V_NOSUBTYPE;
1855 if (v1->v_type <= 0 && v1->v_type != -E_1OVER0)
1856 return;
1857 if (v2->v_type <= 0) {
1858 vres->v_type = v2->v_type;
1859 return;
1860 }
1861 real_v2 = v2->v_num;
1862
1863 /* case: raising to a real power */
1864 switch (v2->v_type) {
1865 case V_NUM:
1866
1867 /* deal with the division by 0 value */
1868 if (v1->v_type == -E_1OVER0) {
1869 if (qisneg(real_v2)) {
1870 vres->v_type = V_NUM;
1871 vres->v_num = qlink(&_qzero_);
1872 } else {
1873 vres->v_type = -E_1OVER0;
1874 }
1875 break;
1876 }
1877
1878 /* raise something with a real exponent */
1879 switch (v1->v_type) {
1880 case V_NUM:
1881 if (qiszero(v1->v_num)) {
1882 if (qisneg(real_v2)) {
1883 *vres = error_value(E_1OVER0);
1884 break;
1885 }
1886 /* 0 ^ non-neg is zero, including 0^0 */
1887 vres->v_type = V_NUM;
1888 vres->v_num = qlink(&_qzero_);
1889 } else if (qisint(real_v2)) {
1890 vres->v_num = qpowi(v1->v_num, real_v2);
1891 } else {
1892 vres->v_type = V_NUM;
1893 vres->v_num = qlink(&_qzero_);
1894 powervalue(v1, v2, NULL, vres);
1895 }
1896 break;
1897 case V_COM:
1898 if (qisint(real_v2)) {
1899 vres->v_com = c_powi(v1->v_com, real_v2);
1900 } else {
1901 vres->v_type = V_NUM;
1902 vres->v_num = qlink(&_qzero_);
1903 powervalue(v1, v2, NULL, vres);
1904 }
1905 if (vres->v_type == V_COM) {
1906 c = vres->v_com;
1907 if (!cisreal(c))
1908 break;
1909 vres->v_num = qlink(c->real);
1910 vres->v_type = V_NUM;
1911 comfree(c);
1912 }
1913 break;
1914 case V_MAT:
1915 vres->v_mat = matpowi(v1->v_mat, real_v2);
1916 break;
1917 default:
1918 *vres = error_value(E_POWI);
1919 break;
1920 }
1921 break;
1922
1923 case V_COM:
1924
1925 /* deal with the division by 0 value */
1926 if (v1->v_type == -E_1OVER0) {
1927 if (cisreal(v2->v_com) && qisneg(real_v2)) {
1928 vres->v_type = V_NUM;
1929 vres->v_num = qlink(&_qzero_);
1930 } else {
1931 vres->v_type = -E_1OVER0;
1932 }
1933 break;
1934 }
1935
1936 /* raise something with a real exponent */
1937 switch (v1->v_type) {
1938 case V_NUM:
1939 if (qiszero(v1->v_num)) {
1940 if (cisreal(v2->v_com) && qisneg(real_v2)) {
1941 *vres = error_value(E_1OVER0);
1942 break;
1943 }
1944 /*
1945 * 0 ^ real non-neg is zero
1946 * 0 ^ complex is zero
1947 */
1948 vres->v_type = V_NUM;
1949 vres->v_num = qlink(&_qzero_);
1950 }
1951 if (cisreal(v2->v_com) && qisint(real_v2)) {
1952 vres->v_num = qpowi(v1->v_num, real_v2);
1953 } else {
1954 vres->v_type = V_NUM;
1955 vres->v_num = qlink(&_qzero_);
1956 powervalue(v1, v2, NULL, vres);
1957 }
1958 if (vres->v_type == V_COM) {
1959 c = vres->v_com;
1960 if (!cisreal(c))
1961 break;
1962 vres->v_num = qlink(c->real);
1963 vres->v_type = V_NUM;
1964 comfree(c);
1965 }
1966 break;
1967 case V_COM:
1968 if (cisreal(v2->v_com) && qisint(real_v2)) {
1969 vres->v_com = c_powi(v1->v_com, real_v2);
1970 } else {
1971 vres->v_type = V_NUM;
1972 vres->v_num = qlink(&_qzero_);
1973 powervalue(v1, v2, NULL, vres);
1974 }
1975 if (vres->v_type == V_COM) {
1976 c = vres->v_com;
1977 if (!cisreal(c))
1978 break;
1979 vres->v_num = qlink(c->real);
1980 vres->v_type = V_NUM;
1981 comfree(c);
1982 }
1983 break;
1984 default:
1985 *vres = error_value(E_POWI);
1986 break;
1987 }
1988 break;
1989
1990 /* unspported exponent type */
1991 default:
1992 *vres = error_value(E_POWI2);
1993 break;
1994 }
1995 return;
1996 }
1997
1998
1999 /*
2000 * Raise one value to another value's power, within the specified error.
2001 * Result is placed in the indicated location. If v3 is NULL, the
2002 * value conf->epsiilon is used.
2003 */
2004 void
2005 powervalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
2006 {
2007 NUMBER *epsilon;
2008 COMPLEX *c, ctmp1, ctmp2;
2009
2010 vres->v_subtype = V_NOSUBTYPE;
2011 if (v1->v_type <= 0) {
2012 vres->v_type = v1->v_type;
2013 return;
2014 }
2015 if (v1->v_type != V_NUM && v1->v_type != V_COM) {
2016 *vres = error_value(E_POWER);
2017 return;
2018 }
2019 if (v2->v_type != V_NUM && v2->v_type != V_COM) {
2020 *vres = error_value(E_POWER2);
2021 return;
2022 }
2023
2024 /* NULL epsilon means use built-in epslion value */
2025 if (v3 == NULL) {
2026 epsilon = conf->epsilon;
2027 } else {
2028 if (v3->v_type != V_NUM || qiszero(v3->v_num)) {
2029 *vres = error_value(E_POWER3);
2030 return;
2031 }
2032 epsilon = v3->v_num;
2033 }
2034 if (qiszero(epsilon)) {
2035 *vres = error_value(E_POWER3);
2036 return;
2037 }
2038
2039 switch (TWOVAL(v1->v_type, v2->v_type)) {
2040 case TWOVAL(V_NUM, V_NUM):
2041 if (qisneg(v1->v_num)) {
2042 ctmp1.real = v1->v_num;
2043 ctmp1.imag = &_qzero_;
2044 ctmp1.links = 1;
2045 ctmp2.real = v2->v_num;
2046 ctmp2.imag = &_qzero_;
2047 ctmp2.links = 1;
2048 c = c_power(&ctmp1, &ctmp2, epsilon);
2049 break;
2050 }
2051 vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
2052 vres->v_type = V_NUM;
2053 if (vres->v_num == NULL)
2054 *vres = error_value(E_POWER4);
2055 return;
2056 case TWOVAL(V_NUM, V_COM):
2057 ctmp1.real = v1->v_num;
2058 ctmp1.imag = &_qzero_;
2059 ctmp1.links = 1;
2060 c = c_power(&ctmp1, v2->v_com, epsilon);
2061 break;
2062 case TWOVAL(V_COM, V_NUM):
2063 ctmp2.real = v2->v_num;
2064 ctmp2.imag = &_qzero_;
2065 ctmp2.links = 1;
2066 c = c_power(v1->v_com, &ctmp2, epsilon);
2067 break;
2068 case TWOVAL(V_COM, V_COM):
2069 c = c_power(v1->v_com, v2->v_com, epsilon);
2070 break;
2071 default:
2072 *vres = error_value(E_POWER);
2073 return;
2074 }
2075 /*
2076 * Here for any complex result.
2077 */
2078 vres->v_type = V_COM;
2079 vres->v_com = c;
2080 if (cisreal(c)) {
2081 vres->v_num = qlink(c->real);
2082 vres->v_type = V_NUM;
2083 comfree(c);
2084 }
2085 }
2086
2087
2088 /*
2089 * Divide one arbitrary value by another one.
2090 * Result is placed in the indicated location.
2091 */
2092 void
2093 divvalue(VALUE *v1, VALUE *v2, VALUE *vres)
2094 {
2095 COMPLEX *c;
2096 COMPLEX ctmp;
2097 NUMBER *q;
2098 VALUE tmpval;
2099
2100 vres->v_type = v1->v_type;
2101 vres->v_subtype = V_NOSUBTYPE;
2102 if (v1->v_type <= 0)
2103 return;
2104 if (v2->v_type <= 0) {
2105 if (testvalue(v1) && v2->v_type == -E_1OVER0) {
2106 vres->v_type = V_NUM;
2107 vres->v_num = qlink(&_qzero_);
2108 }
2109 else
2110 vres->v_type = v2->v_type;
2111 return;
2112 }
2113 if (!testvalue(v2)) {
2114 if (testvalue(v1))
2115 *vres = error_value(E_1OVER0);
2116 else
2117 *vres = error_value(E_0OVER0);
2118 return;
2119 }
2120 vres->v_type = v1->v_type;
2121 switch (TWOVAL(v1->v_type, v2->v_type)) {
2122 case TWOVAL(V_NUM, V_NUM):
2123 vres->v_num = qqdiv(v1->v_num, v2->v_num);
2124 return;
2125 case TWOVAL(V_COM, V_NUM):
2126 vres->v_com = c_divq(v1->v_com, v2->v_num);
2127 return;
2128 case TWOVAL(V_NUM, V_COM):
2129 if (qiszero(v1->v_num)) {
2130 vres->v_num = qlink(&_qzero_);
2131 return;
2132 }
2133 ctmp.real = v1->v_num;
2134 ctmp.imag = &_qzero_;
2135 ctmp.links = 1;
2136 vres->v_com = c_div(&ctmp, v2->v_com);
2137 vres->v_type = V_COM;
2138 return;
2139 case TWOVAL(V_COM, V_COM):
2140 vres->v_com = c_div(v1->v_com, v2->v_com);
2141 c = vres->v_com;
2142 if (cisreal(c)) {
2143 vres->v_num = qlink(c->real);
2144 vres->v_type = V_NUM;
2145 comfree(c);
2146 }
2147 return;
2148 case TWOVAL(V_MAT, V_NUM):
2149 case TWOVAL(V_MAT, V_COM):
2150 invertvalue(v2, &tmpval);
2151 vres->v_mat = matmulval(v1->v_mat, &tmpval);
2152 freevalue(&tmpval);
2153 return;
2154 case TWOVAL(V_STR, V_NUM):
2155 q = qinv(v2->v_num);
2156 vres->v_str = stringmul(q, v1->v_str);
2157 qfree(q);
2158 if (vres->v_str == NULL)
2159 *vres = error_value(E_DIV);
2160 return;
2161 default:
2162 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) {
2163 *vres = error_value(E_DIV);
2164 return;
2165 }
2166 *vres = objcall(OBJ_DIV, v1, v2, NULL_VALUE);
2167 return;
2168 }
2169 }
2170
2171
2172 /*
2173 * Divide one arbitrary value by another one keeping only the integer part.
2174 * Result is placed in the indicated location.
2175 */
2176 void
2177 quovalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
2178 {
2179 COMPLEX *c;
2180 NUMBER *q1, *q2;
2181 long rnd;
2182
2183 vres->v_type = v1->v_type;
2184 vres->v_subtype = V_NOSUBTYPE;
2185 if (v1->v_type <= 0)
2186 return;
2187
2188 if (v1->v_type == V_MAT) {
2189 vres->v_mat = matquoval(v1->v_mat, v2, v3);
2190 return;
2191 }
2192 if (v1->v_type == V_LIST) {
2193 vres->v_list = listquo(v1->v_list, v2, v3);
2194 return;
2195 }
2196 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
2197 *vres = objcall(OBJ_QUO, v1, v2, v3);
2198 return;
2199 }
2200 if (v2->v_type <= 0) {
2201 vres->v_type = v2->v_type;
2202 return;
2203 }
2204 if (v2->v_type != V_NUM) {
2205 *vres = error_value(E_QUO2);
2206 return;
2207 }
2208 rnd = 0;
2209 switch (v3->v_type) {
2210 case V_NUM:
2211 if (qisfrac(v3->v_num)) {
2212 *vres = error_value(E_QUO3);
2213 return;
2214 }
2215 rnd = qtoi(v3->v_num);
2216 break;
2217 case V_NULL:
2218 rnd = conf->quo;
2219 break;
2220 default:
2221 *vres = error_value(E_QUO3);
2222 return;
2223 }
2224 switch (v1->v_type) {
2225 case V_NUM:
2226 vres->v_num = qquo(v1->v_num, v2->v_num, rnd);
2227 return;
2228 case V_COM:
2229 q1 = qquo(v1->v_com->real, v2->v_num, rnd);
2230 q2 = qquo(v1->v_com->imag, v2->v_num, rnd);
2231 if (qiszero(q2)) {
2232 qfree(q2);
2233 vres->v_type = V_NUM;
2234 vres->v_num = q1;
2235 return;
2236 }
2237 c = comalloc();
2238 qfree(c->real);
2239 qfree(c->imag);
2240 c->real = q1;
2241 c->imag = q2;
2242 vres->v_com = c;
2243 return;
2244 default:
2245 *vres = error_value(E_QUO);
2246 return;
2247 }
2248 }
2249
2250
2251 /*
2252 * Divide one arbitrary value by another one keeping only the remainder.
2253 * Result is placed in the indicated location.
2254 */
2255 void
2256 modvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres)
2257 {
2258 COMPLEX *c;
2259 NUMBER *q1, *q2;
2260 long rnd;
2261
2262 vres->v_type = v1->v_type;
2263 vres->v_subtype = V_NOSUBTYPE;
2264 if (v1->v_type <= 0)
2265 return;
2266
2267 if (v1->v_type == V_MAT) {
2268 vres->v_mat = matmodval(v1->v_mat, v2, v3);
2269 return;
2270 }
2271 if (v1->v_type == V_LIST) {
2272 vres->v_list = listmod(v1->v_list, v2, v3);
2273 return;
2274 }
2275 if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) {
2276 *vres = objcall(OBJ_MOD, v1, v2, v3);
2277 return;
2278 }
2279 if (v2->v_type <= 0) {
2280 vres->v_type = v2->v_type;
2281 return;
2282 }
2283 if (v2->v_type != V_NUM) {
2284 *vres = error_value(E_MOD2);
2285 return;
2286 }
2287 rnd = 0;
2288 switch (v3->v_type) {
2289 case V_NUM:
2290 if (qisfrac(v3->v_num)) {
2291 *vres = error_value(E_MOD3);
2292 return;
2293 }
2294 rnd = qtoi(v3->v_num);
2295 break;
2296 case V_NULL:
2297 rnd = conf->mod;
2298 break;
2299 default:
2300 *vres = error_value(E_MOD3);
2301 return;
2302 }
2303 switch (v1->v_type) {
2304 case V_NUM:
2305 vres->v_num = qmod(v1->v_num, v2->v_num, rnd);
2306 return;
2307 case V_COM:
2308 q1 = qmod(v1->v_com->real, v2->v_num, rnd);
2309 q2 = qmod(v1->v_com->imag, v2->v_num, rnd);
2310 if (qiszero(q2)) {
2311 qfree(q2);
2312 vres->v_type = V_NUM;
2313 vres->v_num = q1;
2314 return;
2315 }
2316 c = comalloc();
2317 qfree(c->real);
2318 qfree(c->imag);
2319 c->real = q1;
2320 c->imag = q2;
2321 vres->v_com = c;
2322 return;
2323 default:
2324 *vres = error_value(E_MOD);
2325 return;
2326 }
2327 }
2328
2329
2330 /*
2331 * Test an arbitrary value to see if it is equal to "zero".
2332 * The definition of zero varies depending on the value type. For example,
2333 * the null string is "zero", and a matrix with zero values is "zero".
2334 * Returns TRUE if value is not equal to zero.
2335 */
2336 BOOL
2337 testvalue(VALUE *vp)
2338 {
2339 VALUE val;
2340 LISTELEM *ep;
2341 int i;
2342
2343 switch (vp->v_type) {
2344 case V_NUM:
2345 return !qiszero(vp->v_num);
2346 case V_COM:
2347 return !ciszero(vp->v_com);
2348 case V_STR:
2349 return stringtest(vp->v_str);
2350 case V_MAT:
2351 return mattest(vp->v_mat);
2352 case V_LIST:
2353 for (ep = vp->v_list->l_first; ep; ep = ep->e_next) {
2354 if (testvalue(&ep->e_value))
2355 return TRUE;
2356 }
2357 return FALSE;
2358 case V_ASSOC:
2359 return (vp->v_assoc->a_count != 0);
2360 case V_FILE:
2361 return validid(vp->v_file);
2362 case V_NULL:
2363 break; /* hack to get gcc on SunOS to be quiet */
2364 case V_OBJ:
2365 val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
2366 return (val.v_int != 0);
2367 case V_BLOCK:
2368 for (i=0; i < vp->v_block->datalen; ++i) {
2369 if (vp->v_block->data[i]) {
2370 return TRUE;
2371 }
2372 }
2373 return FALSE;
2374 case V_OCTET:
2375 return (*vp->v_octet != 0);
2376 case V_NBLOCK:
2377 if (vp->v_nblock->blk->data == NULL)
2378 return FALSE;
2379 for (i=0; i < vp->v_nblock->blk->datalen; ++i) {
2380 if (vp->v_nblock->blk->data[i]) {
2381 return TRUE;
2382 }
2383 }
2384 return FALSE;
2385 default:
2386 return TRUE;
2387 }
2388 /* hack to get gcc on SunOS to be quiet */
2389 return FALSE;
2390 }
2391
2392
2393 /*
2394 * Compare two values for equality.
2395 * Returns TRUE if the two values differ.
2396 */
2397 BOOL
2398 comparevalue(VALUE *v1, VALUE *v2)
2399 {
2400 int r = FALSE;
2401 VALUE val;
2402
2403 if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
2404 val = objcall(OBJ_CMP, v1, v2, NULL_VALUE);
2405 return (val.v_int != 0);
2406 }
2407 if (v1 == v2)
2408 return FALSE;
2409 if (v1->v_type == V_OCTET) {
2410 if (v2->v_type == V_OCTET)
2411 return (*v1->v_octet != *v2->v_octet);
2412 if (v2->v_type == V_STR)
2413 return (*v1->v_octet != (OCTET) *v2->v_str->s_str)
2414 || (v2->v_str->s_len != 1);
2415 if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
2416 qisneg(v2->v_num) || v2->v_num->num.len > 1)
2417 return TRUE;
2418 return (*v2->v_num->num.v != *v1->v_octet);
2419 }
2420 if (v2->v_type == V_OCTET)
2421 return comparevalue(v2, v1);
2422 if (v1->v_type != v2->v_type)
2423 return TRUE;
2424 if (v1->v_type <= 0)
2425 return FALSE;
2426 switch (v1->v_type) {
2427 case V_NUM:
2428 r = qcmp(v1->v_num, v2->v_num);
2429 break;
2430 case V_COM:
2431 r = c_cmp(v1->v_com, v2->v_com);
2432 break;
2433 case V_STR:
2434 r = stringcmp(v1->v_str, v2->v_str);
2435 break;
2436 case V_MAT:
2437 r = matcmp(v1->v_mat, v2->v_mat);
2438 break;
2439 case V_LIST:
2440 r = listcmp(v1->v_list, v2->v_list);
2441 break;
2442 case V_ASSOC:
2443 r = assoccmp(v1->v_assoc, v2->v_assoc);
2444 break;
2445 case V_FILE:
2446 r = (v1->v_file != v2->v_file);
2447 break;
2448 case V_RAND:
2449 r = randcmp(v1->v_rand, v2->v_rand);
2450 break;
2451 case V_RANDOM:
2452 r = randomcmp(v1->v_random, v2->v_random);
2453 break;
2454 case V_CONFIG:
2455 r = config_cmp(v1->v_config, v2->v_config);
2456 break;
2457 case V_HASH:
2458 r = hash_cmp(v1->v_hash, v2->v_hash);
2459 break;
2460 case V_BLOCK:
2461 r = blk_cmp(v1->v_block, v2->v_block);
2462 break;
2463 case V_OCTET:
2464 r = (v1->v_octet != v2->v_octet);
2465 break;
2466 case V_NBLOCK:
2467 return (v1->v_nblock != v2->v_nblock);
2468 case V_VPTR:
2469 return (v1->v_addr != v2->v_addr);
2470 case V_OPTR:
2471 return (v1->v_octet != v2->v_octet);
2472 case V_SPTR:
2473 return (v1->v_str != v2->v_str);
2474 case V_NPTR:
2475 return (v1->v_num != v2->v_num);
2476 default:
2477 math_error("Illegal values for comparevalue");
2478 /*NOTREACHED*/
2479 }
2480 return (r != 0);
2481 }
2482
2483 BOOL
2484 acceptvalue(VALUE *v1, VALUE *v2)
2485 {
2486 long index;
2487 FUNC *fp;
2488 BOOL ret;
2489
2490 index = adduserfunc("accept");
2491 fp = findfunc(index);
2492 if (fp) {
2493 ++stack;
2494 stack->v_type = V_ADDR;
2495 stack->v_subtype = V_NOSUBTYPE;
2496 stack->v_addr = v1;
2497 ++stack;
2498 stack->v_type = V_ADDR;
2499 stack->v_subtype = V_NOSUBTYPE;
2500 stack->v_addr = v2;
2501 calculate(fp, 2);
2502 ret = testvalue(stack);
2503 freevalue(stack--);
2504 return ret;
2505 }
2506 return (!comparevalue(v1, v2));
2507 }
2508
2509
2510 BOOL
2511 precvalue(VALUE *v1, VALUE *v2)
2512 {
2513 VALUE val;
2514 long index;
2515 int r = 0;
2516 FUNC *fp;
2517 BOOL ret;
2518
2519 index = adduserfunc("precedes");
2520 fp = findfunc(index);
2521 if (fp) {
2522 ++stack;
2523 stack->v_type = V_ADDR;
2524 stack->v_subtype = V_NOSUBTYPE;
2525 stack->v_addr = v1;
2526 ++stack;
2527 stack->v_type = V_ADDR;
2528 stack->v_subtype = V_NOSUBTYPE;
2529 stack->v_addr = v2;
2530 calculate(fp, 2);
2531 ret = testvalue(stack);
2532 freevalue(stack--);
2533 return ret;
2534 }
2535 relvalue(v1, v2, &val);
2536 if ((val.v_type == V_NUM && qisneg(val.v_num)) ||
2537 (val.v_type == V_COM && qisneg(val.v_com->imag)))
2538 r = 1;
2539 if (val.v_type == V_NULL)
2540 r = (v1->v_type < v2->v_type);
2541 freevalue(&val);
2542 return r;
2543 }
2544
2545
2546 VALUE
2547 signval(int r)
2548 {
2549 VALUE val;
2550
2551 val.v_type = V_NUM;
2552 val.v_subtype = V_NOSUBTYPE;
2553 if (r > 0)
2554 val.v_num = qlink(&_qone_);
2555 else if (r < 0)
2556 val.v_num = qlink(&_qnegone_);
2557 else
2558 val.v_num = qlink(&_qzero_);
2559 return val;
2560 }
2561
2562
2563 /*
2564 * Compare two values for their relative values.
2565 * Result is placed in the indicated location.
2566 */
2567 void
2568 relvalue(VALUE *v1, VALUE *v2, VALUE *vres)
2569 {
2570 int r = 0;
2571 int i = 0;
2572 NUMBER *q;
2573 COMPLEX *c;
2574
2575 vres->v_subtype = V_NOSUBTYPE;
2576 vres->v_type = V_NULL;
2577 if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
2578 *vres = objcall(OBJ_REL, v1, v2, NULL_VALUE);
2579 return;
2580 }
2581 switch(v1->v_type) {
2582 case V_NUM:
2583 switch(v2->v_type) {
2584 case V_NUM:
2585 r = qrel(v1->v_num, v2->v_num);
2586 break;
2587 case V_OCTET:
2588 q = itoq((long) *v2->v_octet);
2589 r = qrel(v1->v_num, q);
2590 qfree(q);
2591 break;
2592 case V_COM:
2593 r = qrel(v1->v_num, v2->v_com->real);
2594 i = qrel(&_qzero_, v2->v_com->imag);
2595 break;
2596 default:
2597 return;
2598 }
2599 break;
2600 case V_COM:
2601 switch(v2->v_type) {
2602 case V_NUM:
2603 r = qrel(v1->v_com->real, v2->v_num);
2604 i = qrel(v1->v_com->imag, &_qzero_);
2605 break;
2606 case V_COM:
2607 r = qrel(v1->v_com->real, v2->v_com->real);
2608 i = qrel(v1->v_com->imag, v2->v_com->imag);
2609 break;
2610 case V_OCTET:
2611 q = itoq((long) *v2->v_octet);
2612 r = qrel(v1->v_com->real, q);
2613 qfree(q);
2614 i = qrel(v1->v_com->imag, &_qzero_);
2615 break;
2616 default:
2617 return;
2618 }
2619 break;
2620 case V_STR:
2621 switch(v2->v_type) {
2622 case V_STR:
2623 r = stringrel(v1->v_str, v2->v_str);
2624 break;
2625 case V_OCTET:
2626 r = (unsigned char) *v1->v_str->s_str
2627 - *v2->v_octet;
2628 if (r == 0) {
2629 if (v1->v_str->s_len == 0)
2630 r = -1;
2631 else
2632 r = (v1->v_str->s_len > 1);
2633 }
2634 break;
2635 default:
2636 return;
2637 }
2638 break;
2639 case V_OCTET:
2640 switch(v2->v_type) {
2641 case V_NUM:
2642 q = itoq((long) *v1->v_octet);
2643 r = qrel(q, v2->v_num);
2644 qfree(q);
2645 break;
2646 case V_COM:
2647 q = itoq((long) *v1->v_octet);
2648 r = qrel(q, v2->v_com->real);
2649 qfree(q);
2650 i = qrel(&_qzero_, v2->v_com->imag);
2651 break;
2652 case V_OCTET:
2653 r = *v1->v_octet - *v2->v_octet;
2654 break;
2655 case V_STR:
2656 r = *v1->v_octet -
2657 (unsigned char) *v2->v_str->s_str;
2658 if (r == 0) {
2659 if (v2->v_str->s_len == 0)
2660 r = 1;
2661 else
2662 r = -(v2->v_str->s_len > 1);
2663 }
2664 break;
2665 default:
2666 return;
2667 }
2668 break;
2669 case V_VPTR:
2670 if (v2->v_type != V_VPTR)
2671 return;
2672 r = (v1->v_addr - v2->v_addr);
2673 break;
2674 case V_OPTR:
2675 if (v2->v_type != V_OPTR)
2676 return;
2677 r = (v1->v_octet - v2->v_octet);
2678 break;
2679 default:
2680 return;
2681 }
2682 vres->v_type = V_NUM;
2683 *vres = signval(r);
2684 if (i == 0)
2685 return;
2686 c = comalloc();
2687 qfree(c->real);
2688 c->real = vres->v_num;
2689 *vres = signval(i);
2690 qfree(c->imag);
2691 c->imag = vres->v_num;
2692 vres->v_type = V_COM;
2693 vres->v_com = c;
2694 return;
2695 }
2696
2697
2698 /*
2699 * Find a value representing sign or signs in a value
2700 * Result is placed in the indicated location.
2701 */
2702 void
2703 sgnvalue(VALUE *vp, VALUE *vres)
2704 {
2705 COMPLEX *c;
2706
2707 vres->v_type = vp->v_type;
2708 switch (vp->v_type) {
2709 case V_NUM:
2710 vres->v_num = qsign(vp->v_num);
2711 vres->v_subtype = vp->v_subtype;
2712 return;
2713 case V_COM:
2714 c = comalloc();
2715 qfree(c->real);
2716 qfree(c->imag);
2717 c->real = qsign(vp->v_com->real);
2718 c->imag = qsign(vp->v_com->imag);
2719 vres->v_com = c;
2720 vres->v_type = V_COM;
2721 vres->v_subtype = V_NOSUBTYPE;
2722 return;
2723 case V_OCTET:
2724 vres->v_type = V_NUM;
2725 vres->v_subtype = V_NOSUBTYPE;
2726 vres->v_num = itoq((long) (*vp->v_octet != 0));
2727 return;
2728 case V_OBJ:
2729 *vres = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
2730 return;
2731 default:
2732 if (vp->v_type > 0)
2733 *vres = error_value(E_SGN);
2734 return;
2735 }
2736 }
2737
2738
2739 int
2740 userfunc(char *fname, VALUE *vp)
2741 {
2742 FUNC *fp;
2743
2744 fp = findfunc(adduserfunc(fname));
2745 if (fp == NULL)
2746 return 0;
2747 ++stack;
2748 stack->v_addr = vp;
2749 stack->v_type = V_ADDR;
2750 stack->v_subtype = V_NOSUBTYPE;
2751 calculate(fp, 1);
2752 freevalue(stack--);
2753 return 1;
2754 }
2755
2756
2757 /*
2758 * Print the value of a descriptor in one of several formats.
2759 * If flags contains PRINT_SHORT, then elements of arrays and lists
2760 * will not be printed. If flags contains PRINT_UNAMBIG, then quotes
2761 * are placed around strings and the null value is explicitly printed.
2762 */
2763 void
2764 printvalue(VALUE *vp, int flags)
2765 {
2766 NUMBER *qtemp;
2767 int type;
2768
2769 type = vp->v_type;
2770 if (type < 0) {
2771 if (userfunc("error_print", vp))
2772 return;
2773 if (-type >= E__BASE)
2774 math_fmt("Error %d", -type);
2775 else
2776 math_fmt("System error %d", -type);
2777 return;
2778 }
2779 switch (type) {
2780 case V_NUM:
2781 qprintnum(vp->v_num, MODE_DEFAULT);
2782 if (conf->traceflags & TRACE_LINKS)
2783 math_fmt("#%ld", vp->v_num->links);
2784 break;
2785 case V_COM:
2786 comprint(vp->v_com);
2787 if (conf->traceflags & TRACE_LINKS)
2788 math_fmt("##%ld", vp->v_com->links);
2789 break;
2790 case V_STR:
2791 if (flags & PRINT_UNAMBIG)
2792 math_chr('\"');
2793 math_str(vp->v_str->s_str);
2794 if (flags & PRINT_UNAMBIG)
2795 math_chr('\"');
2796 break;
2797 case V_NULL:
2798 if (flags & PRINT_UNAMBIG)
2799 math_str("NULL");
2800 break;
2801 case V_OBJ:
2802 (void) objcall(OBJ_PRINT, vp, NULL_VALUE, NULL_VALUE);
2803 break;
2804 case V_LIST:
2805 if (!userfunc("list_print", vp))
2806 listprint(vp->v_list,
2807 ((flags & PRINT_SHORT) ? 0L : conf->maxprint));
2808 break;
2809 case V_ASSOC:
2810 assocprint(vp->v_assoc,
2811 ((flags & PRINT_SHORT) ? 0L : conf->maxprint));
2812 break;
2813 case V_MAT:
2814 if (!userfunc("mat_print", vp))
2815 matprint(vp->v_mat,
2816 ((flags & PRINT_SHORT) ? 0L : conf->maxprint));
2817 break;
2818 case V_FILE:
2819 if (!userfunc("file_print", vp))
2820 printid(vp->v_file, flags);
2821 break;
2822 case V_RAND:
2823 randprint(vp->v_rand, flags);
2824 break;
2825 case V_RANDOM:
2826 randomprint(vp->v_random, flags);
2827 break;
2828 case V_CONFIG:
2829 config_print(vp->v_config);
2830 break;
2831 case V_HASH:
2832 hash_print(vp->v_hash);
2833 break;
2834 case V_BLOCK:
2835 if (!userfunc("blk_print", vp))
2836 blk_print(vp->v_block);
2837 break;
2838 case V_OCTET:
2839 if (userfunc("octet_print", vp))
2840 break;
2841 qtemp = itoq((long) *vp->v_octet);
2842 qprintnum(qtemp, MODE_DEFAULT);
2843 qfree(qtemp);
2844 break;
2845 case V_OPTR:
2846 math_fmt("o-ptr: %p", vp->v_octet);
2847 break;
2848 case V_VPTR:
2849 math_fmt("v-ptr: %p", vp->v_addr);
2850 break;
2851 case V_SPTR:
2852 math_fmt("s_ptr: %p", vp->v_str);
2853 break;
2854 case V_NPTR:
2855 math_fmt("n_ptr: %p", vp->v_num);
2856 break;
2857 case V_NBLOCK:
2858 if (!userfunc("nblk_print", vp))
2859 nblock_print(vp->v_nblock);
2860 break;
2861 default:
2862 math_error("Printing unrecognized type of value");
2863 /*NOTREACHED*/
2864 }
2865 }
2866
2867 /*
2868 * Print an exact text representation of a value
2869 */
2870 void
2871 printestr(VALUE *vp)
2872 {
2873 LISTELEM *ep;
2874 MATRIX *mp;
2875 OBJECT *op;
2876 BLOCK *bp;
2877 int mode;
2878 long i, min, max;
2879 USB8 *cp;
2880
2881 if (vp->v_type < 0) {
2882 math_fmt("error(%d)", -vp->v_type);
2883 return;
2884 }
2885 switch(vp->v_type) {
2886 case V_NULL:
2887 math_str("\"\"");
2888 return;
2889 case V_STR:
2890 math_chr('"');
2891 strprint(vp->v_str);
2892 math_chr('"');
2893 return;
2894 case V_NUM:
2895 qprintnum(vp->v_num, MODE_FRAC);
2896 return;
2897 case V_COM:
2898 mode = math_setmode(MODE_FRAC);
2899 comprint(vp->v_com);
2900 math_setmode(mode);
2901 return;
2902 case V_LIST:
2903 math_str("list(");
2904 ep = vp->v_list->l_first;
2905 if (ep) {
2906 printestr(&ep->e_value);
2907 while ((ep = ep->e_next)) {
2908 math_chr(',');
2909 printestr(&ep->e_value);
2910 }
2911 }
2912 math_chr(')');
2913 return;
2914 case V_MAT:
2915 mp = vp->v_mat;
2916 if (mp->m_dim == 0)
2917 math_str("(mat[])");
2918 else {
2919 math_str("mat[");
2920 for (i = 0; i < mp->m_dim; i++) {
2921 min = mp->m_min[i];
2922 max = mp->m_max[i];
2923 if (i > 0)
2924 math_chr(',');
2925 if (min)
2926 math_fmt("%ld:%ld", min, max);
2927 else
2928 math_fmt("%ld", max + 1);
2929 }
2930 math_chr(']');
2931 }
2932 i = mp->m_size;
2933 vp = mp->m_table;
2934 break;
2935 case V_OBJ:
2936 op = vp->v_obj;
2937 math_fmt("obj %s",objtypename(op->o_actions->oa_index));
2938 i = op->o_actions->oa_count;
2939 vp = op->o_table;
2940 break;
2941 case V_BLOCK:
2942 case V_NBLOCK:
2943 math_str("blk(");
2944 if (vp->v_type == V_BLOCK)
2945 bp = vp->v_block;
2946 else {
2947 math_fmt("\"%s\",", vp->v_nblock->name);
2948 bp = vp->v_nblock->blk;
2949 }
2950 i = bp->datalen;
2951 math_fmt("%ld,%ld)", i, bp->blkchunk);
2952 cp = bp->data;
2953 if (i > 0) {
2954 math_str("={");
2955 math_fmt("%d", *cp);
2956 while (--i > 0) {
2957 math_chr(',');
2958 math_fmt("%d", *++cp);
2959 }
2960 math_chr('}');
2961 }
2962 return;
2963
2964 default:
2965 math_str("\"???\"");
2966 return;
2967 }
2968 if (i > 0) {
2969 math_str("={");
2970 printestr(vp);
2971 while (--i > 0) {
2972 math_chr(',');
2973 printestr(++vp);
2974 }
2975 math_chr('}');
2976 }
2977 }
2978
2979
2980 /*
2981 * config_print - print a configuration value
2982 *
2983 * given:
2984 * cfg what to print
2985 */
2986 void
2987 config_print(CONFIG *cfg)
2988 {
2989 NAMETYPE *cp;
2990 VALUE tmp;
2991 int tab_over; /* TRUE => ok move over one tab stop */
2992 size_t len;
2993
2994 /*
2995 * firewall
2996 */
2997 if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL ||
2998 cfg->prompt2 == NULL) {
2999 math_error("CONFIG value is invalid");
3000 /*NOTREACHED*/
3001 }
3002
3003 /*
3004 * print each element
3005 */
3006 tab_over = FALSE;
3007 for (cp = configs; cp->name; cp++) {
3008
3009 /* skip if special all or duplicate maxerr value */
3010 if (cp->type == CONFIG_ALL || strcmp(cp->name, "maxerr") == 0 ||
3011 strcmp(cp->name, "ctrl-d") == 0)
3012 continue;
3013
3014 /* print tab if allowed */
3015 if (tab_over) {
3016 math_str("\t");
3017 } else if (conf->tab_ok) {
3018 tab_over = TRUE; /* tab next time */
3019 }
3020
3021 /* print name and spaces */
3022 math_fmt("%s", cp->name);
3023 len = 16 - strlen(cp->name);
3024 while (len-- > 0)
3025 math_str(" ");
3026
3027 /* print value */
3028 config_value(cfg, cp->type, &tmp);
3029 printvalue(&tmp, PRINT_SHORT | PRINT_UNAMBIG);
3030 freevalue(&tmp);
3031 if ((cp+1)->name)
3032 math_str("\n");
3033 }
3034 }
A place to share codes with mates