projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
BSD 4_4_Lite1 development
[unix-history] / usr / src / contrib / calc-2.9.3t6 / value.c
CommitLineData
198b5bf9
C		 1/*
2 * Copyright (c) 1994 David I. Bell
3 * Permission is granted to use, distribute, or modify this source,
4 * provided that this copyright notice remains intact.
5 *
6 * Generic value manipulation routines.
7 */
8
9#include "value.h"
10#include "opcodes.h"
11#include "func.h"
12#include "symbol.h"
13#include "string.h"
14
15
16/*
17 * Free a value and set its type to undefined.
18 */
19void
20freevalue(vp)
21 register VALUE *vp; /* value to be freed */
22{
23 int type; /* type of value being freed */
24
25 type = vp->v_type;
26 vp->v_type = V_NULL;
27 switch (type) {
28 case V_NULL:
29 case V_ADDR:
30 case V_FILE:
31 break;
32 case V_STR:
33 if (vp->v_subtype == V_STRALLOC)
34 free(vp->v_str);
35 break;
36 case V_NUM:
37 qfree(vp->v_num);
38 break;
39 case V_COM:
40 comfree(vp->v_com);
41 break;
42 case V_MAT:
43 matfree(vp->v_mat);
44 break;
45 case V_LIST:
46 listfree(vp->v_list);
47 break;
48 case V_ASSOC:
49 assocfree(vp->v_assoc);
50 break;
51 case V_OBJ:
52 objfree(vp->v_obj);
53 break;
54 default:
55 math_error("Freeing unknown value type");
56 }
57 vp->v_subtype = V_NOSUBTYPE;
58}
59
60
61/*
62 * Copy a value from one location to another.
63 * This overwrites the specified new value without checking it.
64 */
65void
66copyvalue(oldvp, newvp)
67 register VALUE *oldvp; /* value to be copied from */
68 register VALUE *newvp; /* value to be copied into */
69{
70 newvp->v_type = V_NULL;
71 switch (oldvp->v_type) {
72 case V_NULL:
73 break;
74 case V_FILE:
75 newvp->v_file = oldvp->v_file;
76 break;
77 case V_NUM:
78 newvp->v_num = qlink(oldvp->v_num);
79 break;
80 case V_COM:
81 newvp->v_com = clink(oldvp->v_com);
82 break;
83 case V_STR:
84 newvp->v_str = oldvp->v_str;
85 if (oldvp->v_subtype == V_STRALLOC) {
86 newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
87 if (newvp->v_str == NULL)
88 math_error("Cannot get memory for string copy");
89 strcpy(newvp->v_str, oldvp->v_str);
90 }
91 break;
92 case V_MAT:
93 newvp->v_mat = matcopy(oldvp->v_mat);
94 break;
95 case V_LIST:
96 newvp->v_list = listcopy(oldvp->v_list);
97 break;
98 case V_ASSOC:
99 newvp->v_assoc = assoccopy(oldvp->v_assoc);
100 break;
101 case V_ADDR:
102 newvp->v_addr = oldvp->v_addr;
103 break;
104 case V_OBJ:
105 newvp->v_obj = objcopy(oldvp->v_obj);
106 break;
107 default:
108 math_error("Copying unknown value type");
109 }
110 if (oldvp->v_type == V_STR) {
111 newvp->v_subtype = oldvp->v_subtype;
112 } else {
113 newvp->v_subtype = V_NOSUBTYPE;
114 }
115 newvp->v_type = oldvp->v_type;
116
117}
118
119
120/*
121 * Negate an arbitrary value.
122 * Result is placed in the indicated location.
123 */
124void
125negvalue(vp, vres)
126 VALUE *vp, *vres;
127{
128 vres->v_type = V_NULL;
129 switch (vp->v_type) {
130 case V_NUM:
131 vres->v_num = qneg(vp->v_num);
132 vres->v_type = V_NUM;
133 return;
134 case V_COM:
135 vres->v_com = cneg(vp->v_com);
136 vres->v_type = V_COM;
137 return;
138 case V_MAT:
139 vres->v_mat = matneg(vp->v_mat);
140 vres->v_type = V_MAT;
141 return;
142 case V_OBJ:
143 *vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
144 return;
145 default:
146 math_error("Illegal value for negation");
147 }
148}
149
150
151/*
152 * Add two arbitrary values together.
153 * Result is placed in the indicated location.
154 */
155void
156addvalue(v1, v2, vres)
157 VALUE *v1, *v2, *vres;
158{
159 COMPLEX *c;
160
161 vres->v_type = V_NULL;
162 switch (TWOVAL(v1->v_type, v2->v_type)) {
163 case TWOVAL(V_NUM, V_NUM):
164 vres->v_num = qadd(v1->v_num, v2->v_num);
165 vres->v_type = V_NUM;
166 return;
167 case TWOVAL(V_COM, V_NUM):
168 vres->v_com = caddq(v1->v_com, v2->v_num);
169 vres->v_type = V_COM;
170 return;
171 case TWOVAL(V_NUM, V_COM):
172 vres->v_com = caddq(v2->v_com, v1->v_num);
173 vres->v_type = V_COM;
174 return;
175 case TWOVAL(V_COM, V_COM):
176 vres->v_com = cadd(v1->v_com, v2->v_com);
177 vres->v_type = V_COM;
178 c = vres->v_com;
179 if (!cisreal(c))
180 return;
181 vres->v_num = qlink(c->real);
182 vres->v_type = V_NUM;
183 comfree(c);
184 return;
185 case TWOVAL(V_MAT, V_MAT):
186 vres->v_mat = matadd(v1->v_mat, v2->v_mat);
187 vres->v_type = V_MAT;
188 return;
189 default:
190 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
191 math_error("Non-compatible values for add");
192 *vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
193 return;
194 }
195}
196
197
198/*
199 * Subtract one arbitrary value from another one.
200 * Result is placed in the indicated location.
201 */
202void
203subvalue(v1, v2, vres)
204 VALUE *v1, *v2, *vres;
205{
206 COMPLEX *c;
207
208 vres->v_type = V_NULL;
209 switch (TWOVAL(v1->v_type, v2->v_type)) {
210 case TWOVAL(V_NUM, V_NUM):
211 vres->v_num = qsub(v1->v_num, v2->v_num);
212 vres->v_type = V_NUM;
213 return;
214 case TWOVAL(V_COM, V_NUM):
215 vres->v_com = csubq(v1->v_com, v2->v_num);
216 vres->v_type = V_COM;
217 return;
218 case TWOVAL(V_NUM, V_COM):
219 c = csubq(v2->v_com, v1->v_num);
220 vres->v_com = cneg(c);
221 comfree(c);
222 vres->v_type = V_COM;
223 return;
224 case TWOVAL(V_COM, V_COM):
225 vres->v_com = csub(v1->v_com, v2->v_com);
226 vres->v_type = V_COM;
227 c = vres->v_com;
228 if (!cisreal(c))
229 return;
230 vres->v_num = qlink(c->real);
231 vres->v_type = V_NUM;
232 comfree(c);
233 return;
234 case TWOVAL(V_MAT, V_MAT):
235 vres->v_mat = matsub(v1->v_mat, v2->v_mat);
236 vres->v_type = V_MAT;
237 return;
238 default:
239 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
240 math_error("Non-compatible values for subtract");
241 *vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
242 return;
243 }
244}
245
246
247/*
248 * Multiply two arbitrary values together.
249 * Result is placed in the indicated location.
250 */
251void
252mulvalue(v1, v2, vres)
253 VALUE *v1, *v2, *vres;
254{
255 COMPLEX *c;
256
257 vres->v_type = V_NULL;
258 switch (TWOVAL(v1->v_type, v2->v_type)) {
259 case TWOVAL(V_NUM, V_NUM):
260 vres->v_num = qmul(v1->v_num, v2->v_num);
261 vres->v_type = V_NUM;
262 return;
263 case TWOVAL(V_COM, V_NUM):
264 vres->v_com = cmulq(v1->v_com, v2->v_num);
265 vres->v_type = V_COM;
266 break;
267 case TWOVAL(V_NUM, V_COM):
268 vres->v_com = cmulq(v2->v_com, v1->v_num);
269 vres->v_type = V_COM;
270 break;
271 case TWOVAL(V_COM, V_COM):
272 vres->v_com = cmul(v1->v_com, v2->v_com);
273 vres->v_type = V_COM;
274 break;
275 case TWOVAL(V_MAT, V_MAT):
276 vres->v_mat = matmul(v1->v_mat, v2->v_mat);
277 vres->v_type = V_MAT;
278 return;
279 case TWOVAL(V_MAT, V_NUM):
280 case TWOVAL(V_MAT, V_COM):
281 vres->v_mat = matmulval(v1->v_mat, v2);
282 vres->v_type = V_MAT;
283 return;
284 case TWOVAL(V_NUM, V_MAT):
285 case TWOVAL(V_COM, V_MAT):
286 vres->v_mat = matmulval(v2->v_mat, v1);
287 vres->v_type = V_MAT;
288 return;
289 default:
290 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
291 math_error("Non-compatible values for multiply");
292 *vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
293 return;
294 }
295 c = vres->v_com;
296 if (cisreal(c)) {
297 vres->v_num = qlink(c->real);
298 vres->v_type = V_NUM;
299 comfree(c);
300 }
301}
302
303
304/*
305 * Square an arbitrary value.
306 * Result is placed in the indicated location.
307 */
308void
309squarevalue(vp, vres)
310 VALUE *vp, *vres;
311{
312 COMPLEX *c;
313
314 vres->v_type = V_NULL;
315 switch (vp->v_type) {
316 case V_NUM:
317 vres->v_num = qsquare(vp->v_num);
318 vres->v_type = V_NUM;
319 return;
320 case V_COM:
321 vres->v_com = csquare(vp->v_com);
322 vres->v_type = V_COM;
323 c = vres->v_com;
324 if (!cisreal(c))
325 return;
326 vres->v_num = qlink(c->real);
327 vres->v_type = V_NUM;
328 comfree(c);
329 return;
330 case V_MAT:
331 vres->v_mat = matsquare(vp->v_mat);
332 vres->v_type = V_MAT;
333 return;
334 case V_OBJ:
335 *vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
336 return;
337 default:
338 math_error("Illegal value for squaring");
339 }
340}
341
342
343/*
344 * Invert an arbitrary value.
345 * Result is placed in the indicated location.
346 */
347void
348invertvalue(vp, vres)
349 VALUE *vp, *vres;
350{
351 vres->v_type = V_NULL;
352 switch (vp->v_type) {
353 case V_NUM:
354 vres->v_num = qinv(vp->v_num);
355 vres->v_type = V_NUM;
356 return;
357 case V_COM:
358 vres->v_com = cinv(vp->v_com);
359 vres->v_type = V_COM;
360 return;
361 case V_MAT:
362 vres->v_mat = matinv(vp->v_mat);
363 vres->v_type = V_MAT;
364 return;
365 case V_OBJ:
366 *vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
367 return;
368 default:
369 math_error("Illegal value for inverting");
370 }
371}
372
373
374/*
375 * Round an arbitrary value to the specified number of decimal places.
376 * Result is placed in the indicated location.
377 */
378void
379roundvalue(v1, v2, vres)
380 VALUE *v1, *v2, *vres;
381{
382 long places = -1;
383 NUMBER *q;
384 COMPLEX *c;
385
386 switch (v2->v_type) {
387 case V_NUM:
388 q = v2->v_num;
389 if (qisfrac(q) || zisbig(q->num))
390 math_error("Bad number of places for round");
391 places = qtoi(q);
392 break;
393 case V_INT:
394 places = v2->v_int;
395 break;
396 default:
397 math_error("Bad value type for places in round");
398 }
399 if (places < 0)
400 math_error("Negative number of places in round");
401 vres->v_type = V_NULL;
402 switch (v1->v_type) {
403 case V_NUM:
404 if (qisint(v1->v_num))
405 vres->v_num = qlink(v1->v_num);
406 else
407 vres->v_num = qround(v1->v_num, places);
408 vres->v_type = V_NUM;
409 return;
410 case V_COM:
411 if (cisint(v1->v_com)) {
412 vres->v_com = clink(v1->v_com);
413 vres->v_type = V_COM;
414 return;
415 }
416 vres->v_com = cround(v1->v_com, places);
417 vres->v_type = V_COM;
418 c = vres->v_com;
419 if (cisreal(c)) {
420 vres->v_num = qlink(c->real);
421 vres->v_type = V_NUM;
422 comfree(c);
423 }
424 return;
425 case V_MAT:
426 vres->v_mat = matround(v1->v_mat, places);
427 vres->v_type = V_MAT;
428 return;
429 case V_OBJ:
430 *vres = objcall(OBJ_ROUND, v1, v2, NULL_VALUE);
431 return;
432 default:
433 math_error("Illegal value for round");
434 }
435}
436
437
438/*
439 * Round an arbitrary value to the specified number of binary places.
440 * Result is placed in the indicated location.
441 */
442void
443broundvalue(v1, v2, vres)
444 VALUE *v1, *v2, *vres;
445{
446 long places = -1;
447 NUMBER *q;
448 COMPLEX *c;
449
450 switch (v2->v_type) {
451 case V_NUM:
452 q = v2->v_num;
453 if (qisfrac(q) || zisbig(q->num))
454 math_error("Bad number of places for bround");
455 places = qtoi(q);
456 break;
457 case V_INT:
458 places = v2->v_int;
459 break;
460 default:
461 math_error("Bad value type for places in bround");
462 }
463 if (places < 0)
464 math_error("Negative number of places in bround");
465 vres->v_type = V_NULL;
466 switch (v1->v_type) {
467 case V_NUM:
468 if (qisint(v1->v_num))
469 vres->v_num = qlink(v1->v_num);
470 else
471 vres->v_num = qbround(v1->v_num, places);
472 vres->v_type = V_NUM;
473 return;
474 case V_COM:
475 if (cisint(v1->v_com)) {
476 vres->v_com = clink(v1->v_com);
477 vres->v_type = V_COM;
478 return;
479 }
480 vres->v_com = cbround(v1->v_com, places);
481 vres->v_type = V_COM;
482 c = vres->v_com;
483 if (cisreal(c)) {
484 vres->v_num = qlink(c->real);
485 vres->v_type = V_NUM;
486 comfree(c);
487 }
488 return;
489 case V_MAT:
490 vres->v_mat = matbround(v1->v_mat, places);
491 vres->v_type = V_MAT;
492 return;
493 case V_OBJ:
494 *vres = objcall(OBJ_BROUND, v1, v2, NULL_VALUE);
495 return;
496 default:
497 math_error("Illegal value for bround");
498 }
499}
500
501
502/*
503 * Take the integer part of an arbitrary value.
504 * Result is placed in the indicated location.
505 */
506void
507intvalue(vp, vres)
508 VALUE *vp, *vres;
509{
510 COMPLEX *c;
511
512 vres->v_type = V_NULL;
513 switch (vp->v_type) {
514 case V_NUM:
515 if (qisint(vp->v_num))
516 vres->v_num = qlink(vp->v_num);
517 else
518 vres->v_num = qint(vp->v_num);
519 vres->v_type = V_NUM;
520 return;
521 case V_COM:
522 if (cisint(vp->v_com)) {
523 vres->v_com = clink(vp->v_com);
524 vres->v_type = V_COM;
525 return;
526 }
527 vres->v_com = cint(vp->v_com);
528 vres->v_type = V_COM;
529 c = vres->v_com;
530 if (cisreal(c)) {
531 vres->v_num = qlink(c->real);
532 vres->v_type = V_NUM;
533 comfree(c);
534 }
535 return;
536 case V_MAT:
537 vres->v_mat = matint(vp->v_mat);
538 vres->v_type = V_MAT;
539 return;
540 case V_OBJ:
541 *vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
542 return;
543 default:
544 math_error("Illegal value for int");
545 }
546}
547
548
549/*
550 * Take the fractional part of an arbitrary value.
551 * Result is placed in the indicated location.
552 */
553void
554fracvalue(vp, vres)
555 VALUE *vp, *vres;
556{
557 vres->v_type = V_NULL;
558 switch (vp->v_type) {
559 case V_NUM:
560 if (qisint(vp->v_num))
561 vres->v_num = qlink(&_qzero_);
562 else
563 vres->v_num = qfrac(vp->v_num);
564 vres->v_type = V_NUM;
565 return;
566 case V_COM:
567 if (cisint(vp->v_com)) {
568 vres->v_num = clink(&_qzero_);
569 vres->v_type = V_NUM;
570 return;
571 }
572 vres->v_com = cfrac(vp->v_com);
573 vres->v_type = V_COM;
574 return;
575 case V_MAT:
576 vres->v_mat = matfrac(vp->v_mat);
577 vres->v_type = V_MAT;
578 return;
579 case V_OBJ:
580 *vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
581 return;
582 default:
583 math_error("Illegal value for frac function");
584 }
585}
586
587
588/*
589 * Increment an arbitrary value by one.
590 * Result is placed in the indicated location.
591 */
592void
593incvalue(vp, vres)
594 VALUE *vp, *vres;
595{
596 switch (vp->v_type) {
597 case V_NUM:
598 vres->v_num = qinc(vp->v_num);
599 vres->v_type = V_NUM;
600 return;
601 case V_COM:
602 vres->v_com = caddq(vp->v_com, &_qone_);
603 vres->v_type = V_COM;
604 return;
605 case V_OBJ:
606 *vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
607 return;
608 default:
609 math_error("Illegal value for incrementing");
610 }
611}
612
613
614/*
615 * Decrement an arbitrary value by one.
616 * Result is placed in the indicated location.
617 */
618void
619decvalue(vp, vres)
620 VALUE *vp, *vres;
621{
622 switch (vp->v_type) {
623 case V_NUM:
624 vres->v_num = qdec(vp->v_num);
625 vres->v_type = V_NUM;
626 return;
627 case V_COM:
628 vres->v_com = caddq(vp->v_com, &_qnegone_);
629 vres->v_type = V_COM;
630 return;
631 case V_OBJ:
632 *vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
633 return;
634 default:
635 math_error("Illegal value for decrementing");
636 }
637}
638
639
640/*
641 * Produce the 'conjugate' of an arbitrary value.
642 * Result is placed in the indicated location.
643 * (Example: complex conjugate.)
644 */
645void
646conjvalue(vp, vres)
647 VALUE *vp, *vres;
648{
649 vres->v_type = V_NULL;
650 switch (vp->v_type) {
651 case V_NUM:
652 vres->v_num = qlink(vp->v_num);
653 vres->v_type = V_NUM;
654 return;
655 case V_COM:
656 vres->v_com = comalloc();
657 vres->v_com->real = qlink(vp->v_com->real);
658 vres->v_com->imag = qneg(vp->v_com->imag);
659 vres->v_type = V_COM;
660 return;
661 case V_MAT:
662 vres->v_mat = matconj(vp->v_mat);
663 vres->v_type = V_MAT;
664 return;
665 case V_OBJ:
666 *vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
667 return;
668 default:
669 math_error("Illegal value for conjugation");
670 }
671}
672
673
674/*
675 * Take the square root of an arbitrary value within the specified error.
676 * Result is placed in the indicated location.
677 */
678void
679sqrtvalue(v1, v2, vres)
680 VALUE *v1, *v2, *vres;
681{
682 NUMBER *q, *tmp;
683 COMPLEX *c;
684
685 if (v2->v_type != V_NUM)
686 math_error("Non-real epsilon for sqrt");
687 q = v2->v_num;
688 if (qisneg(q) || qiszero(q))
689 math_error("Illegal epsilon value for sqrt");
690 switch (v1->v_type) {
691 case V_NUM:
692 if (!qisneg(v1->v_num)) {
693 vres->v_num = qsqrt(v1->v_num, q);
694 vres->v_type = V_NUM;
695 return;
696 }
697 tmp = qneg(v1->v_num);
698 c = comalloc();
699 c->imag = qsqrt(tmp, q);
700 qfree(tmp);
701 vres->v_com = c;
702 vres->v_type = V_COM;
703 break;
704 case V_COM:
705 vres->v_com = csqrt(v1->v_com, q);
706 vres->v_type = V_COM;
707 break;
708 case V_OBJ:
709 *vres = objcall(OBJ_SQRT, v1, v2, NULL_VALUE);
710 return;
711 default:
712 math_error("Bad value for taking square root");
713 }
714 c = vres->v_com;
715 if (cisreal(c)) {
716 vres->v_num = qlink(c->real);
717 vres->v_type = V_NUM;
718 comfree(c);
719 }
720}
721
722
723/*
724 * Take the Nth root of an arbitrary value within the specified error.
725 * Result is placed in the indicated location.
726 */
727void
728rootvalue(v1, v2, v3, vres)
729 VALUE *v1; /* value to take root of */
730 VALUE *v2; /* value specifying root to take */
731 VALUE *v3; /* value specifying error */
732 VALUE *vres;
733{
734 NUMBER *q1, *q2;
735 COMPLEX ctmp;
736
737 if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
738 math_error("Non-real arguments for root");
739 q1 = v2->v_num;
740 q2 = v3->v_num;
741 if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
742 math_error("Non-positive or non-integral root");
743 if (qisneg(q2) || qiszero(q2))
744 math_error("Non-positive epsilon for root");
745 switch (v1->v_type) {
746 case V_NUM:
747 if (!qisneg(v1->v_num) || zisodd(q1->num)) {
748 vres->v_num = qroot(v1->v_num, q1, q2);
749 vres->v_type = V_NUM;
750 return;
751 }
752 ctmp.real = v1->v_num;
753 ctmp.imag = &_qzero_;
754 ctmp.links = 1;
755 vres->v_com = croot(&ctmp, q1, q2);
756 vres->v_type = V_COM;
757 return;
758 case V_COM:
759 vres->v_com = croot(v1->v_com, q1, q2);
760 vres->v_type = V_COM;
761 return;
762 case V_OBJ:
763 *vres = objcall(OBJ_ROOT, v1, v2, v3);
764 return;
765 default:
766 math_error("Taking root of bad value");
767 }
768}
769
770
771/*
772 * Take the absolute value of an arbitrary value within the specified error.
773 * Result is placed in the indicated location.
774 */
775void
776absvalue(v1, v2, vres)
777 VALUE *v1, *v2, *vres;
778{
779 static NUMBER *q;
780 NUMBER *epsilon;
781
782 if (v2->v_type != V_NUM)
783 math_error("Bad epsilon type for abs");
784 epsilon = v2->v_num;
785 if (qiszero(epsilon) || qisneg(epsilon))
786 math_error("Non-positive epsilon for abs");
787 switch (v1->v_type) {
788 case V_NUM:
789 if (qisneg(v1->v_num))
790 q = qneg(v1->v_num);
791 else
792 q = qlink(v1->v_num);
793 break;
794 case V_COM:
795 q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
796 break;
797 case V_OBJ:
798 *vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
799 return;
800 default:
801 math_error("Illegal value for absolute value");
802 }
803 vres->v_num = q;
804 vres->v_type = V_NUM;
805}
806
807
808/*
809 * Calculate the norm of an arbitrary value.
810 * Result is placed in the indicated location.
811 * The norm is the square of the absolute value.
812 */
813void
814normvalue(vp, vres)
815 VALUE *vp, *vres;
816{
817 NUMBER *q1, *q2;
818
819 vres->v_type = V_NULL;
820 switch (vp->v_type) {
821 case V_NUM:
822 vres->v_num = qsquare(vp->v_num);
823 vres->v_type = V_NUM;
824 return;
825 case V_COM:
826 q1 = qsquare(vp->v_com->real);
827 q2 = qsquare(vp->v_com->imag);
828 vres->v_num = qadd(q1, q2);
829 vres->v_type = V_NUM;
830 qfree(q1);
831 qfree(q2);
832 return;
833 case V_OBJ:
834 *vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
835 return;
836 default:
837 math_error("Illegal value for norm");
838 }
839}
840
841
842/*
843 * Shift a value left or right by the specified number of bits.
844 * Negative shift value means shift the direction opposite the selected dir.
845 * Right shifts are defined to lose bits off the low end of the number.
846 * Result is placed in the indicated location.
847 */
848void
849shiftvalue(v1, v2, rightshift, vres)
850 VALUE *v1, *v2, *vres;
851 BOOL rightshift; /* TRUE if shift right instead of left */
852{
853 COMPLEX *c;
854 long n = 0;
855 VALUE tmp;
856
857 if (v2->v_type != V_NUM)
858 math_error("Non-real shift value");
859 if (qisfrac(v2->v_num))
860 math_error("Non-integral shift value");
861 if (v1->v_type != V_OBJ) {
862 if (zisbig(v2->v_num->num))
863 math_error("Very large shift value");
864 n = qtoi(v2->v_num);
865 }
866 if (rightshift)
867 n = -n;
868 switch (v1->v_type) {
869 case V_NUM:
870 vres->v_num = qshift(v1->v_num, n);
871 vres->v_type = V_NUM;
872 return;
873 case V_COM:
874 c = cshift(v1->v_com, n);
875 if (!cisreal(c)) {
876 vres->v_com = c;
877 vres->v_type = V_COM;
878 return;
879 }
880 vres->v_num = qlink(c->real);
881 vres->v_type = V_NUM;
882 comfree(c);
883 return;
884 case V_MAT:
885 vres->v_mat = matshift(v1->v_mat, n);
886 vres->v_type = V_MAT;
887 return;
888 case V_OBJ:
889 if (!rightshift) {
890 *vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
891 return;
892 }
893 tmp.v_num = qneg(v2->v_num);
894 tmp.v_type = V_NUM;
895 *vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
896 qfree(tmp.v_num);
897 return;
898 default:
899 math_error("Bad value for shifting");
900 }
901}
902
903
904/*
905 * Scale a value by a power of two.
906 * Result is placed in the indicated location.
907 */
908void
909scalevalue(v1, v2, vres)
910 VALUE *v1, *v2, *vres;
911{
912 long n = 0;
913
914 if (v2->v_type != V_NUM)
915 math_error("Non-real scaling factor");
916 if (qisfrac(v2->v_num))
917 math_error("Non-integral scaling factor");
918 if (v1->v_type != V_OBJ) {
919 if (zisbig(v2->v_num->num))
920 math_error("Very large scaling factor");
921 n = qtoi(v2->v_num);
922 }
923 switch (v1->v_type) {
924 case V_NUM:
925 vres->v_num = qscale(v1->v_num, n);
926 vres->v_type = V_NUM;
927 return;
928 case V_COM:
929 vres->v_com = cscale(v1->v_com, n);
930 vres->v_type = V_NUM;
931 return;
932 case V_MAT:
933 vres->v_mat = matscale(v1->v_mat, n);
934 vres->v_type = V_MAT;
935 return;
936 case V_OBJ:
937 *vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
938 return;
939 default:
940 math_error("Bad value for scaling");
941 }
942}
943
944
945/*
946 * Raise a value to an integral power.
947 * Result is placed in the indicated location.
948 */
949void
950powivalue(v1, v2, vres)
951 VALUE *v1, *v2, *vres;
952{
953 NUMBER *q;
954 COMPLEX *c;
955
956 vres->v_type = V_NULL;
957 if (v2->v_type != V_NUM)
958 math_error("Raising value to non-real power");
959 q = v2->v_num;
960 if (qisfrac(q))
961 math_error("Raising value to non-integral power");
962 switch (v1->v_type) {
963 case V_NUM:
964 vres->v_num = qpowi(v1->v_num, q);
965 vres->v_type = V_NUM;
966 return;
967 case V_COM:
968 vres->v_com = cpowi(v1->v_com, q);
969 vres->v_type = V_COM;
970 c = vres->v_com;
971 if (!cisreal(c))
972 return;
973 vres->v_num = qlink(c->real);
974 vres->v_type = V_NUM;
975 comfree(c);
976 return;
977 case V_MAT:
978 vres->v_mat = matpowi(v1->v_mat, q);
979 vres->v_type = V_MAT;
980 return;
981 case V_OBJ:
982 *vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
983 return;
984 default:
985 math_error("Illegal value for raising to integer power");
986 }
987}
988
989
990/*
991 * Raise one value to another value's power, within the specified error.
992 * Result is placed in the indicated location.
993 */
994void
995powervalue(v1, v2, v3, vres)
996 VALUE *v1, *v2, *v3, *vres;
997{
998 NUMBER *epsilon;
999 COMPLEX *c, ctmp;
1000
1001 vres->v_type = V_NULL;
1002 if (v3->v_type != V_NUM)
1003 math_error("Non-real epsilon value for power");
1004 epsilon = v3->v_num;
1005 if (qisneg(epsilon) || qiszero(epsilon))
1006 math_error("Non-positive epsilon value for power");
1007 switch (TWOVAL(v1->v_type, v2->v_type)) {
1008 case TWOVAL(V_NUM, V_NUM):
1009 vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
1010 vres->v_type = V_NUM;
1011 return;
1012 case TWOVAL(V_NUM, V_COM):
1013 ctmp.real = v1->v_num;
1014 ctmp.imag = &_qzero_;
1015 ctmp.links = 1;
1016 vres->v_com = cpower(&ctmp, v2->v_com, epsilon);
1017 break;
1018 case TWOVAL(V_COM, V_NUM):
1019 ctmp.real = v2->v_num;
1020 ctmp.imag = &_qzero_;
1021 ctmp.links = 1;
1022 vres->v_com = cpower(v1->v_com, &ctmp, epsilon);
1023 break;
1024 case TWOVAL(V_COM, V_COM):
1025 vres->v_com = cpower(v1->v_com, v2->v_com, epsilon);
1026 break;
1027 default:
1028 math_error("Illegal value for raising to power");
1029 }
1030 /*
1031 * Here for any complex result.
1032 */
1033 vres->v_type = V_COM;
1034 c = vres->v_com;
1035 if (!cisreal(c))
1036 return;
1037 vres->v_num = qlink(c->real);
1038 vres->v_type = V_NUM;
1039 comfree(c);
1040}
1041
1042
1043/*
1044 * Divide one arbitrary value by another one.
1045 * Result is placed in the indicated location.
1046 */
1047void
1048divvalue(v1, v2, vres)
1049 VALUE *v1, *v2, *vres;
1050{
1051 COMPLEX *c;
1052 COMPLEX ctmp;
1053 VALUE tmpval;
1054
1055 vres->v_type = V_NULL;
1056 switch (TWOVAL(v1->v_type, v2->v_type)) {
1057 case TWOVAL(V_NUM, V_NUM):
1058 vres->v_num = qdiv(v1->v_num, v2->v_num);
1059 vres->v_type = V_NUM;
1060 return;
1061 case TWOVAL(V_COM, V_NUM):
1062 vres->v_com = cdivq(v1->v_com, v2->v_num);
1063 vres->v_type = V_COM;
1064 return;
1065 case TWOVAL(V_NUM, V_COM):
1066 if (qiszero(v1->v_num)) {
1067 vres->v_num = qlink(&_qzero_);
1068 vres->v_type = V_NUM;
1069 return;
1070 }
1071 ctmp.real = v1->v_num;
1072 ctmp.imag = &_qzero_;
1073 ctmp.links = 1;
1074 vres->v_com = cdiv(&ctmp, v2->v_com);
1075 vres->v_type = V_COM;
1076 return;
1077 case TWOVAL(V_COM, V_COM):
1078 vres->v_com = cdiv(v1->v_com, v2->v_com);
1079 vres->v_type = V_COM;
1080 c = vres->v_com;
1081 if (cisreal(c)) {
1082 vres->v_num = qlink(c->real);
1083 vres->v_type = V_NUM;
1084 comfree(c);
1085 }
1086 return;
1087 case TWOVAL(V_MAT, V_NUM):
1088 case TWOVAL(V_MAT, V_COM):
1089 invertvalue(v2, &tmpval);
1090 vres->v_mat = matmulval(v1->v_mat, &tmpval);
1091 vres->v_type = V_MAT;
1092 freevalue(&tmpval);
1093 return;
1094 default:
1095 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
1096 math_error("Non-compatible values for divide");
1097 *vres = objcall(OBJ_DIV, v1, v2, NULL_VALUE);
1098 return;
1099 }
1100}
1101
1102
1103/*
1104 * Divide one arbitrary value by another one keeping only the integer part.
1105 * Result is placed in the indicated location.
1106 */
1107void
1108quovalue(v1, v2, vres)
1109 VALUE *v1, *v2, *vres;
1110{
1111 COMPLEX *c;
1112
1113 vres->v_type = V_NULL;
1114 switch (TWOVAL(v1->v_type, v2->v_type)) {
1115 case TWOVAL(V_NUM, V_NUM):
1116 vres->v_num = qquo(v1->v_num, v2->v_num);
1117 vres->v_type = V_NUM;
1118 return;
1119 case TWOVAL(V_COM, V_NUM):
1120 vres->v_com = cquoq(v1->v_com, v2->v_num);
1121 vres->v_type = V_COM;
1122 c = vres->v_com;
1123 if (cisreal(c)) {
1124 vres->v_num = qlink(c->real);
1125 vres->v_type = V_NUM;
1126 comfree(c);
1127 }
1128 return;
1129 case TWOVAL(V_MAT, V_NUM):
1130 case TWOVAL(V_MAT, V_COM):
1131 vres->v_mat = matquoval(v1->v_mat, v2);
1132 vres->v_type = V_MAT;
1133 return;
1134 default:
1135 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
1136 math_error("Non-compatible values for quotient");
1137 *vres = objcall(OBJ_QUO, v1, v2, NULL_VALUE);
1138 return;
1139 }
1140}
1141
1142
1143/*
1144 * Divide one arbitrary value by another one keeping only the remainder.
1145 * Result is placed in the indicated location.
1146 */
1147void
1148modvalue(v1, v2, vres)
1149 VALUE *v1, *v2, *vres;
1150{
1151 COMPLEX *c;
1152
1153 vres->v_type = V_NULL;
1154 switch (TWOVAL(v1->v_type, v2->v_type)) {
1155 case TWOVAL(V_NUM, V_NUM):
1156 vres->v_num = qmod(v1->v_num, v2->v_num);
1157 vres->v_type = V_NUM;
1158 return;
1159 case TWOVAL(V_COM, V_NUM):
1160 vres->v_com = cmodq(v1->v_com, v2->v_num);
1161 vres->v_type = V_COM;
1162 c = vres->v_com;
1163 if (cisreal(c)) {
1164 vres->v_num = qlink(c->real);
1165 vres->v_type = V_NUM;
1166 comfree(c);
1167 }
1168 return;
1169 case TWOVAL(V_MAT, V_NUM):
1170 case TWOVAL(V_MAT, V_COM):
1171 vres->v_mat = matmodval(v1->v_mat, v2);
1172 vres->v_type = V_MAT;
1173 return;
1174 default:
1175 if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
1176 math_error("Non-compatible values for mod");
1177 *vres = objcall(OBJ_MOD, v1, v2, NULL_VALUE);
1178 return;
1179 }
1180}
1181
1182
1183/*
1184 * Test an arbitrary value to see if it is equal to "zero".
1185 * The definition of zero varies depending on the value type. For example,
1186 * the null string is "zero", and a matrix with zero values is "zero".
1187 * Returns TRUE if value is not equal to zero.
1188 */
1189BOOL
1190testvalue(vp)
1191 VALUE *vp;
1192{
1193 VALUE val;
1194
1195 switch (vp->v_type) {
1196 case V_NUM:
1197 return !qiszero(vp->v_num);
1198 case V_COM:
1199 return !ciszero(vp->v_com);
1200 case V_STR:
1201 return (vp->v_str[0] != '\0');
1202 case V_MAT:
1203 return mattest(vp->v_mat);
1204 case V_LIST:
1205 return (vp->v_list->l_count != 0);
1206 case V_ASSOC:
1207 return (vp->v_assoc->a_count != 0);
1208 case V_FILE:
1209 return validid(vp->v_file);
1210 case V_NULL:
1211 return FALSE;
1212 case V_OBJ:
1213 val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
1214 return (val.v_int != 0);
1215 default:
1216 return TRUE;
1217 }
1218}
1219
1220
1221/*
1222 * Compare two values for equality.
1223 * Returns TRUE if the two values differ.
1224 */
1225BOOL
1226comparevalue(v1, v2)
1227 VALUE *v1, *v2;
1228{
1229 int r = FALSE;
1230 VALUE val;
1231
1232 if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
1233 val = objcall(OBJ_CMP, v1, v2, NULL_VALUE);
1234 return (val.v_int != 0);
1235 }
1236 if (v1 == v2)
1237 return FALSE;
1238 if (v1->v_type != v2->v_type)
1239 return TRUE;
1240 switch (v1->v_type) {
1241 case V_NUM:
1242 r = qcmp(v1->v_num, v2->v_num);
1243 break;
1244 case V_COM:
1245 r = ccmp(v1->v_com, v2->v_com);
1246 break;
1247 case V_STR:
1248 r = ((v1->v_str != v2->v_str) &&
1249 ((v1->v_str[0] - v2->v_str[0]) ||
1250 strcmp(v1->v_str, v2->v_str)));
1251 break;
1252 case V_MAT:
1253 r = matcmp(v1->v_mat, v2->v_mat);
1254 break;
1255 case V_LIST:
1256 r = listcmp(v1->v_list, v2->v_list);
1257 break;
1258 case V_ASSOC:
1259 r = assoccmp(v1->v_assoc, v2->v_assoc);
1260 break;
1261 case V_NULL:
1262 break;
1263 case V_FILE:
1264 r = (v1->v_file != v2->v_file);
1265 break;
1266 default:
1267 math_error("Illegal values for comparevalue");
1268 }
1269 return (r != 0);
1270}
1271
1272
1273/*
1274 * Compare two values for their relative values.
1275 * Returns minus one if the first value is less than the second one,
1276 * one if the first value is greater than the second one, and
1277 * zero if they are equal.
1278 */
1279FLAG
1280relvalue(v1, v2)
1281 VALUE *v1, *v2;
1282{
1283 int r = 0;
1284 VALUE val;
1285
1286 if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
1287 val = objcall(OBJ_REL, v1, v2, NULL_VALUE);
1288 return val.v_int;
1289 }
1290 if (v1 == v2)
1291 return 0;
1292 if (v1->v_type != v2->v_type)
1293 math_error("Relative comparison of differing types");
1294 switch (v1->v_type) {
1295 case V_NUM:
1296 r = qrel(v1->v_num, v2->v_num);
1297 break;
1298 case V_STR:
1299 r = strcmp(v1->v_str, v2->v_str);
1300 break;
1301 case V_NULL:
1302 break;
1303 default:
1304 math_error("Illegal value for relative comparison");
1305 }
1306 if (r < 0)
1307 return -1;
1308 return (r != 0);
1309}
1310
1311
1312/*
1313 * Calculate a hash value for a value.
1314 * The hash does not have to be a perfect one, it is only used for
1315 * making associations faster.
1316 */
1317HASH
1318hashvalue(vp)
1319 VALUE *vp;
1320{
1321 switch (vp->v_type) {
1322 case V_INT:
1323 return ((long) vp->v_int);
1324 case V_NUM:
1325 return qhash(vp->v_num);
1326 case V_COM:
1327 return chash(vp->v_com);
1328 case V_STR:
1329 return hashstr(vp->v_str);
1330 case V_NULL:
1331 return 0;
1332 case V_OBJ:
1333 return objhash(vp->v_obj);
1334 case V_LIST:
1335 return listhash(vp->v_list);
1336 case V_ASSOC:
1337 return assochash(vp->v_assoc);
1338 case V_MAT:
1339 return mathash(vp->v_mat);
1340 case V_FILE:
1341 return ((long) vp->v_file);
1342 default:
1343 math_error("Hashing unknown value");
1344 }
1345 return 0;
1346}
1347
1348
1349/*
1350 * Print the value of a descriptor in one of several formats.
1351 * If flags contains PRINT_SHORT, then elements of arrays and lists
1352 * will not be printed. If flags contains PRINT_UNAMBIG, then quotes
1353 * are placed around strings and the null value is explicitly printed.
1354 */
1355void
1356printvalue(vp, flags)
1357 VALUE *vp;
1358 int flags;
1359{
1360 switch (vp->v_type) {
1361 case V_NUM:
1362 qprintnum(vp->v_num, MODE_DEFAULT);
1363 break;
1364 case V_COM:
1365 comprint(vp->v_com);
1366 break;
1367 case V_STR:
1368 if (flags & PRINT_UNAMBIG)
1369 math_chr('\"');
1370 math_str(vp->v_str);
1371 if (flags & PRINT_UNAMBIG)
1372 math_chr('\"');
1373 break;
1374 case V_NULL:
1375 if (flags & PRINT_UNAMBIG)
1376 math_str("NULL");
1377 break;
1378 case V_OBJ:
1379 (void) objcall(OBJ_PRINT, vp, NULL_VALUE, NULL_VALUE);
1380 break;
1381 case V_LIST:
1382 listprint(vp->v_list,
1383 ((flags & PRINT_SHORT) ? 0L : maxprint));
1384 break;
1385 case V_ASSOC:
1386 assocprint(vp->v_assoc,
1387 ((flags & PRINT_SHORT) ? 0L : maxprint));
1388 break;
1389 case V_MAT:
1390 matprint(vp->v_mat,
1391 ((flags & PRINT_SHORT) ? 0L : maxprint));
1392 break;
1393 case V_FILE:
1394 printid(vp->v_file, flags);
1395 break;
1396 default:
1397 math_error("Printing unknown value");
1398 }
1399}
1400
1401/* END CODE */
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.