1 /*
2 * func - built-in functions implemented here
3 *
4 * Copyright (C) 1999-2007,2018,2021 David I. Bell, Landon Curt Noll
5 * and Ernest Bowen
6 *
7 * Primary author: David I. Bell
8 *
9 * Calc is open software; you can redistribute it and/or modify it under
10 * the terms of the version 2.1 of the GNU Lesser General Public License
11 * as published by the Free Software Foundation.
12 *
13 * Calc is distributed in the hope that it will be useful, but WITHOUT
14 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
15 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
16 * Public License for more details.
17 *
18 * A copy of version 2.1 of the GNU Lesser General Public License is
19 * distributed with calc under the filename COPYING-LGPL. You should have
20 * received a copy with calc; if not, write to Free Software Foundation, Inc.
21 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
22 *
23 * Under source code control: 1990/02/15 01:48:15
24 * File existed as early as: before 1990
25 *
26 * Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/
27 */
28
29
30 #include <stdio.h>
31 #include <ctype.h>
32 #include <sys/types.h>
33 #include <errno.h>
34
35
36 #if defined(_WIN32) || defined(_WIN64)
37 # include <io.h>
38 # define _access access
39 #endif
40
41 #if defined(FUNCLIST)
42
43 #define CONST /* disabled for FUNCLIST in case NATIVE_CC doesn't have it */
44 #undef HAVE_CONST
45
46 #include "decl.h"
47
48 #else /* FUNCLIST */
49
50 #include "decl.h"
51
52 #include "have_unistd.h"
53 #if defined(HAVE_UNISTD_H)
54 #include <unistd.h>
55 #endif
56
57 #include "have_stdlib.h"
58 #if defined(HAVE_STDLIB_H)
59 #include <stdlib.h>
60 #endif
61
62 #include "have_string.h"
63 #if defined(HAVE_STRING_H)
64 #include <string.h>
65 #endif
66
67 #include "have_times.h"
68 #if defined(HAVE_TIME_H)
69 #include <time.h>
70 #endif
71
72 #if defined(HAVE_TIMES_H)
73 #include <times.h>
74 #endif
75
76 #if defined(HAVE_SYS_TIME_H)
77 #include <sys/time.h>
78 #endif
79
80 #if defined(HAVE_SYS_TIMES_H)
81 #include <sys/times.h>
82 #endif
83
84 #include "have_strdup.h"
85 #if !defined(HAVE_STRDUP)
86 # define strdup(x) calc_strdup((CONST char *)(x))
87 #endif
88
89 #include "have_rusage.h"
90 #if defined(HAVE_GETRUSAGE)
91 # include <sys/resource.h>
92 #endif
93
94 #include "have_const.h"
95 #include "have_unused.h"
96 #include "calc.h"
97 #include "calcerr.h"
98 #include "opcodes.h"
99 #include "token.h"
100 #include "func.h"
101 #include "str.h"
102 #include "symbol.h"
103 #include "prime.h"
104 #include "file.h"
105 #include "zrand.h"
106 #include "zrandom.h"
107 #include "custom.h"
108 #include "strl.h"
109
110 #if defined(CUSTOM)
111 # define E_CUSTOM_ERROR E_NO_C_ARG
112 #else
113 # define E_CUSTOM_ERROR E_NO_CUSTOM
114 #endif
115
116
117 #include "banned.h" /* include after system header <> includes */
118
119
120 /*
121 * forward declarations
122 */
123 S_FUNC NUMBER *base_value(long mode, int defval);
124 S_FUNC int strscan(char *s, int count, VALUE **vals);
125 S_FUNC int filescan(FILEID id, int count, VALUE **vals);
126 S_FUNC VALUE f_eval(VALUE *vp);
127 S_FUNC VALUE f_fsize(VALUE *vp);
128 S_FUNC int malloced_putenv(char *str);
129
130
131
132 /*
133 * external declarations
134 */
135 EXTERN char cmdbuf[]; /* command line expression */
136 EXTERN CONST char *error_table[E__COUNT+2]; /* calc coded error messages */
137 E_FUNC void matrandperm(MATRIX *M);
138 E_FUNC void listrandperm(LIST *lp);
139 E_FUNC int idungetc(FILEID id, int ch);
140 E_FUNC LIST* associndices(ASSOC *ap, long index);
141 E_FUNC LIST* matindices(MATRIX *mp, long index);
142
143
144 /*
145 * malloced environment storage
146 */
147 #define ENV_POOL_CHUNK 10 /* env_pool elements to allocate at a time */
148 struct env_pool {
149 char *getenv; /* what getenv() would return, NULL => unused */
150 char *putenv; /* pointer given to putenv() */
151 };
152 STATIC int env_pool_cnt = 0; /* number of env_pool elements in use */
153 STATIC int env_pool_max = 0; /* number of env_pool elements allocated */
154 STATIC struct env_pool *e_pool = NULL; /* env_pool elements */
155
156
157 /*
158 * constants used for hours or degrees conversion functions
159 */
160 STATIC HALF _nineval_[] = { 9 };
161 STATIC HALF _twentyfourval_[] = { 24 };
162 STATIC HALF _threesixtyval_[] = { 360 };
163 STATIC HALF _fourhundredval_[] = { 400 };
164 STATIC NUMBER _qtendivnine_ = { { _tenval_, 1, 0 },
165 { _nineval_, 1, 0 }, 1, NULL };
166 STATIC NUMBER _qninedivten_ = { { _nineval_, 1, 0 },
167 { _tenval_, 1, 0 }, 1, NULL };
168 STATIC NUMBER _qtwentyfour = { { _twentyfourval_, 1, 0 },
169 { _oneval_, 1, 0 }, 1, NULL };
170 STATIC NUMBER _qthreesixty = { { _threesixtyval_, 1, 0 },
171 { _oneval_, 1, 0 }, 1, NULL };
172 STATIC NUMBER _qfourhundred = { { _fourhundredval_, 1, 0 },
173 { _oneval_, 1, 0 }, 1, NULL };
174
175
176 /*
177 * user-defined error strings
178 */
179 STATIC short nexterrnum = E_USERDEF;
180 STATIC STRINGHEAD newerrorstr;
181
182 #endif /* !FUNCLIST */
183
184
185 /*
186 * arg count definitions
187 */
188 #define IN 1024 /* maximum number of arguments */
189 #define FE 0x01 /* flag to indicate default epsilon argument */
190 #define FA 0x02 /* preserve addresses of variables */
191
192
193 /*
194 * builtins - List of primitive built-in functions
195 */
196 struct builtin {
197 char *b_name; /* name of built-in function */
198 short b_minargs; /* minimum number of arguments */
199 short b_maxargs; /* maximum number of arguments */
200 short b_flags; /* special handling flags */
201 short b_opcode; /* opcode which makes the call quick */
202 NUMBER *(*b_numfunc)(); /* routine to calculate numeric function */
203 VALUE (*b_valfunc)(); /* routine to calculate general values */
204 char *b_desc; /* description of function */
205 };
206
207
208 #if !defined(FUNCLIST)
209
210 S_FUNC VALUE
f_eval(VALUE * vp)211 f_eval(VALUE *vp)
212 {
213 FUNC *oldfunc;
214 FUNC *newfunc;
215 VALUE result;
216 char *str;
217 size_t num;
218 long temp_stoponerror; /* temp value of stoponerror */
219
220 if (vp->v_type != V_STR)
221 return error_value(E_EVAL2);
222 str = vp->v_str->s_str;
223 num = vp->v_str->s_len;
224 switch (openstring(str, num)) {
225 case -2:
226 return error_value(E_EVAL3);
227 case -1:
228 return error_value(E_EVAL4);
229 }
230 oldfunc = curfunc;
231 enterfilescope();
232 temp_stoponerror = stoponerror;
233 stoponerror = -1;
234 if (evaluate(TRUE)) {
235 stoponerror = temp_stoponerror;
236 closeinput();
237 exitfilescope();
238 freevalue(stack--);
239 newfunc = curfunc;
240 curfunc = oldfunc;
241 result = newfunc->f_savedvalue;
242 newfunc->f_savedvalue.v_type = V_NULL;
243 newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE;
244 freenumbers(newfunc);
245 if (newfunc != oldfunc)
246 free(newfunc);
247 return result;
248 }
249 stoponerror = temp_stoponerror;
250 closeinput();
251 exitfilescope();
252 newfunc = curfunc;
253 curfunc = oldfunc;
254 freevalue(&newfunc->f_savedvalue);
255 newfunc->f_savedvalue.v_type = V_NULL;
256 newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE;
257 freenumbers(newfunc);
258 if (newfunc != oldfunc)
259 free(newfunc);
260 return error_value(E_EVAL);
261 }
262
263
264 S_FUNC VALUE
f_prompt(VALUE * vp)265 f_prompt(VALUE *vp)
266 {
267 VALUE result;
268 char *cp;
269 char *newcp;
270 size_t len;
271
272 /* initialize VALUE */
273 result.v_type = V_STR;
274 result.v_subtype = V_NOSUBTYPE;
275
276 openterminal();
277 printvalue(vp, PRINT_SHORT);
278 math_flush();
279 cp = nextline();
280 closeinput();
281 if (cp == NULL) {
282 result.v_type = V_NULL;
283 return result;
284 }
285 if (*cp == '\0') {
286 result.v_str = slink(&_nullstring_);
287 return result;
288 }
289 len = strlen(cp);
290 newcp = (char *) malloc(len + 1);
291 if (newcp == NULL) {
292 math_error("Cannot allocate string");
293 /*NOTREACHED*/
294 }
295 strlcpy(newcp, cp, len+1);
296 result.v_str = makestring(newcp);
297 return result;
298 }
299
300
301 S_FUNC VALUE
f_display(int count,VALUE ** vals)302 f_display(int count, VALUE **vals)
303 {
304 LEN oldvalue;
305 VALUE res;
306
307 /* initialize VALUE */
308 res.v_type = V_NUM;
309 res.v_subtype = V_NOSUBTYPE;
310
311 oldvalue = conf->outdigits;
312
313 if (count > 0) {
314 if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) ||
315 qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num))
316 fprintf(stderr,
317 "Out-of-range arg for display ignored\n");
318 else
319 conf->outdigits = (LEN) qtoi(vals[0]->v_num);
320 }
321 res.v_num = itoq((long) oldvalue);
322 return res;
323 }
324
325
326 /*ARGSUSED*/
327 S_FUNC VALUE
f_null(int UNUSED (count),VALUE ** UNUSED (vals))328 f_null(int UNUSED(count), VALUE **UNUSED(vals))
329 {
330 VALUE res;
331
332 /* initialize VALUE */
333 res.v_type = V_NULL;
334 res.v_subtype = V_NOSUBTYPE;
335
336 return res;
337 }
338
339
340 S_FUNC VALUE
f_str(VALUE * vp)341 f_str(VALUE *vp)
342 {
343 VALUE result;
344 char *cp;
345
346 /* initialize VALUE */
347 result.v_type = V_STR;
348 result.v_subtype = V_NOSUBTYPE;
349
350 switch (vp->v_type) {
351 case V_STR:
352 result.v_str = makenewstring(vp->v_str->s_str);
353 break;
354 case V_NULL:
355 result.v_str = slink(&_nullstring_);
356 break;
357 case V_OCTET:
358 result.v_str = charstring(*vp->v_octet);
359 break;
360 case V_NUM:
361 math_divertio();
362 qprintnum(vp->v_num, MODE_DEFAULT, conf->outdigits);
363 cp = math_getdivertedio();
364 result.v_str = makestring(cp);
365 break;
366 case V_COM:
367 math_divertio();
368 comprint(vp->v_com);
369 cp = math_getdivertedio();
370 result.v_str = makestring(cp);
371 break;
372 default:
373 return error_value(E_STR);
374 }
375 return result;
376 }
377
378
379 S_FUNC VALUE
f_estr(VALUE * vp)380 f_estr(VALUE *vp)
381 {
382 VALUE result;
383 char *cp;
384
385 /* initialize result */
386 result.v_type = V_STR;
387 result.v_subtype = V_NOSUBTYPE;
388
389 math_divertio();
390 printestr(vp);
391 cp = math_getdivertedio();
392 result.v_str = makestring(cp);
393 return result;
394 }
395
396
397 S_FUNC VALUE
f_name(VALUE * vp)398 f_name(VALUE *vp)
399 {
400 VALUE result;
401 char *cp;
402 char *name;
403
404 /* initialize VALUE */
405 result.v_type = V_STR;
406 result.v_subtype = V_NOSUBTYPE;
407
408 switch (vp->v_type) {
409 case V_NBLOCK:
410 result.v_type = V_STR;
411 result.v_str = makenewstring(vp->v_nblock->name);
412 return result;
413 case V_FILE:
414 name = findfname(vp->v_file);
415 if (name == NULL) {
416 result.v_type = V_NULL;
417 return result;
418 }
419 math_divertio();
420 math_str(name);
421 cp = math_getdivertedio();
422 break;
423 default:
424 result.v_type = V_NULL;
425 return result;
426 }
427 result.v_str = makestring(cp);
428 return result;
429 }
430
431
432
433 S_FUNC VALUE
f_poly(int count,VALUE ** vals)434 f_poly(int count, VALUE **vals)
435 {
436 VALUE *x;
437 VALUE result, tmp;
438 LIST *clist, *lp;
439
440 /* initialize VALUEs */
441 result.v_subtype = V_NOSUBTYPE;
442 tmp.v_subtype = V_NOSUBTYPE;
443
444 if (vals[0]->v_type == V_LIST) {
445 clist = vals[0]->v_list;
446 lp = listalloc();
447 while (--count > 0) {
448 if ((*++vals)->v_type == V_LIST)
449 insertitems(lp, (*vals)->v_list);
450 else
451 insertlistlast(lp, *vals);
452 }
453 if (!evalpoly(clist, lp->l_first, &result)) {
454 result.v_type = V_NUM;
455 result.v_num = qlink(&_qzero_);
456 }
457 listfree(lp);
458 return result;
459 }
460 x = vals[--count];
461 copyvalue(*vals++, &result);
462 while (--count > 0) {
463 mulvalue(&result, x, &tmp);
464 freevalue(&result);
465 addvalue(*vals++, &tmp, &result);
466 freevalue(&tmp);
467 }
468 return result;
469 }
470
471
472 S_FUNC NUMBER *
f_mne(NUMBER * val1,NUMBER * val2,NUMBER * val3)473 f_mne(NUMBER *val1, NUMBER *val2, NUMBER *val3)
474 {
475 NUMBER *tmp, *res;
476
477 tmp = qsub(val1, val2);
478 res = itoq((long) !qdivides(tmp, val3));
479 qfree(tmp);
480 return res;
481 }
482
483
484 S_FUNC NUMBER *
f_isrel(NUMBER * val1,NUMBER * val2)485 f_isrel(NUMBER *val1, NUMBER *val2)
486 {
487 if (qisfrac(val1) || qisfrac(val2)) {
488 math_error("Non-integer for isrel");
489 /*NOTREACHED*/
490 }
491 return itoq((long) zrelprime(val1->num, val2->num));
492 }
493
494
495 S_FUNC NUMBER *
f_issquare(NUMBER * vp)496 f_issquare(NUMBER *vp)
497 {
498 return itoq((long) qissquare(vp));
499 }
500
501
502 S_FUNC NUMBER *
f_isprime(int count,NUMBER ** vals)503 f_isprime(int count, NUMBER **vals)
504 {
505 NUMBER *err; /* error return, NULL => use math_error */
506
507 /* determine the way we report problems */
508 if (count == 2) {
509 if (qisfrac(vals[1])) {
510 math_error("2nd isprime arg must be an integer");
511 /*NOTREACHED*/
512 }
513 err = vals[1];
514 } else {
515 err = NULL;
516 }
517
518 /* firewall - must be an integer */
519 if (qisfrac(vals[0])) {
520 if (err) {
521 return qlink(err);
522 }
523 math_error("non-integral arg for builtin function isprime");
524 /*NOTREACHED*/
525 }
526
527 /* test the integer */
528 switch (zisprime(vals[0]->num)) {
529 case 0: return qlink(&_qzero_);
530 case 1: return qlink(&_qone_);
531 }
532
533 /* error return */
534 if (!err) {
535 math_error("isprime argument is an odd value > 2^32");
536 /*NOTREACHED*/
537 }
538 return qlink(err);
539 }
540
541
542 S_FUNC NUMBER *
f_nprime(int count,NUMBER ** vals)543 f_nprime(int count, NUMBER **vals)
544 {
545 NUMBER *err; /* error return, NULL => use math_error */
546 FULL nxt_prime; /* next prime or 0 */
547
548 /* determine the way we report problems */
549 if (count == 2) {
550 if (qisfrac(vals[1])) {
551 math_error("2nd nextprime arg must be an integer");
552 /*NOTREACHED*/
553 }
554 err = vals[1];
555 } else {
556 err = NULL;
557 }
558
559 /* firewall - must be an integer */
560 if (qisfrac(vals[0])) {
561 if (err) {
562 return qlink(err);
563 }
564 math_error("non-integral arg 1 for builtin function nextprime");
565 /*NOTREACHED*/
566 }
567
568 /* test the integer */
569 nxt_prime = znprime(vals[0]->num);
570 if (nxt_prime > 1) {
571 return utoq(nxt_prime);
572 } else if (nxt_prime == 0) {
573 /* return 2^32+15 */
574 return qlink(&_nxtprime_);
575 }
576
577 /* error return */
578 if (!err) {
579 math_error("nextprime arg 1 is >= 2^32");
580 /*NOTREACHED*/
581 }
582 return qlink(err);
583 }
584
585
586 S_FUNC NUMBER *
f_pprime(int count,NUMBER ** vals)587 f_pprime(int count, NUMBER **vals)
588 {
589 NUMBER *err; /* error return, NULL => use math_error */
590 FULL prev_prime; /* previous prime or 0 */
591
592 /* determine the way we report problems */
593 if (count == 2) {
594 if (qisfrac(vals[1])) {
595 math_error("2nd prevprime arg must be an integer");
596 /*NOTREACHED*/
597 }
598 err = vals[1];
599 } else {
600 err = NULL;
601 }
602
603 /* firewall - must be an integer */
604 if (qisfrac(vals[0])) {
605 if (err) {
606 return qlink(err);
607 }
608 math_error("non-integral arg 1 for builtin function prevprime");
609 /*NOTREACHED*/
610 }
611
612 /* test the integer */
613 prev_prime = zpprime(vals[0]->num);
614 if (prev_prime > 1) {
615 return utoq(prev_prime);
616 }
617 if (prev_prime == 0) {
618 return qlink(&_qzero_);
619 }
620 /* error return */
621 if (!err) {
622 if (prev_prime == 0) {
623 math_error("prevprime arg 1 is <= 2");
624 /*NOTREACHED*/
625 } else {
626 math_error("prevprime arg 1 is >= 2^32");
627 /*NOTREACHED*/
628 }
629 }
630 return qlink(err);
631 }
632
633
634 S_FUNC NUMBER *
f_factor(int count,NUMBER ** vals)635 f_factor(int count, NUMBER **vals)
636 {
637 NUMBER *err; /* error return, NULL => use math_error */
638 ZVALUE limit; /* highest prime factor in search */
639 ZVALUE n; /* number to factor */
640 NUMBER *factor; /* the prime factor found */
641 int res; /* -1 => error, 0 => not found, 1 => factor found */
642
643 /*
644 * parse args
645 */
646 if (count == 3) {
647 if (qisfrac(vals[2])) {
648 math_error("3rd factor arg must be an integer");
649 /*NOTREACHED*/
650 }
651 err = vals[2];
652 } else {
653 err = NULL;
654 }
655 if (count >= 2) {
656 if (qisfrac(vals[1])) {
657 if (err) {
658 return qlink(err);
659 }
660 math_error("non-integral arg 2 for builtin factor");
661 /*NOTREACHED*/
662 }
663 limit = vals[1]->num;
664 } else {
665 /* default limit is 2^32-1 */
666 utoz((FULL)0xffffffff, &limit);
667 }
668 if (qisfrac(vals[0])) {
669 if (count < 2)
670 zfree(limit);
671 if (err) {
672 return qlink(err);
673 }
674 math_error("non-integral arg 1 for builtin pfactor");
675 /*NOTREACHED*/
676 }
677 n = vals[0]->num;
678
679 /*
680 * find the smallest prime factor in the range
681 */
682 factor = qalloc();
683 res = zfactor(n, limit, &(factor->num));
684 if (res < 0) {
685 /* error processing */
686 if (err) {
687 return qlink(err);
688 }
689 math_error("limit >= 2^32 for builtin factor");
690 /*NOTREACHED*/
691 } else if (res == 0) {
692 if (count < 2)
693 zfree(limit);
694 /* no factor found - qalloc set factor to 1, return 1 */
695 return factor;
696 }
697
698 /*
699 * return the factor found
700 */
701 if (count < 2)
702 zfree(limit);
703 return factor;
704 }
705
706
707 S_FUNC NUMBER *
f_pix(int count,NUMBER ** vals)708 f_pix(int count, NUMBER **vals)
709 {
710 NUMBER *err; /* error return, NULL => use math_error */
711 long value; /* primes <= x, or 0 ==> error */
712
713 /* determine the way we report problems */
714 if (count == 2) {
715 if (qisfrac(vals[1])) {
716 math_error("2nd pix arg must be an integer");
717 /*NOTREACHED*/
718 }
719 err = vals[1];
720 } else {
721 err = NULL;
722 }
723
724 /* firewall - must be an integer */
725 if (qisfrac(vals[0])) {
726 if (err) {
727 return qlink(err);
728 }
729 math_error("non-integral arg 1 for builtin function pix");
730 /*NOTREACHED*/
731 }
732
733 /* determine the number of primes <= x */
734 value = zpix(vals[0]->num);
735 if (value >= 0) {
736 return utoq(value);
737 }
738
739 /* error return */
740 if (!err) {
741 math_error("pix arg 1 is >= 2^32");
742 /*NOTREACHED*/
743 }
744 return qlink(err);
745 }
746
747
748 S_FUNC NUMBER *
f_prevcand(int count,NUMBER ** vals)749 f_prevcand(int count, NUMBER **vals)
750 {
751 ZVALUE zmodulus;
752 ZVALUE zresidue;
753 ZVALUE zskip;
754 ZVALUE *zcount = NULL; /* ptest trial count */
755 ZVALUE tmp;
756 NUMBER *ans; /* candidate for primality */
757
758 zmodulus = _one_;
759 zresidue = _zero_;
760 zskip = _one_;
761 /*
762 * check on the number of args passed and that args passed are ints
763 */
764 switch (count) {
765 case 5:
766 if (!qisint(vals[4])) {
767 math_error( "prevcand 5th arg must both be integer");
768 /*NOTREACHED*/
769 }
770 zmodulus = vals[4]->num;
771 /*FALLTHRU*/
772 case 4:
773 if (!qisint(vals[3])) {
774 math_error( "prevcand 4th arg must both be integer");
775 /*NOTREACHED*/
776 }
777 zresidue = vals[3]->num;
778 /*FALLTHRU*/
779 case 3:
780 if (!qisint(vals[2])) {
781 math_error(
782 "prevcand skip arg (3rd) must be an integer or omitted");
783 /*NOTREACHED*/
784 }
785 zskip = vals[2]->num;
786 /*FALLTHRU*/
787 case 2:
788 if (!qisint(vals[1])) {
789 math_error(
790 "prevcand count arg (2nd) must be an integer or omitted");
791 /*NOTREACHED*/
792 }
793 zcount = &vals[1]->num;
794 /*FALLTHRU*/
795 case 1:
796 if (!qisint(vals[0])) {
797 math_error(
798 "prevcand search arg (1st) must be an integer");
799 /*NOTREACHED*/
800 }
801 break;
802 default:
803 math_error("invalid number of args passed to prevcand");
804 /*NOTREACHED*/
805 }
806
807 if (zcount == NULL) {
808 count = 1; /* default is 1 ptest */
809 } else {
810 if (zge24b(*zcount)) {
811 math_error("prevcand count arg (2nd) must be < 2^24");
812 /*NOTREACHED*/
813 }
814 count = ztoi(*zcount);
815 }
816
817 /*
818 * find the candidate
819 */
820 if (zprevcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) {
821 ans = qalloc();
822 ans->num = tmp;
823 return ans;
824 }
825 return qlink(&_qzero_);
826 }
827
828
829 S_FUNC NUMBER *
f_nextcand(int count,NUMBER ** vals)830 f_nextcand(int count, NUMBER **vals)
831 {
832 ZVALUE zmodulus;
833 ZVALUE zresidue;
834 ZVALUE zskip;
835 ZVALUE *zcount = NULL; /* ptest trial count */
836 ZVALUE tmp;
837 NUMBER *ans; /* candidate for primality */
838
839 zmodulus = _one_;
840 zresidue = _zero_;
841 zskip = _one_;
842 /*
843 * check on the number of args passed and that args passed are ints
844 */
845 switch (count) {
846 case 5:
847 if (!qisint(vals[4])) {
848 math_error(
849 "nextcand 5th args must be integer");
850 /*NOTREACHED*/
851 }
852 zmodulus = vals[4]->num;
853 /*FALLTHRU*/
854 case 4:
855 if (!qisint(vals[3])) {
856 math_error(
857 "nextcand 5th args must be integer");
858 /*NOTREACHED*/
859 }
860 zresidue = vals[3]->num;
861 /*FALLTHRU*/
862 case 3:
863 if (!qisint(vals[2])) {
864 math_error(
865 "nextcand skip arg (3rd) must be an integer or omitted");
866 /*NOTREACHED*/
867 }
868 zskip = vals[2]->num;
869 /*FALLTHRU*/
870 case 2:
871 if (!qisint(vals[1])) {
872 math_error(
873 "nextcand count arg (2nd) must be an integer or omitted");
874 /*NOTREACHED*/
875 }
876 zcount = &vals[1]->num;
877 /*FALLTHRU*/
878 case 1:
879 if (!qisint(vals[0])) {
880 math_error(
881 "nextcand search arg (1st) must be an integer");
882 /*NOTREACHED*/
883 }
884 break;
885 default:
886 math_error("invalid number of args passed to nextcand");
887 /*NOTREACHED*/
888 }
889
890 /*
891 * check ranges on integers passed
892 */
893 if (zcount == NULL) {
894 count = 1; /* default is 1 ptest */
895 } else {
896 if (zge24b(*zcount)) {
897 math_error("prevcand count arg (2nd) must be < 2^24");
898 /*NOTREACHED*/
899 }
900 count = ztoi(*zcount);
901 }
902
903 /*
904 * find the candidate
905 */
906 if (znextcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) {
907 ans = qalloc();
908 ans->num = tmp;
909 return ans;
910 }
911 return qlink(&_qzero_);
912 }
913
914
915 S_FUNC NUMBER *
f_seed(void)916 f_seed(void)
917 {
918 return pseudo_seed();
919 }
920
921
922 S_FUNC NUMBER *
f_rand(int count,NUMBER ** vals)923 f_rand(int count, NUMBER **vals)
924 {
925 NUMBER *ans;
926
927 /* parse args */
928 switch (count) {
929 case 0: /* rand() == rand(2^64) */
930 /* generate an a55 random number */
931 ans = qalloc();
932 zrand(SBITS, &ans->num);
933 break;
934
935 case 1: /* rand(limit) */
936 if (!qisint(vals[0])) {
937 math_error("rand limit must be an integer");
938 /*NOTREACHED*/
939 }
940 if (zislezero(vals[0]->num)) {
941 math_error("rand limit must > 0");
942 /*NOTREACHED*/
943 }
944 ans = qalloc();
945 zrandrange(_zero_, vals[0]->num, &ans->num);
946 break;
947
948 case 2: /* rand(low, limit) */
949 /* firewall */
950 if (!qisint(vals[0]) || !qisint(vals[1])) {
951 math_error("rand range must be integers");
952 /*NOTREACHED*/
953 }
954 ans = qalloc();
955 zrandrange(vals[0]->num, vals[1]->num, &ans->num);
956 break;
957
958 default:
959 math_error("invalid number of args passed to rand");
960 /*NOTREACHED*/
961 return NULL;
962 }
963
964 /* return the a55 random number */
965 return ans;
966 }
967
968
969 S_FUNC NUMBER *
f_randbit(int count,NUMBER ** vals)970 f_randbit(int count, NUMBER **vals)
971 {
972 NUMBER *ans;
973 ZVALUE ztmp;
974 long cnt; /* bits needed or skipped */
975
976 /* parse args */
977 if (count == 0) {
978 zrand(1, &ztmp);
979 ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_);
980 zfree(ztmp);
981 return ans;
982 }
983
984 /*
985 * firewall
986 */
987 if (!qisint(vals[0])) {
988 math_error("rand bit count must be an integer");
989 /*NOTREACHED*/
990 }
991 if (zge31b(vals[0]->num)) {
992 math_error("huge rand bit count");
993 /*NOTREACHED*/
994 }
995
996 /*
997 * generate an a55 random number or skip random bits
998 */
999 ans = qalloc();
1000 cnt = ztolong(vals[0]->num);
1001 if (zisneg(vals[0]->num)) {
1002 /* skip bits */
1003 zrandskip(cnt);
1004 itoz(cnt, &ans->num);
1005 } else {
1006 /* generate bits */
1007 zrand(cnt, &ans->num);
1008 }
1009
1010 /*
1011 * return the a55 random number
1012 */
1013 return ans;
1014 }
1015
1016
1017 S_FUNC VALUE
f_srand(int count,VALUE ** vals)1018 f_srand(int count, VALUE **vals)
1019 {
1020 VALUE result;
1021
1022 /* initialize VALUE */
1023 result.v_type = V_RAND;
1024 result.v_subtype = V_NOSUBTYPE;
1025
1026 /* parse args */
1027 switch (count) {
1028 case 0:
1029 /* get the current a55 state */
1030 result.v_rand = zsrand(NULL, NULL);
1031 break;
1032
1033 case 1:
1034 switch (vals[0]->v_type) {
1035 case V_NUM: /* srand(seed) */
1036 /* seed a55 and return previous state */
1037 if (!qisint(vals[0]->v_num)) {
1038 math_error(
1039 "srand number seed must be an integer");
1040 /*NOTREACHED*/
1041 }
1042 result.v_rand = zsrand(&vals[0]->v_num->num, NULL);
1043 break;
1044
1045 case V_RAND: /* srand(state) */
1046 /* set a55 state and return previous state */
1047 result.v_rand = zsetrand(vals[0]->v_rand);
1048 break;
1049
1050 case V_MAT:
1051 /* load subtractive 100 table and return prev state */
1052 result.v_rand = zsrand(NULL, vals[0]->v_mat);
1053 break;
1054
1055 default:
1056 math_error("illegal type of arg passed to srand()");
1057 /*NOTREACHED*/
1058 break;
1059 }
1060 break;
1061
1062 default:
1063 math_error("bad arg count to srand()");
1064 /*NOTREACHED*/
1065 break;
1066 }
1067
1068 /* return the current state */
1069 return result;
1070 }
1071
1072
1073 S_FUNC NUMBER *
f_random(int count,NUMBER ** vals)1074 f_random(int count, NUMBER **vals)
1075 {
1076 NUMBER *ans;
1077
1078 /* parse args */
1079 switch (count) {
1080 case 0: /* random() == random(2^64) */
1081 /* generate a Blum-Blum-Shub random number */
1082 ans = qalloc();
1083 zrandom(SBITS, &ans->num);
1084 break;
1085
1086 case 1: /* random(limit) */
1087 if (!qisint(vals[0])) {
1088 math_error("random limit must be an integer");
1089 /*NOTREACHED*/
1090 }
1091 if (zislezero(vals[0]->num)) {
1092 math_error("random limit must > 0");
1093 /*NOTREACHED*/
1094 }
1095 ans = qalloc();
1096 zrandomrange(_zero_, vals[0]->num, &ans->num);
1097 break;
1098
1099 case 2: /* random(low, limit) */
1100 /* firewall */
1101 if (!qisint(vals[0]) || !qisint(vals[1])) {
1102 math_error("random range must be integers");
1103 /*NOTREACHED*/
1104 }
1105 ans = qalloc();
1106 zrandomrange(vals[0]->num, vals[1]->num, &ans->num);
1107 break;
1108
1109 default:
1110 math_error("invalid number of args passed to random");
1111 /*NOTREACHED*/
1112 return NULL;
1113 }
1114
1115 /* return the Blum-Blum-Shub random number */
1116 return ans;
1117 }
1118
1119
1120 S_FUNC NUMBER *
f_randombit(int count,NUMBER ** vals)1121 f_randombit(int count, NUMBER **vals)
1122 {
1123 NUMBER *ans;
1124 ZVALUE ztmp;
1125 long cnt; /* bits needed or skipped */
1126
1127 /* parse args */
1128 ztmp.len = 0; /* paranoia */
1129 ztmp.v = NULL;
1130 ztmp.sign = 0;
1131 if (count == 0) {
1132 zrandom(1, &ztmp);
1133 ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_);
1134 zfree(ztmp);
1135 return ans;
1136 }
1137
1138 /*
1139 * firewall
1140 */
1141 if (!qisint(vals[0])) {
1142 math_error("random bit count must be an integer");
1143 /*NOTREACHED*/
1144 }
1145 if (zge31b(vals[0]->num)) {
1146 math_error("huge random bit count");
1147 /*NOTREACHED*/
1148 }
1149
1150 /*
1151 * generate a Blum-Blum-Shub random number or skip random bits
1152 */
1153 ans = qalloc();
1154 cnt = ztolong(vals[0]->num);
1155 if (zisneg(vals[0]->num)) {
1156 /* skip bits */
1157 zrandomskip(cnt);
1158 itoz(cnt, &ans->num);
1159 } else {
1160 /* generate bits */
1161 zrandom(cnt, &ans->num);
1162 }
1163
1164 /*
1165 * return the Blum-Blum-Shub random number
1166 */
1167 return ans;
1168 }
1169
1170
1171 S_FUNC VALUE
f_srandom(int count,VALUE ** vals)1172 f_srandom(int count, VALUE **vals)
1173 {
1174 VALUE result;
1175
1176 /* initialize VALUE */
1177 result.v_type = V_RANDOM;
1178 result.v_subtype = V_NOSUBTYPE;
1179
1180 /* parse args */
1181 switch (count) {
1182 case 0: /* srandom() */
1183 /* get the current random state */
1184 result.v_random = zsetrandom(NULL);
1185 break;
1186
1187 case 1: /* srandom(seed) or srandom(state) */
1188 switch (vals[0]->v_type) {
1189 case V_NUM: /* srand(seed) */
1190 /* seed Blum and return previous state */
1191 if (!qisint(vals[0]->v_num)) {
1192 math_error(
1193 "srandom number seed must be an integer");
1194 /*NOTREACHED*/
1195 }
1196 result.v_random = zsrandom1(vals[0]->v_num->num, TRUE);
1197 break;
1198
1199 case V_RANDOM: /* srandom(state) */
1200 /* set a55 state and return previous state */
1201 result.v_random = zsetrandom(vals[0]->v_random);
1202 break;
1203
1204 default:
1205 math_error("illegal type of arg passed to srandom()");
1206 /*NOTREACHED*/
1207 break;
1208 }
1209 break;
1210
1211 case 2: /* srandom(seed, newn) */
1212 if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) {
1213 math_error("srandom seed must be an integer");
1214 /*NOTREACHED*/
1215 }
1216 if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) {
1217 math_error("srandom Blum modulus must be an integer");
1218 /*NOTREACHED*/
1219 }
1220 result.v_random = zsrandom2(vals[0]->v_num->num,
1221 vals[1]->v_num->num);
1222 break;
1223
1224 case 4: /* srandom(seed, ip, iq, trials) */
1225 if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) {
1226 math_error("srandom seed must be an integer");
1227 /*NOTREACHED*/
1228 }
1229 if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) {
1230 math_error("srandom 2nd arg must be an integer");
1231 /*NOTREACHED*/
1232 }
1233 if (vals[2]->v_type != V_NUM || !qisint(vals[2]->v_num)) {
1234 math_error("srandom 3rd arg must be an integer");
1235 /*NOTREACHED*/
1236 }
1237 if (vals[3]->v_type != V_NUM || !qisint(vals[3]->v_num)) {
1238 math_error("srandom 4th arg must be an integer");
1239 /*NOTREACHED*/
1240 }
1241 if (zge24b(vals[3]->v_num->num)) {
1242 math_error("srandom trials count is excessive");
1243 /*NOTREACHED*/
1244 }
1245 result.v_random = zsrandom4(vals[0]->v_num->num,
1246 vals[1]->v_num->num,
1247 vals[2]->v_num->num,
1248 ztoi(vals[3]->v_num->num));
1249 break;
1250
1251 default:
1252 math_error("bad arg count to srandom()");
1253 /*NOTREACHED*/
1254 break;
1255 }
1256
1257 /* return the current state */
1258 return result;
1259 }
1260
1261
1262 S_FUNC NUMBER *
f_primetest(int count,NUMBER ** vals)1263 f_primetest(int count, NUMBER **vals)
1264 {
1265 /* parse args */
1266 switch (count) {
1267 case 1: qlink(&_qone_);
1268 qlink(&_qone_);
1269 return itoq((long) qprimetest(vals[0], &_qone_, &_qone_));
1270 case 2: qlink(&_qone_);
1271 return itoq((long) qprimetest(vals[0], vals[1], &_qone_));
1272 default: return itoq((long) qprimetest(vals[0], vals[1], vals[2]));
1273 }
1274 }
1275
1276
1277 S_FUNC VALUE
f_setbit(int count,VALUE ** vals)1278 f_setbit(int count, VALUE **vals)
1279 {
1280 BOOL r;
1281 long index;
1282 VALUE result;
1283
1284 /* initialize VALUE */
1285 result.v_type = V_NULL;
1286 result.v_subtype = V_NOSUBTYPE;
1287
1288 r = (count == 3) ? testvalue(vals[2]) : 1;
1289
1290 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
1291 return error_value(E_SETBIT1);
1292 if (zge31b(vals[1]->v_num->num))
1293 return error_value(E_SETBIT2);
1294 if (vals[0]->v_type != V_STR)
1295 return error_value(E_SETBIT3);
1296 index = qtoi(vals[1]->v_num);
1297 if (stringsetbit(vals[0]->v_str, index, r))
1298 return error_value(E_SETBIT2);
1299 return result;
1300 }
1301
1302
1303 S_FUNC VALUE
f_digit(int count,VALUE ** vals)1304 f_digit(int count, VALUE **vals)
1305 {
1306 VALUE res;
1307 ZVALUE base;
1308
1309 if (vals[0]->v_type != V_NUM)
1310 return error_value(E_DGT1);
1311
1312 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
1313 return error_value(E_DGT2);
1314
1315 if (count == 3) {
1316 if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num))
1317 return error_value(E_DGT3);
1318 base = vals[2]->v_num->num;
1319 } else {
1320 base = _ten_;
1321 }
1322 res.v_type = V_NUM;
1323 res.v_subtype = V_NOSUBTYPE;
1324 res.v_num = qdigit(vals[0]->v_num, vals[1]->v_num->num, base);
1325 if (res.v_num == NULL)
1326 return error_value(E_DGT3);
1327
1328 return res;
1329 }
1330
1331
1332 S_FUNC VALUE
f_digits(int count,VALUE ** vals)1333 f_digits(int count, VALUE **vals)
1334 {
1335 ZVALUE base;
1336 VALUE res;
1337
1338 if (vals[0]->v_type != V_NUM)
1339 return error_value(E_DGTS1);
1340 if (count > 1) {
1341 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)
1342 || qiszero(vals[1]->v_num) || qisunit(vals[1]->v_num))
1343 return error_value(E_DGTS2);
1344 base = vals[1]->v_num->num;
1345 } else {
1346 base = _ten_;
1347 }
1348 res.v_type = V_NUM;
1349 res.v_subtype = V_NOSUBTYPE;
1350 res.v_num = itoq(qdigits(vals[0]->v_num, base));
1351 return res;
1352 }
1353
1354
1355 S_FUNC VALUE
f_places(int count,VALUE ** vals)1356 f_places(int count, VALUE **vals)
1357 {
1358 long places;
1359 VALUE res;
1360
1361 if (vals[0]->v_type != V_NUM)
1362 return error_value(E_PLCS1);
1363 if (count > 1) {
1364 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
1365 return error_value(E_PLCS2);
1366 places = qplaces(vals[0]->v_num, vals[1]->v_num->num);
1367 if (places == -2)
1368 return error_value(E_PLCS2);
1369 } else
1370 places = qdecplaces(vals[0]->v_num);
1371
1372 res.v_type = V_NUM;
1373 res.v_subtype = V_NOSUBTYPE;
1374 res.v_num = itoq(places);
1375 return res;
1376 }
1377
1378
1379 S_FUNC NUMBER *
f_popcnt(int count,NUMBER ** vals)1380 f_popcnt(int count, NUMBER **vals)
1381 {
1382 int bitval = 1;
1383
1384 /*
1385 * parse args
1386 */
1387 if (count == 2 && qiszero(vals[1])) {
1388 bitval = 0;
1389 }
1390
1391 /*
1392 * count bit values
1393 */
1394 if (qisint(vals[0])) {
1395 return itoq(zpopcnt(vals[0]->num, bitval));
1396 } else {
1397 return itoq(zpopcnt(vals[0]->num, bitval) +
1398 zpopcnt(vals[0]->den, bitval));
1399 }
1400 }
1401
1402
1403 S_FUNC VALUE
f_xor(int count,VALUE ** vals)1404 f_xor(int count, VALUE **vals)
1405 {
1406 NUMBER *q, *qtmp;
1407 STRING *s, *stmp;
1408 VALUE result;
1409 int i;
1410 int type;
1411
1412 type = vals[0]->v_type;
1413 result.v_type = type;
1414 result.v_subtype = vals[0]->v_subtype;
1415 for (i = 1; i < count; i++) {
1416 if (vals[i]->v_type != type)
1417 return error_value(E_XOR1);
1418 }
1419 switch (type) {
1420 case V_NUM:
1421 q = qlink(vals[0]->v_num);
1422 for (i = 1; i < count; i++) {
1423 qtmp = qxor(q, vals[i]->v_num);
1424 qfree(q);
1425 q = qtmp;
1426 }
1427 result.v_num = q;
1428 break;
1429 case V_STR:
1430 s = slink(vals[0]->v_str);
1431 for (i = 1; i < count; i++) {
1432 stmp = stringxor(s, vals[i]->v_str);
1433 sfree(s);
1434 s = stmp;
1435 }
1436 result.v_str = s;
1437 break;
1438 default:
1439 return error_value(E_XOR2);
1440 }
1441 return result;
1442 }
1443
1444
1445 VALUE
minlistitems(LIST * lp)1446 minlistitems(LIST *lp)
1447 {
1448 LISTELEM *ep;
1449 VALUE *vp;
1450 VALUE term;
1451 VALUE rel;
1452 VALUE min;
1453
1454 /* initialize VALUEs */
1455 min.v_type = V_NULL;
1456 min.v_subtype = V_NOSUBTYPE;
1457 term.v_type = V_NULL;
1458 term.v_subtype = V_NOSUBTYPE;
1459
1460 for (ep = lp->l_first; ep; ep = ep->e_next) {
1461 vp = &ep->e_value;
1462 switch(vp->v_type) {
1463 case V_LIST:
1464 term = minlistitems(vp->v_list);
1465 break;
1466 case V_OBJ:
1467 term = objcall(OBJ_MIN, vp,
1468 NULL_VALUE, NULL_VALUE);
1469 break;
1470 default:
1471 copyvalue(vp, &term);
1472 }
1473 if (min.v_type == V_NULL) {
1474 min = term;
1475 continue;
1476 }
1477 if (term.v_type == V_NULL)
1478 continue;
1479 relvalue(&term, &min, &rel);
1480 if (rel.v_type != V_NUM) {
1481 freevalue(&term);
1482 freevalue(&min);
1483 freevalue(&rel);
1484 return error_value(E_LISTMIN);
1485 }
1486 if (qisneg(rel.v_num)) {
1487 freevalue(&min);
1488 min = term;
1489 }
1490 else
1491 freevalue(&term);
1492 freevalue(&rel);
1493 }
1494 return min;
1495 }
1496
1497
1498 VALUE
maxlistitems(LIST * lp)1499 maxlistitems(LIST *lp)
1500 {
1501 LISTELEM *ep;
1502 VALUE *vp;
1503 VALUE term;
1504 VALUE rel;
1505 VALUE max;
1506
1507 /* initialize VALUEs */
1508 max.v_type = V_NULL;
1509 max.v_subtype = V_NOSUBTYPE;
1510 term.v_type = V_NULL;
1511 term.v_subtype = V_NOSUBTYPE;
1512
1513 for (ep = lp->l_first; ep; ep = ep->e_next) {
1514 vp = &ep->e_value;
1515 switch(vp->v_type) {
1516 case V_LIST:
1517 term = maxlistitems(vp->v_list);
1518 break;
1519 case V_OBJ:
1520 term = objcall(OBJ_MAX, vp,
1521 NULL_VALUE, NULL_VALUE);
1522 break;
1523 default:
1524 copyvalue(vp, &term);
1525 }
1526 if (max.v_type == V_NULL) {
1527 max = term;
1528 continue;
1529 }
1530 if (term.v_type == V_NULL)
1531 continue;
1532 relvalue(&max, &term, &rel);
1533 if (rel.v_type != V_NUM) {
1534 freevalue(&max);
1535 freevalue(&term);
1536 freevalue(&rel);
1537 return error_value(E_LISTMAX);
1538 }
1539 if (qisneg(rel.v_num)) {
1540 freevalue(&max);
1541 max = term;
1542 }
1543 else
1544 freevalue(&term);
1545 freevalue(&rel);
1546 }
1547 return max;
1548 }
1549
1550
1551 S_FUNC VALUE
f_min(int count,VALUE ** vals)1552 f_min(int count, VALUE **vals)
1553 {
1554 VALUE min;
1555 VALUE term;
1556 VALUE *vp;
1557 VALUE rel;
1558
1559 /* initialize VALUEs */
1560 min.v_type = V_NULL;
1561 min.v_subtype = V_NOSUBTYPE;
1562 term.v_type = V_NULL;
1563 term.v_subtype = V_NOSUBTYPE;
1564
1565 while (count-- > 0) {
1566 vp = *vals++;
1567 switch(vp->v_type) {
1568 case V_LIST:
1569 term = minlistitems(vp->v_list);
1570 break;
1571 case V_OBJ:
1572 term = objcall(OBJ_MIN, vp,
1573 NULL_VALUE, NULL_VALUE);
1574 break;
1575 default:
1576 copyvalue(vp, &term);
1577 }
1578 if (min.v_type == V_NULL) {
1579 min = term;
1580 continue;
1581 }
1582 if (term.v_type == V_NULL)
1583 continue;
1584 if (term.v_type < 0) {
1585 freevalue(&min);
1586 return term;
1587 }
1588 relvalue(&term, &min, &rel);
1589 if (rel.v_type != V_NUM) {
1590 freevalue(&min);
1591 freevalue(&term);
1592 freevalue(&rel);
1593 return error_value(E_MIN);
1594 }
1595 if (qisneg(rel.v_num)) {
1596 freevalue(&min);
1597 min = term;
1598 } else {
1599 freevalue(&term);
1600 }
1601 freevalue(&rel);
1602 }
1603 return min;
1604 }
1605
1606
1607 S_FUNC VALUE
f_max(int count,VALUE ** vals)1608 f_max(int count, VALUE **vals)
1609 {
1610 VALUE max;
1611 VALUE term;
1612 VALUE *vp;
1613 VALUE rel;
1614
1615 /* initialize VALUEs */
1616 max.v_type = V_NULL;
1617 max.v_subtype = V_NOSUBTYPE;
1618 term.v_type = V_NULL;
1619 term.v_subtype = V_NOSUBTYPE;
1620
1621 while (count-- > 0) {
1622 vp = *vals++;
1623 switch(vp->v_type) {
1624 case V_LIST:
1625 term = maxlistitems(vp->v_list);
1626 break;
1627 case V_OBJ:
1628 term = objcall(OBJ_MAX, vp,
1629 NULL_VALUE, NULL_VALUE);
1630 break;
1631 default:
1632 copyvalue(vp, &term);
1633 }
1634 if (max.v_type == V_NULL) {
1635 max = term;
1636 continue;
1637 }
1638 if (term.v_type == V_NULL)
1639 continue;
1640 if (term.v_type < 0) {
1641 freevalue(&max);
1642 return term;
1643 }
1644 relvalue(&max, &term, &rel);
1645 if (rel.v_type != V_NUM) {
1646 freevalue(&max);
1647 freevalue(&term);
1648 freevalue(&rel);
1649 return error_value(E_MAX);
1650 }
1651 if (qisneg(rel.v_num)) {
1652 freevalue(&max);
1653 max = term;
1654 } else {
1655 freevalue(&term);
1656 }
1657 freevalue(&rel);
1658 }
1659 return max;
1660 }
1661
1662
1663 S_FUNC NUMBER *
f_gcd(int count,NUMBER ** vals)1664 f_gcd(int count, NUMBER **vals)
1665 {
1666 NUMBER *val, *tmp;
1667
1668 val = qqabs(*vals);
1669 while (--count > 0) {
1670 tmp = qgcd(val, *++vals);
1671 qfree(val);
1672 val = tmp;
1673 }
1674 return val;
1675 }
1676
1677
1678 S_FUNC NUMBER *
f_lcm(int count,NUMBER ** vals)1679 f_lcm(int count, NUMBER **vals)
1680 {
1681 NUMBER *val, *tmp;
1682
1683 val = qqabs(*vals);
1684 while (--count > 0) {
1685 tmp = qlcm(val, *++vals);
1686 qfree(val);
1687 val = tmp;
1688 if (qiszero(val))
1689 break;
1690 }
1691 return val;
1692 }
1693
1694
1695 S_FUNC VALUE
f_hash(int count,VALUE ** vals)1696 f_hash(int count, VALUE **vals)
1697 {
1698 QCKHASH hash;
1699 VALUE result;
1700
1701 /* initialize VALUE */
1702 result.v_type = V_NUM;
1703 result.v_subtype = V_NOSUBTYPE;
1704
1705 hash = QUICKHASH_BASIS;
1706 while (count-- > 0)
1707 hash = hashvalue(*vals++, hash);
1708 result.v_num = utoq((FULL) hash);
1709 return result;
1710 }
1711
1712
1713 VALUE
sumlistitems(LIST * lp)1714 sumlistitems(LIST *lp)
1715 {
1716 LISTELEM *ep;
1717 VALUE *vp;
1718 VALUE term;
1719 VALUE tmp;
1720 VALUE sum;
1721
1722 /* initialize VALUEs */
1723 term.v_type = V_NULL;
1724 term.v_subtype = V_NOSUBTYPE;
1725 tmp.v_type = V_NULL;
1726 tmp.v_subtype = V_NOSUBTYPE;
1727 sum.v_type = V_NULL;
1728 sum.v_subtype = V_NOSUBTYPE;
1729
1730 for (ep = lp->l_first; ep; ep = ep->e_next) {
1731 vp = &ep->e_value;
1732 switch(vp->v_type) {
1733 case V_LIST:
1734 term = sumlistitems(vp->v_list);
1735 break;
1736 case V_OBJ:
1737 term = objcall(OBJ_SUM, vp,
1738 NULL_VALUE, NULL_VALUE);
1739 break;
1740 default:
1741 addvalue(&sum, vp, &tmp);
1742 freevalue(&sum);
1743 if (tmp.v_type < 0)
1744 return tmp;
1745 sum = tmp;
1746 continue;
1747 }
1748 addvalue(&sum, &term, &tmp);
1749 freevalue(&sum);
1750 freevalue(&term);
1751 sum = tmp;
1752 if (sum.v_type < 0)
1753 break;
1754 }
1755 return sum;
1756 }
1757
1758
1759 S_FUNC VALUE
f_sum(int count,VALUE ** vals)1760 f_sum(int count, VALUE **vals)
1761 {
1762 VALUE tmp;
1763 VALUE sum;
1764 VALUE term;
1765 VALUE *vp;
1766
1767 /* initialize VALUEs */
1768 tmp.v_type = V_NULL;
1769 tmp.v_subtype = V_NOSUBTYPE;
1770 sum.v_type = V_NULL;
1771 sum.v_subtype = V_NOSUBTYPE;
1772 term.v_type = V_NULL;
1773 term.v_subtype = V_NOSUBTYPE;
1774 while (count-- > 0) {
1775 vp = *vals++;
1776 switch(vp->v_type) {
1777 case V_LIST:
1778 term = sumlistitems(vp->v_list);
1779 break;
1780 case V_OBJ:
1781 term = objcall(OBJ_SUM, vp,
1782 NULL_VALUE, NULL_VALUE);
1783 break;
1784 default:
1785 addvalue(&sum, vp, &tmp);
1786 freevalue(&sum);
1787 if (tmp.v_type < 0)
1788 return tmp;
1789 sum = tmp;
1790 continue;
1791 }
1792 addvalue(&sum, &term, &tmp);
1793 freevalue(&term);
1794 freevalue(&sum);
1795 sum = tmp;
1796 if (sum.v_type < 0)
1797 break;
1798 }
1799 return sum;
1800 }
1801
1802
1803 S_FUNC VALUE
f_avg(int count,VALUE ** vals)1804 f_avg(int count, VALUE **vals)
1805 {
1806 VALUE tmp;
1807 VALUE sum;
1808 VALUE div;
1809 long n;
1810
1811 /* initialize VALUEs */
1812 tmp.v_type = V_NULL;
1813 tmp.v_subtype = V_NOSUBTYPE;
1814 sum.v_type = V_NULL;
1815 sum.v_subtype = V_NOSUBTYPE;
1816 div.v_type = V_NULL;
1817 div.v_subtype = V_NOSUBTYPE;
1818
1819 n = 0;
1820 while (count-- > 0) {
1821 if ((*vals)->v_type == V_LIST) {
1822 addlistitems((*vals)->v_list, &sum);
1823 n += countlistitems((*vals++)->v_list);
1824 } else {
1825 addvalue(&sum, *vals++, &tmp);
1826 freevalue(&sum);
1827 sum = tmp;
1828 n++;
1829 }
1830 if (sum.v_type < 0)
1831 return sum;
1832 }
1833 if (n < 2)
1834 return sum;
1835 div.v_num = itoq(n);
1836 div.v_type = V_NUM;
1837 div.v_subtype = V_NOSUBTYPE;
1838 divvalue(&sum, &div, &tmp);
1839 freevalue(&sum);
1840 qfree(div.v_num);
1841 return tmp;
1842 }
1843
1844
1845 S_FUNC VALUE
f_fact(VALUE * vp)1846 f_fact(VALUE *vp)
1847 {
1848 VALUE res;
1849
1850 /* initialize VALUE */
1851 res.v_type = V_NUM;
1852 res.v_subtype = V_NOSUBTYPE;
1853
1854 if (vp->v_type == V_OBJ) {
1855 return objcall(OBJ_FACT, vp, NULL_VALUE, NULL_VALUE);
1856 }
1857 if (vp->v_type != V_NUM) {
1858 math_error("Non-real argument for fact()");
1859 /*NOTREACHED*/
1860 }
1861 res.v_num = qfact(vp->v_num);
1862 return res;
1863 }
1864
1865
1866 S_FUNC VALUE
f_hmean(int count,VALUE ** vals)1867 f_hmean(int count, VALUE **vals)
1868 {
1869 VALUE sum, tmp1, tmp2;
1870 long n = 0;
1871
1872 /* initialize VALUEs */
1873 sum.v_type = V_NULL;
1874 sum.v_subtype = V_NOSUBTYPE;
1875 tmp1.v_type = V_NULL;
1876 tmp1.v_subtype = V_NOSUBTYPE;
1877 tmp2.v_type = V_NULL;
1878 tmp2.v_subtype = V_NOSUBTYPE;
1879
1880 while (count-- > 0) {
1881 if ((*vals)->v_type == V_LIST) {
1882 addlistinv((*vals)->v_list, &sum);
1883 n += countlistitems((*vals++)->v_list);
1884 } else {
1885 invertvalue(*vals++, &tmp1);
1886 addvalue(&sum, &tmp1, &tmp2);
1887 freevalue(&tmp1);
1888 freevalue(&sum);
1889 sum = tmp2;
1890 n++;
1891 }
1892 }
1893 if (n == 0)
1894 return sum;
1895 tmp1.v_type = V_NUM;
1896 tmp1.v_subtype = V_NOSUBTYPE;
1897 tmp1.v_num = itoq(n);
1898 divvalue(&tmp1, &sum, &tmp2);
1899 qfree(tmp1.v_num);
1900 freevalue(&sum);
1901 return tmp2;
1902 }
1903
1904
1905 S_FUNC NUMBER *
f_hnrmod(NUMBER * val1,NUMBER * val2,NUMBER * val3,NUMBER * val4)1906 f_hnrmod(NUMBER *val1, NUMBER *val2, NUMBER *val3, NUMBER *val4)
1907 {
1908 ZVALUE answer; /* v mod h*2^n+r */
1909 NUMBER *res; /* v mod h*2^n+r */
1910
1911 /*
1912 * firewall
1913 */
1914 if (qisfrac(val1)) {
1915 math_error("1st arg of hnrmod (v) must be an integer");
1916 /*NOTREACHED*/
1917 }
1918 if (qisfrac(val2) || qisneg(val2) || qiszero(val2)) {
1919 math_error("2nd arg of hnrmod (h) must be an integer > 0");
1920 /*NOTREACHED*/
1921 }
1922 if (qisfrac(val3) || qisneg(val3) || qiszero(val3)) {
1923 math_error("3rd arg of hnrmod (n) must be an integer > 0");
1924 /*NOTREACHED*/
1925 }
1926 if (qisfrac(val4) || !zisabsleone(val4->num)) {
1927 math_error("4th arg of hnrmod (r) must be -1, 0 or 1");
1928 /*NOTREACHED*/
1929 }
1930
1931 /*
1932 * perform the val1 mod (val2 * 2^val3 + val4) operation
1933 */
1934 zhnrmod(val1->num, val2->num, val3->num, val4->num, &answer);
1935
1936 /*
1937 * return the answer
1938 */
1939 res = qalloc();
1940 res->num = answer;
1941 return res;
1942 }
1943
1944 VALUE
ssqlistitems(LIST * lp)1945 ssqlistitems(LIST *lp)
1946 {
1947 LISTELEM *ep;
1948 VALUE *vp;
1949 VALUE term;
1950 VALUE tmp;
1951 VALUE sum;
1952
1953 /* initialize VALUEs */
1954 term.v_type = V_NULL;
1955 term.v_subtype = V_NOSUBTYPE;
1956 tmp.v_type = V_NULL;
1957 tmp.v_subtype = V_NOSUBTYPE;
1958 sum.v_type = V_NULL;
1959 sum.v_subtype = V_NOSUBTYPE;
1960
1961 for (ep = lp->l_first; ep; ep = ep->e_next) {
1962 vp = &ep->e_value;
1963 if (vp->v_type == V_LIST) {
1964 term = ssqlistitems(vp->v_list);
1965 } else {
1966 squarevalue(vp, &term);
1967 }
1968 addvalue(&sum, &term, &tmp);
1969 freevalue(&sum);
1970 freevalue(&term);
1971 sum = tmp;
1972 if (sum.v_type < 0)
1973 break;
1974 }
1975 return sum;
1976 }
1977
1978 S_FUNC VALUE
f_ssq(int count,VALUE ** vals)1979 f_ssq(int count, VALUE **vals)
1980 {
1981 VALUE tmp;
1982 VALUE sum;
1983 VALUE term;
1984 VALUE *vp;
1985
1986 /* initialize VALUEs */
1987 tmp.v_type = V_NULL;
1988 tmp.v_subtype = V_NOSUBTYPE;
1989 sum.v_type = V_NULL;
1990 sum.v_subtype = V_NOSUBTYPE;
1991 term.v_type = V_NULL;
1992 term.v_subtype = V_NOSUBTYPE;
1993 while (count-- > 0) {
1994 vp = *vals++;
1995 if (vp->v_type == V_LIST) {
1996 term = ssqlistitems(vp->v_list);
1997 } else {
1998 squarevalue(vp, &term);
1999 }
2000 addvalue(&sum, &term, &tmp);
2001 freevalue(&term);
2002 freevalue(&sum);
2003 sum = tmp;
2004 if (sum.v_type < 0)
2005 break;
2006 }
2007 return sum;
2008 }
2009
2010
2011 S_FUNC NUMBER *
f_ismult(NUMBER * val1,NUMBER * val2)2012 f_ismult(NUMBER *val1, NUMBER *val2)
2013 {
2014 return itoq((long) qdivides(val1, val2));
2015 }
2016
2017
2018 S_FUNC NUMBER *
f_meq(NUMBER * val1,NUMBER * val2,NUMBER * val3)2019 f_meq(NUMBER *val1, NUMBER *val2, NUMBER *val3)
2020 {
2021 NUMBER *tmp, *res;
2022
2023 tmp = qsub(val1, val2);
2024 res = itoq((long) qdivides(tmp, val3));
2025 qfree(tmp);
2026 return res;
2027 }
2028
2029
2030 S_FUNC VALUE
f_exp(int count,VALUE ** vals)2031 f_exp(int count, VALUE **vals)
2032 {
2033 VALUE result;
2034 NUMBER *eps;
2035 NUMBER *q;
2036 COMPLEX *c;
2037
2038 /* initialize VALUE */
2039 result.v_subtype = V_NOSUBTYPE;
2040
2041 eps = conf->epsilon;
2042 if (count == 2) {
2043 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2044 return error_value(E_EXP1);
2045 eps = vals[1]->v_num;
2046 }
2047 switch (vals[0]->v_type) {
2048 case V_NUM:
2049 q = qexp(vals[0]->v_num, eps);
2050 if (q == NULL)
2051 return error_value(E_EXP3);
2052 result.v_num = q;
2053 result.v_type = V_NUM;
2054 break;
2055 case V_COM:
2056 c = c_exp(vals[0]->v_com, eps);
2057 if (c == NULL)
2058 return error_value(E_EXP3);
2059 result.v_com = c;
2060 result.v_type = V_COM;
2061 if (cisreal(c)) {
2062 result.v_num = qlink(c->real);
2063 result.v_type = V_NUM;
2064 comfree(c);
2065 }
2066 break;
2067 default:
2068 return error_value(E_EXP2);
2069 }
2070 return result;
2071 }
2072
2073
2074 S_FUNC VALUE
f_ln(int count,VALUE ** vals)2075 f_ln(int count, VALUE **vals)
2076 {
2077 VALUE result;
2078 COMPLEX ctmp, *c;
2079 NUMBER *err;
2080
2081 /* initialize VALUE */
2082 result.v_subtype = V_NOSUBTYPE;
2083
2084 err = conf->epsilon;
2085 if (count == 2) {
2086 if (vals[1]->v_type != V_NUM)
2087 return error_value(E_LN1);
2088 err = vals[1]->v_num;
2089 }
2090 switch (vals[0]->v_type) {
2091 case V_NUM:
2092 if (!qisneg(vals[0]->v_num) &&
2093 !qiszero(vals[0]->v_num)) {
2094 result.v_num = qln(vals[0]->v_num, err);
2095 result.v_type = V_NUM;
2096 return result;
2097 }
2098 ctmp.real = vals[0]->v_num;
2099 ctmp.imag = qlink(&_qzero_);
2100 ctmp.links = 1;
2101 c = c_ln(&ctmp, err);
2102 break;
2103 case V_COM:
2104 c = c_ln(vals[0]->v_com, err);
2105 break;
2106 default:
2107 return error_value(E_LN2);
2108 }
2109 result.v_type = V_COM;
2110 result.v_com = c;
2111 if (cisreal(c)) {
2112 result.v_num = qlink(c->real);
2113 result.v_type = V_NUM;
2114 comfree(c);
2115 }
2116 return result;
2117 }
2118
2119
2120 S_FUNC VALUE
f_log(int count,VALUE ** vals)2121 f_log(int count, VALUE **vals)
2122 {
2123 VALUE result;
2124 COMPLEX ctmp, *c;
2125 NUMBER *err;
2126
2127 /* initialize VALUE */
2128 result.v_subtype = V_NOSUBTYPE;
2129
2130 err = conf->epsilon;
2131 if (count == 2) {
2132 if (vals[1]->v_type != V_NUM)
2133 return error_value(E_LOG1);
2134 err = vals[1]->v_num;
2135 }
2136 switch (vals[0]->v_type) {
2137 case V_NUM:
2138 if (!qisneg(vals[0]->v_num) &&
2139 !qiszero(vals[0]->v_num)) {
2140 result.v_num = qlog(vals[0]->v_num, err);
2141 result.v_type = V_NUM;
2142 return result;
2143 }
2144 ctmp.real = vals[0]->v_num;
2145 ctmp.imag = qlink(&_qzero_);
2146 ctmp.links = 1;
2147 c = c_log(&ctmp, err);
2148 break;
2149 case V_COM:
2150 c = c_log(vals[0]->v_com, err);
2151 break;
2152 default:
2153 return error_value(E_LOG2);
2154 }
2155 if (c == NULL) {
2156 return error_value(E_LOG3);
2157 }
2158 result.v_type = V_COM;
2159 result.v_com = c;
2160 if (cisreal(c)) {
2161 result.v_num = qlink(c->real);
2162 result.v_type = V_NUM;
2163 comfree(c);
2164 }
2165 return result;
2166 }
2167
2168
2169 S_FUNC VALUE
f_cos(int count,VALUE ** vals)2170 f_cos(int count, VALUE **vals)
2171 {
2172 VALUE result;
2173 COMPLEX *c;
2174 NUMBER *eps;
2175
2176 /* initialize VALUE */
2177 result.v_subtype = V_NOSUBTYPE;
2178
2179 eps = conf->epsilon;
2180 if (count == 2) {
2181 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2182 return error_value(E_COS1);
2183 eps = vals[1]->v_num;
2184 }
2185 switch (vals[0]->v_type) {
2186 case V_NUM:
2187 result.v_num = qcos(vals[0]->v_num, eps);
2188 result.v_type = V_NUM;
2189 break;
2190 case V_COM:
2191 c = c_cos(vals[0]->v_com, eps);
2192 if (c == NULL)
2193 return error_value(E_COS3);
2194 result.v_com = c;
2195 result.v_type = V_COM;
2196 if (cisreal(c)) {
2197 result.v_num = qlink(c->real);
2198 result.v_type = V_NUM;
2199 comfree(c);
2200 }
2201 break;
2202 default:
2203 return error_value(E_COS2);
2204 }
2205 return result;
2206 }
2207
2208
2209 /*
2210 * f_d2r - convert degrees to radians
2211 */
2212 S_FUNC VALUE
f_d2r(int count,VALUE ** vals)2213 f_d2r(int count, VALUE **vals)
2214 {
2215 VALUE result;
2216 NUMBER *eps;
2217 NUMBER *pidiv180;
2218
2219 /* initialize VALUE */
2220 result.v_subtype = V_NOSUBTYPE;
2221
2222 /* firewall */
2223 eps = conf->epsilon;
2224 if (count == 2) {
2225 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2226 return error_value(E_D2R1);
2227 eps = vals[1]->v_num;
2228 }
2229
2230 /* calculate argument * (pi/180) */
2231 switch (vals[0]->v_type) {
2232 case V_NUM:
2233 pidiv180 = qpidiv180(eps);
2234 result.v_num = qmul(vals[0]->v_num, pidiv180);
2235 result.v_type = V_NUM;
2236 qfree(pidiv180);
2237 break;
2238 case V_COM:
2239 pidiv180 = qpidiv180(eps);
2240 result.v_com = c_mulq(vals[0]->v_com, pidiv180);
2241 result.v_type = V_COM;
2242 qfree(pidiv180);
2243 break;
2244 default:
2245 return error_value(E_D2R2);
2246 }
2247 return result;
2248 }
2249
2250
2251 /*
2252 * f_r2d - convert radians to degrees
2253 */
2254 S_FUNC VALUE
f_r2d(int count,VALUE ** vals)2255 f_r2d(int count, VALUE **vals)
2256 {
2257 VALUE result;
2258 NUMBER *eps;
2259 NUMBER *pidiv180;
2260
2261 /* initialize VALUE */
2262 result.v_subtype = V_NOSUBTYPE;
2263
2264 /* firewall */
2265 eps = conf->epsilon;
2266 if (count == 2) {
2267 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2268 return error_value(E_R2D1);
2269 eps = vals[1]->v_num;
2270 }
2271
2272 /* calculate argument / (pi/180) */
2273 switch (vals[0]->v_type) {
2274 case V_NUM:
2275 pidiv180 = qpidiv180(eps);
2276 result.v_num = qqdiv(vals[0]->v_num, pidiv180);
2277 result.v_type = V_NUM;
2278 qfree(pidiv180);
2279 break;
2280 case V_COM:
2281 pidiv180 = qpidiv180(eps);
2282 result.v_com = c_divq(vals[0]->v_com, pidiv180);
2283 result.v_type = V_COM;
2284 qfree(pidiv180);
2285 break;
2286 default:
2287 return error_value(E_R2D2);
2288 }
2289 return result;
2290 }
2291
2292
2293 /*
2294 * f_d2r - convert gradians to radians
2295 */
2296 S_FUNC VALUE
f_g2r(int count,VALUE ** vals)2297 f_g2r(int count, VALUE **vals)
2298 {
2299 VALUE result;
2300 NUMBER *eps;
2301 NUMBER *pidiv200;
2302
2303 /* initialize VALUE */
2304 result.v_subtype = V_NOSUBTYPE;
2305
2306 /* firewall */
2307 eps = conf->epsilon;
2308 if (count == 2) {
2309 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2310 return error_value(E_G2R1);
2311 eps = vals[1]->v_num;
2312 }
2313
2314 /* calculate argument * (pi/200) */
2315 switch (vals[0]->v_type) {
2316 case V_NUM:
2317 pidiv200 = qpidiv200(eps);
2318 result.v_num = qmul(vals[0]->v_num, pidiv200);
2319 result.v_type = V_NUM;
2320 qfree(pidiv200);
2321 break;
2322 case V_COM:
2323 pidiv200 = qpidiv200(eps);
2324 result.v_com = c_mulq(vals[0]->v_com, pidiv200);
2325 result.v_type = V_COM;
2326 qfree(pidiv200);
2327 break;
2328 default:
2329 return error_value(E_G2R2);
2330 }
2331 return result;
2332 }
2333
2334
2335 /*
2336 * f_r2g - convert radians to gradians
2337 */
2338 S_FUNC VALUE
f_r2g(int count,VALUE ** vals)2339 f_r2g(int count, VALUE **vals)
2340 {
2341 VALUE result;
2342 NUMBER *eps;
2343 NUMBER *pidiv200;
2344
2345 /* initialize VALUE */
2346 result.v_subtype = V_NOSUBTYPE;
2347
2348 /* firewall */
2349 eps = conf->epsilon;
2350 if (count == 2) {
2351 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2352 return error_value(E_R2G1);
2353 eps = vals[1]->v_num;
2354 }
2355
2356 /* calculate argument / (pi/200) */
2357 switch (vals[0]->v_type) {
2358 case V_NUM:
2359 pidiv200 = qpidiv200(eps);
2360 result.v_num = qqdiv(vals[0]->v_num, pidiv200);
2361 result.v_type = V_NUM;
2362 qfree(pidiv200);
2363 break;
2364 case V_COM:
2365 pidiv200 = qpidiv200(eps);
2366 result.v_com = c_divq(vals[0]->v_com, pidiv200);
2367 result.v_type = V_COM;
2368 qfree(pidiv200);
2369 break;
2370 default:
2371 return error_value(E_R2G2);
2372 }
2373 return result;
2374 }
2375
2376
2377 /*
2378 * f_d2g - convert degrees to gradians
2379 *
2380 * NOTE: The epsilon (vals[1]->v_num) argument is ignored.
2381 */
2382 /*ARGSUSED*/
2383 S_FUNC VALUE
f_d2g(int UNUSED (count),VALUE ** vals)2384 f_d2g(int UNUSED(count), VALUE **vals)
2385 {
2386 VALUE result;
2387
2388 /* initialize VALUE */
2389 result.v_subtype = V_NOSUBTYPE;
2390
2391 /* NOTE: the epsilon (vals[1]->v_num) argument is ignored */
2392
2393 /* calculate argument * (10/9) */
2394 switch (vals[0]->v_type) {
2395 case V_NUM:
2396 result.v_num = qmul(vals[0]->v_num, &_qtendivnine_);
2397 result.v_type = V_NUM;
2398 break;
2399 case V_COM:
2400 result.v_com = c_mulq(vals[0]->v_com, &_qtendivnine_);
2401 result.v_type = V_COM;
2402 break;
2403 default:
2404 return error_value(E_D2G1);
2405 }
2406 return result;
2407 }
2408
2409
2410 /*
2411 * f_g2d - convert gradians to degrees
2412 *
2413 * NOTE: The epsilon (vals[1]->v_num) argument is ignored.
2414 */
2415 /*ARGSUSED*/
2416 S_FUNC VALUE
f_g2d(int UNUSED (count),VALUE ** vals)2417 f_g2d(int UNUSED(count), VALUE **vals)
2418 {
2419 VALUE result;
2420
2421 /* initialize VALUE */
2422 result.v_subtype = V_NOSUBTYPE;
2423
2424 /* NOTE: the epsilon (vals[1]->v_num) argument is ignored */
2425
2426 /* calculate argument * (9/10) */
2427 switch (vals[0]->v_type) {
2428 case V_NUM:
2429 result.v_num = qmul(vals[0]->v_num, &_qninedivten_);
2430 result.v_type = V_NUM;
2431 break;
2432 case V_COM:
2433 result.v_com = c_mulq(vals[0]->v_com, &_qninedivten_);
2434 result.v_type = V_COM;
2435 break;
2436 default:
2437 return error_value(E_G2D1);
2438 }
2439 return result;
2440 }
2441
2442
2443 S_FUNC VALUE
f_sin(int count,VALUE ** vals)2444 f_sin(int count, VALUE **vals)
2445 {
2446 VALUE result;
2447 COMPLEX *c;
2448 NUMBER *eps;
2449
2450 /* initialize VALUE */
2451 result.v_subtype = V_NOSUBTYPE;
2452
2453 eps = conf->epsilon;
2454 if (count == 2) {
2455 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2456 return error_value(E_SIN1);
2457 eps = vals[1]->v_num;
2458 }
2459 switch (vals[0]->v_type) {
2460 case V_NUM:
2461 result.v_num = qsin(vals[0]->v_num, eps);
2462 result.v_type = V_NUM;
2463 break;
2464 case V_COM:
2465 c = c_sin(vals[0]->v_com, eps);
2466 if (c == NULL)
2467 return error_value(E_SIN3);
2468 result.v_com = c;
2469 result.v_type = V_COM;
2470 if (cisreal(c)) {
2471 result.v_num = qlink(c->real);
2472 result.v_type = V_NUM;
2473 comfree(c);
2474 }
2475 break;
2476 default:
2477 return error_value(E_SIN2);
2478 }
2479 return result;
2480 }
2481
2482
2483 S_FUNC VALUE
f_tan(int count,VALUE ** vals)2484 f_tan(int count, VALUE **vals)
2485 {
2486 VALUE result;
2487 VALUE tmp1, tmp2;
2488 NUMBER *err;
2489
2490 /* initialize VALUEs */
2491 result.v_subtype = V_NOSUBTYPE;
2492 tmp1.v_subtype = V_NOSUBTYPE;
2493 tmp2.v_subtype = V_NOSUBTYPE;
2494
2495 err = conf->epsilon;
2496 if (count == 2) {
2497 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2498 return error_value(E_TAN1);
2499 err = vals[1]->v_num;
2500 }
2501 switch (vals[0]->v_type) {
2502 case V_NUM:
2503 result.v_num = qtan(vals[0]->v_num, err);
2504 result.v_type = V_NUM;
2505 break;
2506 case V_COM:
2507 tmp1.v_type = V_COM;
2508 tmp1.v_com = c_sin(vals[0]->v_com, err);
2509 if (tmp1.v_com == NULL) {
2510 return error_value(E_TAN3);
2511 }
2512 tmp2.v_type = V_COM;
2513 tmp2.v_com = c_cos(vals[0]->v_com, err);
2514 if (tmp2.v_com == NULL) {
2515 comfree(tmp1.v_com);
2516 return error_value(E_TAN4);
2517 }
2518 divvalue(&tmp1, &tmp2, &result);
2519 comfree(tmp1.v_com);
2520 comfree(tmp2.v_com);
2521 break;
2522 default:
2523 return error_value(E_TAN2);
2524 }
2525 return result;
2526 }
2527
2528 S_FUNC VALUE
f_sec(int count,VALUE ** vals)2529 f_sec(int count, VALUE **vals)
2530 {
2531 VALUE result;
2532 VALUE tmp;
2533 NUMBER *err;
2534
2535 /* initialize VALUEs */
2536 result.v_subtype = V_NOSUBTYPE;
2537 tmp.v_subtype = V_NOSUBTYPE;
2538
2539 err = conf->epsilon;
2540 if (count == 2) {
2541 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2542 return error_value(E_SEC1);
2543 err = vals[1]->v_num;
2544 }
2545 switch (vals[0]->v_type) {
2546 case V_NUM:
2547 result.v_num = qsec(vals[0]->v_num, err);
2548 result.v_type = V_NUM;
2549 break;
2550 case V_COM:
2551 tmp.v_type = V_COM;
2552 tmp.v_com = c_cos(vals[0]->v_com, err);
2553 if (tmp.v_com == NULL) {
2554 return error_value(E_SEC3);
2555 }
2556 invertvalue(&tmp, &result);
2557 comfree(tmp.v_com);
2558 break;
2559 default:
2560 return error_value(E_SEC2);
2561 }
2562 return result;
2563 }
2564
2565
2566 S_FUNC VALUE
f_cot(int count,VALUE ** vals)2567 f_cot(int count, VALUE **vals)
2568 {
2569 VALUE result;
2570 VALUE tmp1, tmp2;
2571 NUMBER *err;
2572
2573 /* initialize VALUEs */
2574 result.v_subtype = V_NOSUBTYPE;
2575 tmp1.v_subtype = V_NOSUBTYPE;
2576 tmp2.v_subtype = V_NOSUBTYPE;
2577
2578 err = conf->epsilon;
2579 if (count == 2) {
2580 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2581 return error_value(E_COT1);
2582 err = vals[1]->v_num;
2583 }
2584 switch (vals[0]->v_type) {
2585 case V_NUM:
2586 if (qiszero(vals[0]->v_num))
2587 return error_value(E_1OVER0);
2588 result.v_num = qcot(vals[0]->v_num, err);
2589 result.v_type = V_NUM;
2590 break;
2591 case V_COM:
2592 tmp1.v_type = V_COM;
2593 tmp1.v_com = c_cos(vals[0]->v_com, err);
2594 if (tmp1.v_com == NULL) {
2595 return error_value(E_COT3);
2596 }
2597 tmp2.v_type = V_COM;
2598 tmp2.v_com = c_sin(vals[0]->v_com, err);
2599 if (tmp2.v_com == NULL) {
2600 comfree(tmp1.v_com);
2601 return error_value(E_COT4);
2602 }
2603 divvalue(&tmp1, &tmp2, &result);
2604 comfree(tmp1.v_com);
2605 comfree(tmp2.v_com);
2606 break;
2607 default:
2608 return error_value(E_COT2);
2609 }
2610 return result;
2611 }
2612
2613
2614 S_FUNC VALUE
f_csc(int count,VALUE ** vals)2615 f_csc(int count, VALUE **vals)
2616 {
2617 VALUE result;
2618 VALUE tmp;
2619 NUMBER *err;
2620
2621 /* initialize VALUEs */
2622 result.v_subtype = V_NOSUBTYPE;
2623 tmp.v_subtype = V_NOSUBTYPE;
2624
2625 err = conf->epsilon;
2626 if (count == 2) {
2627 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2628 return error_value(E_CSC1);
2629 err = vals[1]->v_num;
2630 }
2631 switch (vals[0]->v_type) {
2632 case V_NUM:
2633 if (qiszero(vals[0]->v_num))
2634 return error_value(E_1OVER0);
2635 result.v_num = qcsc(vals[0]->v_num, err);
2636 result.v_type = V_NUM;
2637 break;
2638 case V_COM:
2639 tmp.v_type = V_COM;
2640 tmp.v_com = c_sin(vals[0]->v_com, err);
2641 if (tmp.v_com == NULL) {
2642 return error_value(E_CSC3);
2643 }
2644 invertvalue(&tmp, &result);
2645 comfree(tmp.v_com);
2646 break;
2647 default:
2648 return error_value(E_CSC2);
2649 }
2650 return result;
2651 }
2652
2653 S_FUNC VALUE
f_sinh(int count,VALUE ** vals)2654 f_sinh(int count, VALUE **vals)
2655 {
2656 VALUE result;
2657 NUMBER *eps;
2658 NUMBER *q;
2659 COMPLEX *c;
2660
2661 /* initialize VALUE */
2662 result.v_subtype = V_NOSUBTYPE;
2663
2664 eps = conf->epsilon;
2665 if (count == 2) {
2666 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2667 return error_value(E_SINH1);
2668 eps = vals[1]->v_num;
2669 }
2670 switch (vals[0]->v_type) {
2671 case V_NUM:
2672 q = qsinh(vals[0]->v_num, eps);
2673 if (q == NULL)
2674 return error_value(E_SINH3);
2675 result.v_num = q;
2676 result.v_type = V_NUM;
2677 break;
2678 case V_COM:
2679 c = c_sinh(vals[0]->v_com, eps);
2680 if (c == NULL)
2681 return error_value(E_SINH3);
2682 result.v_com = c;
2683 result.v_type = V_COM;
2684 if (cisreal(c)) {
2685 result.v_num = qlink(c->real);
2686 comfree(c);
2687 result.v_type = V_NUM;
2688 }
2689 break;
2690 default:
2691 return error_value(E_SINH2);
2692 }
2693 return result;
2694 }
2695
2696 S_FUNC VALUE
f_cosh(int count,VALUE ** vals)2697 f_cosh(int count, VALUE **vals)
2698 {
2699 VALUE result;
2700 NUMBER *eps;
2701 NUMBER *q;
2702 COMPLEX *c;
2703
2704 /* initialize VALUE */
2705 result.v_subtype = V_NOSUBTYPE;
2706
2707 eps = conf->epsilon;
2708 if (count == 2) {
2709 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2710 return error_value(E_COSH1);
2711 eps = vals[1]->v_num;
2712 }
2713 switch (vals[0]->v_type) {
2714 case V_NUM:
2715 q = qcosh(vals[0]->v_num, eps);
2716 if (q == NULL)
2717 return error_value(E_COSH3);
2718 result.v_num = q;
2719 result.v_type = V_NUM;
2720 break;
2721 case V_COM:
2722 c = c_cosh(vals[0]->v_com, eps);
2723 if (c == NULL)
2724 return error_value(E_COSH3);
2725 result.v_com = c;
2726 result.v_type = V_COM;
2727 if (cisreal(c)) {
2728 result.v_num = qlink(c->real);
2729 comfree(c);
2730 result.v_type = V_NUM;
2731 }
2732 break;
2733 default:
2734 return error_value(E_COSH2);
2735 }
2736 return result;
2737 }
2738
2739
2740 S_FUNC VALUE
f_tanh(int count,VALUE ** vals)2741 f_tanh(int count, VALUE **vals)
2742 {
2743 VALUE result;
2744 VALUE tmp1, tmp2;
2745 NUMBER *err;
2746
2747 /* initialize VALUEs */
2748 result.v_subtype = V_NOSUBTYPE;
2749 tmp1.v_subtype = V_NOSUBTYPE;
2750 tmp2.v_subtype = V_NOSUBTYPE;
2751
2752 err = conf->epsilon;
2753 if (count == 2) {
2754 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2755 return error_value(E_TANH1);
2756 err = vals[1]->v_num;
2757 }
2758 switch (vals[0]->v_type) {
2759 case V_NUM:
2760 result.v_num = qtanh(vals[0]->v_num, err);
2761 result.v_type = V_NUM;
2762 break;
2763 case V_COM:
2764 tmp1.v_type = V_COM;
2765 tmp1.v_com = c_sinh(vals[0]->v_com, err);
2766 if (tmp1.v_com == NULL) {
2767 return error_value(E_TANH3);
2768 }
2769 tmp2.v_type = V_COM;
2770 tmp2.v_com = c_cosh(vals[0]->v_com, err);
2771 if (tmp2.v_com == NULL) {
2772 comfree(tmp1.v_com);
2773 return error_value(E_TANH4);
2774 }
2775 divvalue(&tmp1, &tmp2, &result);
2776 comfree(tmp1.v_com);
2777 comfree(tmp2.v_com);
2778 break;
2779 default:
2780 return error_value(E_TANH2);
2781 }
2782 return result;
2783 }
2784
2785
2786 S_FUNC VALUE
f_coth(int count,VALUE ** vals)2787 f_coth(int count, VALUE **vals)
2788 {
2789 VALUE result;
2790 VALUE tmp1, tmp2;
2791 NUMBER *err;
2792
2793 /* initialize VALUEs */
2794 result.v_subtype = V_NOSUBTYPE;
2795 tmp1.v_subtype = V_NOSUBTYPE;
2796 tmp2.v_subtype = V_NOSUBTYPE;
2797
2798 err = conf->epsilon;
2799 if (count == 2) {
2800 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2801 return error_value(E_COTH1);
2802 err = vals[1]->v_num;
2803 }
2804 switch (vals[0]->v_type) {
2805 case V_NUM:
2806 if (qiszero(vals[0]->v_num))
2807 return error_value(E_1OVER0);
2808 result.v_num = qcoth(vals[0]->v_num, err);
2809 result.v_type = V_NUM;
2810 break;
2811 case V_COM:
2812 tmp1.v_type = V_COM;
2813 tmp1.v_com = c_cosh(vals[0]->v_com, err);
2814 if (tmp1.v_com == NULL) {
2815 return error_value(E_COTH3);
2816 }
2817 tmp2.v_type = V_COM;
2818 tmp2.v_com = c_sinh(vals[0]->v_com, err);
2819 if (tmp2.v_com == NULL) {
2820 comfree(tmp1.v_com);
2821 return error_value(E_COTH4);
2822 }
2823 divvalue(&tmp1, &tmp2, &result);
2824 comfree(tmp1.v_com);
2825 comfree(tmp2.v_com);
2826 break;
2827 default:
2828 return error_value(E_COTH2);
2829 }
2830 return result;
2831 }
2832
2833
2834 S_FUNC VALUE
f_sech(int count,VALUE ** vals)2835 f_sech(int count, VALUE **vals)
2836 {
2837 VALUE result;
2838 VALUE tmp;
2839 NUMBER *err;
2840
2841 /* initialize VALUEs */
2842 result.v_subtype = V_NOSUBTYPE;
2843 tmp.v_subtype = V_NOSUBTYPE;
2844
2845 err = conf->epsilon;
2846 if (count == 2) {
2847 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2848 return error_value(E_SECH1);
2849 err = vals[1]->v_num;
2850 }
2851 switch (vals[0]->v_type) {
2852 case V_NUM:
2853 result.v_num = qsech(vals[0]->v_num, err);
2854 result.v_type = V_NUM;
2855 break;
2856 case V_COM:
2857 tmp.v_type = V_COM;
2858 tmp.v_com = c_cosh(vals[0]->v_com, err);
2859 if (tmp.v_com == NULL) {
2860 return error_value(E_SECH3);
2861 }
2862 invertvalue(&tmp, &result);
2863 comfree(tmp.v_com);
2864 break;
2865 default:
2866 return error_value(E_SECH2);
2867 }
2868 return result;
2869 }
2870
2871
2872 S_FUNC VALUE
f_csch(int count,VALUE ** vals)2873 f_csch(int count, VALUE **vals)
2874 {
2875 VALUE result;
2876 VALUE tmp;
2877 NUMBER *err;
2878
2879 /* initialize VALUEs */
2880 result.v_subtype = V_NOSUBTYPE;
2881 tmp.v_subtype = V_NOSUBTYPE;
2882
2883 err = conf->epsilon;
2884 if (count == 2) {
2885 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2886 return error_value(E_CSCH1);
2887 err = vals[1]->v_num;
2888 }
2889 switch (vals[0]->v_type) {
2890 case V_NUM:
2891 if (qiszero(vals[0]->v_num))
2892 return error_value(E_1OVER0);
2893 result.v_num = qcsch(vals[0]->v_num, err);
2894 result.v_type = V_NUM;
2895 break;
2896 case V_COM:
2897 tmp.v_type = V_COM;
2898 tmp.v_com = c_sinh(vals[0]->v_com, err);
2899 if (tmp.v_com == NULL) {
2900 return error_value(E_CSCH3);
2901 }
2902 invertvalue(&tmp, &result);
2903 comfree(tmp.v_com);
2904 break;
2905 default:
2906 return error_value(E_CSCH2);
2907 }
2908 return result;
2909 }
2910
2911
2912 S_FUNC VALUE
f_atan(int count,VALUE ** vals)2913 f_atan(int count, VALUE **vals)
2914 {
2915 VALUE result;
2916 COMPLEX *tmp;
2917 NUMBER *err;
2918
2919 /* initialize VALUE */
2920 result.v_subtype = V_NOSUBTYPE;
2921
2922 err = conf->epsilon;
2923 if (count == 2) {
2924 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2925 return error_value(E_ATAN1);
2926 err = vals[1]->v_num;
2927 }
2928 switch (vals[0]->v_type) {
2929 case V_NUM:
2930 result.v_num = qatan(vals[0]->v_num, err);
2931 result.v_type = V_NUM;
2932 break;
2933 case V_COM:
2934 tmp = c_atan(vals[0]->v_com, err);
2935 if (tmp == NULL)
2936 return error_value(E_ATAN3);
2937 result.v_type = V_COM;
2938 result.v_com = tmp;
2939 if (cisreal(tmp)) {
2940 result.v_num = qlink(tmp->real);
2941 result.v_type = V_NUM;
2942 comfree(tmp);
2943 }
2944 break;
2945 default:
2946 return error_value(E_ATAN2);
2947 }
2948 return result;
2949 }
2950
2951
2952 S_FUNC VALUE
f_acot(int count,VALUE ** vals)2953 f_acot(int count, VALUE **vals)
2954 {
2955 VALUE result;
2956 COMPLEX *tmp;
2957 NUMBER *err;
2958
2959 /* initialize VALUE */
2960 result.v_subtype = V_NOSUBTYPE;
2961
2962 err = conf->epsilon;
2963 if (count == 2) {
2964 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
2965 return error_value(E_ACOT1);
2966 err = vals[1]->v_num;
2967 }
2968 switch (vals[0]->v_type) {
2969 case V_NUM:
2970 result.v_num = qacot(vals[0]->v_num, err);
2971 result.v_type = V_NUM;
2972 break;
2973 case V_COM:
2974 tmp = c_acot(vals[0]->v_com, err);
2975 if (tmp == NULL)
2976 return error_value(E_ACOT3);
2977 result.v_type = V_COM;
2978 result.v_com = tmp;
2979 if (cisreal(tmp)) {
2980 result.v_num = qlink(tmp->real);
2981 result.v_type = V_NUM;
2982 comfree(tmp);
2983 }
2984 break;
2985 default:
2986 return error_value(E_ACOT2);
2987 }
2988 return result;
2989 }
2990
2991 S_FUNC VALUE
f_asin(int count,VALUE ** vals)2992 f_asin(int count, VALUE **vals)
2993 {
2994 VALUE result;
2995 COMPLEX *tmp;
2996 NUMBER *err;
2997 NUMBER *q;
2998
2999 /* initialize VALUE */
3000 result.v_subtype = V_NOSUBTYPE;
3001
3002 err = conf->epsilon;
3003 if (count == 2) {
3004 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3005 return error_value(E_ASIN1);
3006 err = vals[1]->v_num;
3007 }
3008 switch (vals[0]->v_type) {
3009 case V_NUM:
3010 result.v_num = qasin(vals[0]->v_num, err);
3011 result.v_type = V_NUM;
3012 if (result.v_num == NULL) {
3013 tmp = comalloc();
3014 qfree(tmp->real);
3015 tmp->real = qlink(vals[0]->v_num);
3016 result.v_type = V_COM;
3017 result.v_com = c_asin(tmp, err);
3018 comfree(tmp);
3019 }
3020 break;
3021 case V_COM:
3022 result.v_com = c_asin(vals[0]->v_com, err);
3023 result.v_type = V_COM;
3024 break;
3025 default:
3026 return error_value(E_ASIN2);
3027 }
3028 if (result.v_com == NULL) {
3029 return error_value(E_ASIN3);
3030 }
3031 if (result.v_type == V_COM && cisreal(result.v_com)) {
3032 q = qlink(result.v_com->real);
3033 comfree(result.v_com);
3034 result.v_type = V_NUM;
3035 result.v_num = q;
3036 }
3037 return result;
3038 }
3039
3040 S_FUNC VALUE
f_acos(int count,VALUE ** vals)3041 f_acos(int count, VALUE **vals)
3042 {
3043 VALUE result;
3044 COMPLEX *tmp;
3045 NUMBER *err;
3046 NUMBER *q;
3047
3048 /* initialize VALUE */
3049 result.v_subtype = V_NOSUBTYPE;
3050
3051 err = conf->epsilon;
3052 if (count == 2) {
3053 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3054 return error_value(E_ACOS1);
3055 err = vals[1]->v_num;
3056 }
3057 switch (vals[0]->v_type) {
3058 case V_NUM:
3059 result.v_num = qacos(vals[0]->v_num, err);
3060 result.v_type = V_NUM;
3061 if (result.v_num == NULL) {
3062 tmp = comalloc();
3063 qfree(tmp->real);
3064 tmp->real = qlink(vals[0]->v_num);
3065 result.v_type = V_COM;
3066 result.v_com = c_acos(tmp, err);
3067 comfree(tmp);
3068 }
3069 break;
3070 case V_COM:
3071 result.v_com = c_acos(vals[0]->v_com, err);
3072 result.v_type = V_COM;
3073 break;
3074 default:
3075 return error_value(E_ACOS2);
3076 }
3077 if (result.v_com == NULL) {
3078 return error_value(E_ACOS3);
3079 }
3080 if (result.v_type == V_COM && cisreal(result.v_com)) {
3081 q = qlink(result.v_com->real);
3082 comfree(result.v_com);
3083 result.v_type = V_NUM;
3084 result.v_num = q;
3085 }
3086 return result;
3087 }
3088
3089
3090 S_FUNC VALUE
f_asec(int count,VALUE ** vals)3091 f_asec(int count, VALUE **vals)
3092 {
3093 VALUE result;
3094 COMPLEX *tmp;
3095 NUMBER *err;
3096 NUMBER *q;
3097
3098 /* initialize VALUE */
3099 result.v_subtype = V_NOSUBTYPE;
3100
3101 err = conf->epsilon;
3102 if (count == 2) {
3103 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3104 return error_value(E_ASEC1);
3105 err = vals[1]->v_num;
3106 }
3107 switch (vals[0]->v_type) {
3108 case V_NUM:
3109 if (qiszero(vals[0]->v_num))
3110 return error_value(E_ASEC3);
3111 result.v_num = qasec(vals[0]->v_num, err);
3112 result.v_type = V_NUM;
3113 if (result.v_num == NULL) {
3114 tmp = comalloc();
3115 qfree(tmp->real);
3116 tmp->real = qlink(vals[0]->v_num);
3117 result.v_com = c_asec(tmp, err);
3118 result.v_type = V_COM;
3119 comfree(tmp);
3120 }
3121 break;
3122 case V_COM:
3123 result.v_com = c_asec(vals[0]->v_com, err);
3124 result.v_type = V_COM;
3125 break;
3126 default:
3127 return error_value(E_ASEC2);
3128 }
3129 if (result.v_com == NULL) {
3130 return error_value(E_ASEC3);
3131 }
3132 if (result.v_type == V_COM) {
3133 if (cisreal(result.v_com)) {
3134 q = qlink(result.v_com->real);
3135 comfree(result.v_com);
3136 result.v_type = V_NUM;
3137 result.v_num = q;
3138 }
3139 }
3140 return result;
3141 }
3142
3143
3144 S_FUNC VALUE
f_acsc(int count,VALUE ** vals)3145 f_acsc(int count, VALUE **vals)
3146 {
3147 VALUE result;
3148 COMPLEX *tmp;
3149 NUMBER *err;
3150 NUMBER *q;
3151
3152 /* initialize VALUE */
3153 result.v_subtype = V_NOSUBTYPE;
3154
3155 err = conf->epsilon;
3156 if (count == 2) {
3157 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3158 return error_value(E_ACSC1);
3159 err = vals[1]->v_num;
3160 }
3161 switch (vals[0]->v_type) {
3162 case V_NUM:
3163 if (qiszero(vals[0]->v_num))
3164 return error_value(E_ACSC3);
3165 result.v_num = qacsc(vals[0]->v_num, err);
3166 result.v_type = V_NUM;
3167 if (result.v_num == NULL) {
3168 tmp = comalloc();
3169 qfree(tmp->real);
3170 tmp->real = qlink(vals[0]->v_num);
3171 result.v_com = c_acsc(tmp, err);
3172 result.v_type = V_COM;
3173 comfree(tmp);
3174 }
3175 break;
3176 case V_COM:
3177 result.v_com = c_acsc(vals[0]->v_com, err);
3178 result.v_type = V_COM;
3179 break;
3180 default:
3181 return error_value(E_ACSC2);
3182 }
3183 if (result.v_com == NULL) {
3184 return error_value(E_ACSC3);
3185 }
3186 if (result.v_type == V_COM) {
3187 if (cisreal(result.v_com)) {
3188 q = qlink(result.v_com->real);
3189 comfree(result.v_com);
3190 result.v_type = V_NUM;
3191 result.v_num = q;
3192 }
3193 }
3194 return result;
3195 }
3196
3197
3198 S_FUNC VALUE
f_asinh(int count,VALUE ** vals)3199 f_asinh(int count, VALUE **vals)
3200 {
3201 VALUE result;
3202 COMPLEX *tmp;
3203 NUMBER *err;
3204
3205 /* initialize VALUE */
3206 result.v_subtype = V_NOSUBTYPE;
3207
3208 err = conf->epsilon;
3209 if (count == 2) {
3210 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3211 return error_value(E_ASINH1);
3212 err = vals[1]->v_num;
3213 }
3214 switch (vals[0]->v_type) {
3215 case V_NUM:
3216 result.v_num = qasinh(vals[0]->v_num, err);
3217 result.v_type = V_NUM;
3218 break;
3219 case V_COM:
3220 tmp = c_asinh(vals[0]->v_com, err);
3221 if (tmp == NULL) {
3222 return error_value(E_ASINH3);
3223 }
3224 result.v_type = V_COM;
3225 result.v_com = tmp;
3226 if (cisreal(tmp)) {
3227 result.v_num = qlink(tmp->real);
3228 result.v_type = V_NUM;
3229 comfree(tmp);
3230 }
3231 break;
3232 default:
3233 return error_value(E_ASINH2);
3234 }
3235 return result;
3236 }
3237
3238
3239 S_FUNC VALUE
f_acosh(int count,VALUE ** vals)3240 f_acosh(int count, VALUE **vals)
3241 {
3242 VALUE result;
3243 COMPLEX *tmp;
3244 NUMBER *err;
3245 NUMBER *q;
3246
3247 /* initialize VALUE */
3248 result.v_subtype = V_NOSUBTYPE;
3249
3250 err = conf->epsilon;
3251 if (count == 2) {
3252 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3253 return error_value(E_ACOSH1);
3254 err = vals[1]->v_num;
3255 }
3256 switch (vals[0]->v_type) {
3257 case V_NUM:
3258 result.v_num = qacosh(vals[0]->v_num, err);
3259 result.v_type = V_NUM;
3260 if (result.v_num == NULL) {
3261 tmp = comalloc();
3262 qfree(tmp->real);
3263 tmp->real = qlink(vals[0]->v_num);
3264 result.v_com = c_acosh(tmp, err);
3265 result.v_type = V_COM;
3266 comfree(tmp);
3267 }
3268 break;
3269 case V_COM:
3270 result.v_com = c_acosh(vals[0]->v_com, err);
3271 result.v_type = V_COM;
3272 break;
3273 default:
3274 return error_value(E_ACOSH2);
3275 }
3276 if (result.v_com == NULL) {
3277 return error_value(E_ACOSH3);
3278 }
3279 if (result.v_type == V_COM && cisreal(result.v_com)) {
3280 q = qlink(result.v_com->real);
3281 comfree(result.v_com);
3282 result.v_type = V_NUM;
3283 result.v_num = q;
3284 }
3285 return result;
3286 }
3287
3288
3289 S_FUNC VALUE
f_atanh(int count,VALUE ** vals)3290 f_atanh(int count, VALUE **vals)
3291 {
3292 VALUE result;
3293 COMPLEX *tmp;
3294 NUMBER *err;
3295 NUMBER *q;
3296
3297 /* initialize VALUE */
3298 result.v_subtype = V_NOSUBTYPE;
3299
3300 err = conf->epsilon;
3301 if (count == 2) {
3302 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3303 return error_value(E_ATANH1);
3304 err = vals[1]->v_num;
3305 }
3306 switch (vals[0]->v_type) {
3307 case V_NUM:
3308 result.v_num = qatanh(vals[0]->v_num, err);
3309 result.v_type = V_NUM;
3310 if (result.v_num == NULL) {
3311 tmp = comalloc();
3312 qfree(tmp->real);
3313 tmp->real = qlink(vals[0]->v_num);
3314 result.v_com = c_atanh(tmp, err);
3315 result.v_type = V_COM;
3316 comfree(tmp);
3317 }
3318 break;
3319 case V_COM:
3320 result.v_com = c_atanh(vals[0]->v_com, err);
3321 result.v_type = V_COM;
3322 break;
3323 default:
3324 return error_value(E_ATANH2);
3325 }
3326 if (result.v_com == NULL) {
3327 return error_value(E_ATANH3);
3328 }
3329 if (result.v_type == V_COM) {
3330 if (cisreal(result.v_com)) {
3331 q = qlink(result.v_com->real);
3332 comfree(result.v_com);
3333 result.v_type = V_NUM;
3334 result.v_num = q;
3335 }
3336 }
3337 return result;
3338 }
3339
3340
3341 S_FUNC VALUE
f_acoth(int count,VALUE ** vals)3342 f_acoth(int count, VALUE **vals)
3343 {
3344 VALUE result;
3345 COMPLEX *tmp;
3346 NUMBER *err;
3347 NUMBER *q;
3348
3349 /* initialize VALUE */
3350 result.v_subtype = V_NOSUBTYPE;
3351
3352 err = conf->epsilon;
3353 if (count == 2) {
3354 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3355 return error_value(E_ACOTH1);
3356 err = vals[1]->v_num;
3357 }
3358 switch (vals[0]->v_type) {
3359 case V_NUM:
3360 result.v_num = qacoth(vals[0]->v_num, err);
3361 result.v_type = V_NUM;
3362 if (result.v_num == NULL) {
3363 tmp = comalloc();
3364 qfree(tmp->real);
3365 tmp->real = qlink(vals[0]->v_num);
3366 result.v_com = c_acoth(tmp, err);
3367 result.v_type = V_COM;
3368 comfree(tmp);
3369 }
3370 break;
3371 case V_COM:
3372 result.v_com = c_acoth(vals[0]->v_com, err);
3373 result.v_type = V_COM;
3374 break;
3375 default:
3376 return error_value(E_ACOTH2);
3377 }
3378 if (result.v_com == NULL) {
3379 return error_value(E_ACOTH3);
3380 }
3381 if (result.v_type == V_COM) {
3382 if (cisreal(result.v_com)) {
3383 q = qlink(result.v_com->real);
3384 comfree(result.v_com);
3385 result.v_type = V_NUM;
3386 result.v_num = q;
3387 }
3388 }
3389 return result;
3390 }
3391
3392
3393 S_FUNC VALUE
f_asech(int count,VALUE ** vals)3394 f_asech(int count, VALUE **vals)
3395 {
3396 VALUE result;
3397 COMPLEX *tmp;
3398 NUMBER *err;
3399 NUMBER *q;
3400
3401 /* initialize VALUE */
3402 result.v_subtype = V_NOSUBTYPE;
3403
3404 err = conf->epsilon;
3405 if (count == 2) {
3406 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3407 return error_value(E_SECH1);
3408 err = vals[1]->v_num;
3409 }
3410 switch (vals[0]->v_type) {
3411 case V_NUM:
3412 if (qiszero(vals[0]->v_num))
3413 return error_value(E_ASECH3);
3414 result.v_num = qasech(vals[0]->v_num, err);
3415 result.v_type = V_NUM;
3416 if (result.v_num == NULL) {
3417 tmp = comalloc();
3418 qfree(tmp->real);
3419 tmp->real = qlink(vals[0]->v_num);
3420 result.v_com = c_asech(tmp, err);
3421 result.v_type = V_COM;
3422 comfree(tmp);
3423 }
3424 break;
3425 case V_COM:
3426 result.v_com = c_asech(vals[0]->v_com, err);
3427 result.v_type = V_COM;
3428 break;
3429 default:
3430 return error_value(E_ASECH2);
3431 }
3432 if (result.v_com == NULL) {
3433 return error_value(E_ASECH3);
3434 }
3435 if (result.v_type == V_COM) {
3436 if (cisreal(result.v_com)) {
3437 q = qlink(result.v_com->real);
3438 comfree(result.v_com);
3439 result.v_type = V_NUM;
3440 result.v_num = q;
3441 }
3442 }
3443 return result;
3444 }
3445
3446
3447 S_FUNC VALUE
f_acsch(int count,VALUE ** vals)3448 f_acsch(int count, VALUE **vals)
3449 {
3450 VALUE result;
3451 COMPLEX *tmp;
3452 NUMBER *err;
3453 NUMBER *q;
3454
3455 /* initialize VALUE */
3456 result.v_subtype = V_NOSUBTYPE;
3457
3458 err = conf->epsilon;
3459 if (count == 2) {
3460 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3461 return error_value(E_ACSCH1);
3462 err = vals[1]->v_num;
3463 }
3464 switch (vals[0]->v_type) {
3465 case V_NUM:
3466 if (qiszero(vals[0]->v_num))
3467 return error_value(E_ACSCH3);
3468 result.v_num = qacsch(vals[0]->v_num, err);
3469 result.v_type = V_NUM;
3470 if (result.v_num == NULL) {
3471 tmp = comalloc();
3472 qfree(tmp->real);
3473 tmp->real = qlink(vals[0]->v_num);
3474 result.v_com = c_acsch(tmp, err);
3475 result.v_type = V_COM;
3476 comfree(tmp);
3477 }
3478 break;
3479 case V_COM:
3480 result.v_com = c_acsch(vals[0]->v_com, err);
3481 result.v_type = V_COM;
3482 break;
3483 default:
3484 return error_value(E_ACSCH2);
3485 }
3486 if (result.v_com == NULL) {
3487 return error_value(E_ACSCH3);
3488 }
3489 if (result.v_type == V_COM) {
3490 if (cisreal(result.v_com)) {
3491 q = qlink(result.v_com->real);
3492 comfree(result.v_com);
3493 result.v_type = V_NUM;
3494 result.v_num = q;
3495 }
3496 }
3497 return result;
3498 }
3499
3500
3501 S_FUNC VALUE
f_gd(int count,VALUE ** vals)3502 f_gd(int count, VALUE **vals)
3503 {
3504 VALUE result;
3505 NUMBER *eps;
3506 NUMBER *q;
3507 COMPLEX *tmp;
3508
3509 /* initialize VALUE */
3510 result.v_subtype = V_NOSUBTYPE;
3511
3512 eps = conf->epsilon;
3513 if (count == 2) {
3514 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3515 return error_value(E_GD1);
3516 eps = vals[1]->v_num;
3517 }
3518 result.v_type = V_COM;
3519 switch (vals[0]->v_type) {
3520 case V_NUM:
3521 if (qiszero(vals[0]->v_num)) {
3522 result.v_type = V_NUM;
3523 result.v_num = qlink(&_qzero_);
3524 return result;
3525 }
3526 tmp = comalloc();
3527 qfree(tmp->real);
3528 tmp->real = qlink(vals[0]->v_num);
3529 result.v_com = c_gd(tmp, eps);
3530 comfree(tmp);
3531 break;
3532 case V_COM:
3533 result.v_com = c_gd(vals[0]->v_com, eps);
3534 break;
3535 default:
3536 return error_value(E_GD2);
3537 }
3538 if (result.v_com == NULL)
3539 return error_value(E_GD3);
3540 if (cisreal(result.v_com)) {
3541 q = qlink(result.v_com->real);
3542 comfree(result.v_com);
3543 result.v_num = q;
3544 result.v_type = V_NUM;
3545 }
3546 return result;
3547 }
3548
3549
3550 S_FUNC VALUE
f_agd(int count,VALUE ** vals)3551 f_agd(int count, VALUE **vals)
3552 {
3553 VALUE result;
3554 NUMBER *eps;
3555 NUMBER *q;
3556 COMPLEX *tmp;
3557
3558 /* initialize VALUE */
3559 result.v_subtype = V_NOSUBTYPE;
3560
3561 eps = conf->epsilon;
3562 if (count == 2) {
3563 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3564 return error_value(E_AGD1);
3565 eps = vals[1]->v_num;
3566 }
3567 result.v_type = V_COM;
3568 switch (vals[0]->v_type) {
3569 case V_NUM:
3570 if (qiszero(vals[0]->v_num)) {
3571 result.v_type = V_NUM;
3572 result.v_num = qlink(&_qzero_);
3573 return result;
3574 }
3575 tmp = comalloc();
3576 qfree(tmp->real);
3577 tmp->real = qlink(vals[0]->v_num);
3578 result.v_com = c_agd(tmp, eps);
3579 comfree(tmp);
3580 break;
3581 case V_COM:
3582 result.v_com = c_agd(vals[0]->v_com, eps);
3583 break;
3584 default:
3585 return error_value(E_AGD2);
3586 }
3587 if (result.v_com == NULL)
3588 return error_value(E_AGD3);
3589 if (cisreal(result.v_com)) {
3590 q = qlink(result.v_com->real);
3591 comfree(result.v_com);
3592 result.v_num = q;
3593 result.v_type = V_NUM;
3594 }
3595 return result;
3596 }
3597
3598
3599 S_FUNC VALUE
f_comb(VALUE * v1,VALUE * v2)3600 f_comb(VALUE *v1, VALUE *v2)
3601 {
3602 long n;
3603 VALUE result;
3604 VALUE tmp1, tmp2, div;
3605
3606 if (v2->v_type != V_NUM || qisfrac(v2->v_num))
3607 return error_value(E_COMB1);
3608 result.v_subtype = V_NOSUBTYPE;
3609 result.v_type = V_NUM;
3610 if (qisneg(v2->v_num)) {
3611 result.v_num = qlink(&_qzero_);
3612 return result;
3613 }
3614 if (qiszero(v2->v_num)) {
3615 result.v_num = qlink(&_qone_);
3616 return result;
3617 }
3618 if (qisone(v2->v_num)) {
3619 copyvalue(v1, &result);
3620 return result;
3621 }
3622 if (v1->v_type == V_NUM) {
3623 result.v_num = qcomb(v1->v_num, v2->v_num);
3624 if (result.v_num == NULL)
3625 return error_value(E_COMB2);
3626 return result;
3627 }
3628 if (zge24b(v2->v_num->num))
3629 return error_value(E_COMB2);
3630 n = qtoi(v2->v_num);
3631 copyvalue(v1, &result);
3632 decvalue(v1, &tmp1);
3633 div.v_type = V_NUM;
3634 div.v_subtype = V_NOSUBTYPE;
3635 div.v_num = qlink(&_qtwo_);
3636 n--;
3637 for (;;) {
3638 mulvalue(&result, &tmp1, &tmp2);
3639 freevalue(&result);
3640 divvalue(&tmp2, &div, &result);
3641 freevalue(&tmp2);
3642 if (--n == 0 || !testvalue(&result) || result.v_type < 0) {
3643 freevalue(&tmp1);
3644 freevalue(&div);
3645 return result;
3646 }
3647 decvalue(&tmp1, &tmp2);
3648 freevalue(&tmp1);
3649 tmp1 = tmp2;
3650 incvalue(&div, &tmp2);
3651 freevalue(&div);
3652 div = tmp2;
3653 }
3654 }
3655
3656
3657 S_FUNC VALUE
f_bern(VALUE * vp)3658 f_bern(VALUE *vp)
3659 {
3660 VALUE res;
3661
3662 if (vp->v_type != V_NUM || qisfrac(vp->v_num))
3663 return error_value(E_BERN);
3664
3665 res.v_subtype = V_NOSUBTYPE;
3666 res.v_type = V_NUM;
3667 res.v_num = qbern(vp->v_num->num);
3668 if (res.v_num == NULL)
3669 return error_value(E_BERN);
3670 return res;
3671 }
3672
3673
3674 S_FUNC VALUE
f_freebern(void)3675 f_freebern(void)
3676 {
3677 VALUE res;
3678
3679 qfreebern();
3680 res.v_type = V_NULL;
3681 res.v_subtype = V_NOSUBTYPE;
3682 return res;
3683 }
3684
3685
3686 S_FUNC VALUE
f_euler(VALUE * vp)3687 f_euler(VALUE *vp)
3688 {
3689 VALUE res;
3690
3691 if (vp->v_type!=V_NUM || qisfrac(vp->v_num))
3692 return error_value(E_EULER);
3693 res.v_subtype = V_NOSUBTYPE;
3694 res.v_type = V_NUM;
3695 res.v_num = qeuler(vp->v_num->num);
3696 if (res.v_num == NULL)
3697 return error_value(E_EULER);
3698 return res;
3699 }
3700
3701
3702 S_FUNC VALUE
f_freeeuler(void)3703 f_freeeuler(void)
3704 {
3705 VALUE res;
3706
3707 qfreeeuler();
3708 res.v_type = V_NULL;
3709 res.v_subtype = V_NOSUBTYPE;
3710 return res;
3711 }
3712
3713
3714 S_FUNC VALUE
f_catalan(VALUE * vp)3715 f_catalan(VALUE *vp)
3716 {
3717 VALUE res;
3718
3719 if (vp->v_type!=V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num))
3720 return error_value(E_CTLN);
3721 res.v_type = V_NUM;
3722 res.v_subtype = V_NOSUBTYPE;
3723 res.v_num = qcatalan(vp->v_num);
3724 if (res.v_num == NULL)
3725 return error_value(E_CTLN);
3726 return res;
3727 }
3728
3729 S_FUNC VALUE
f_arg(int count,VALUE ** vals)3730 f_arg(int count, VALUE **vals)
3731 {
3732 VALUE result;
3733 COMPLEX *c;
3734 NUMBER *err;
3735
3736 /* initialize VALUE */
3737 result.v_subtype = V_NOSUBTYPE;
3738
3739 err = conf->epsilon;
3740 if (count == 2) {
3741 if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num))
3742 return error_value(E_ARG1);
3743 err = vals[1]->v_num;
3744 }
3745 result.v_type = V_NUM;
3746 switch (vals[0]->v_type) {
3747 case V_NUM:
3748 if (qisneg(vals[0]->v_num))
3749 result.v_num = qpi(err);
3750 else
3751 result.v_num = qlink(&_qzero_);
3752 break;
3753 case V_COM:
3754 c = vals[0]->v_com;
3755 if (ciszero(c))
3756 result.v_num = qlink(&_qzero_);
3757 else
3758 result.v_num = qatan2(c->imag, c->real, err);
3759 break;
3760 default:
3761 return error_value(E_ARG2);
3762 }
3763 return result;
3764 }
3765
3766
3767 S_FUNC NUMBER *
f_legtoleg(NUMBER * val1,NUMBER * val2)3768 f_legtoleg(NUMBER *val1, NUMBER *val2)
3769 {
3770 return qlegtoleg(val1, val2, FALSE);
3771 }
3772
3773
3774 S_FUNC NUMBER *
f_trunc(int count,NUMBER ** vals)3775 f_trunc(int count, NUMBER **vals)
3776 {
3777 NUMBER *val;
3778
3779 val = qlink(&_qzero_);
3780 if (count == 2)
3781 val = vals[1];
3782 return qtrunc(*vals, val);
3783 }
3784
3785
3786 S_FUNC VALUE
f_bround(int count,VALUE ** vals)3787 f_bround(int count, VALUE **vals)
3788 {
3789 VALUE tmp1, tmp2, res;
3790
3791 /* initialize VALUEs */
3792 res.v_subtype = V_NOSUBTYPE;
3793 tmp1.v_subtype = V_NOSUBTYPE;
3794 tmp2.v_subtype = V_NOSUBTYPE;
3795
3796 if (count > 2)
3797 tmp2 = *vals[2];
3798 else
3799 tmp2.v_type = V_NULL;
3800 if (count > 1)
3801 tmp1 = *vals[1];
3802 else
3803 tmp1.v_type = V_NULL;
3804 broundvalue(vals[0], &tmp1, &tmp2, &res);
3805 return res;
3806 }
3807
3808
3809 S_FUNC VALUE
f_appr(int count,VALUE ** vals)3810 f_appr(int count, VALUE **vals)
3811 {
3812 VALUE tmp1, tmp2, res;
3813
3814 /* initialize VALUEs */
3815 res.v_subtype = V_NOSUBTYPE;
3816 tmp1.v_subtype = V_NOSUBTYPE;
3817 tmp2.v_subtype = V_NOSUBTYPE;
3818
3819 if (count > 2)
3820 copyvalue(vals[2], &tmp2);
3821 else
3822 tmp2.v_type = V_NULL;
3823 if (count > 1)
3824 copyvalue(vals[1], &tmp1);
3825 else
3826 tmp1.v_type = V_NULL;
3827 apprvalue(vals[0], &tmp1, &tmp2, &res);
3828 freevalue(&tmp1);
3829 freevalue(&tmp2);
3830 return res;
3831 }
3832
3833 S_FUNC VALUE
f_round(int count,VALUE ** vals)3834 f_round(int count, VALUE **vals)
3835 {
3836 VALUE tmp1, tmp2, res;
3837
3838 /* initialize VALUEs */
3839 res.v_subtype = V_NOSUBTYPE;
3840 tmp1.v_subtype = V_NOSUBTYPE;
3841 tmp2.v_subtype = V_NOSUBTYPE;
3842
3843 if (count > 2)
3844 tmp2 = *vals[2];
3845 else
3846 tmp2.v_type = V_NULL;
3847 if (count > 1)
3848 tmp1 = *vals[1];
3849 else
3850 tmp1.v_type = V_NULL;
3851 roundvalue(vals[0], &tmp1, &tmp2, &res);
3852 return res;
3853 }
3854
3855
3856 S_FUNC NUMBER *
f_btrunc(int count,NUMBER ** vals)3857 f_btrunc(int count, NUMBER **vals)
3858 {
3859 NUMBER *val;
3860
3861 val = qlink(&_qzero_);
3862 if (count == 2)
3863 val = vals[1];
3864 return qbtrunc(*vals, val);
3865 }
3866
3867
3868 S_FUNC VALUE
f_quo(int count,VALUE ** vals)3869 f_quo(int count, VALUE **vals)
3870 {
3871 VALUE tmp, res;
3872
3873 /* initialize VALUEs */
3874 res.v_subtype = V_NOSUBTYPE;
3875 tmp.v_subtype = V_NOSUBTYPE;
3876
3877 if (count > 2)
3878 tmp = *vals[2];
3879 else
3880 tmp.v_type = V_NULL;
3881 quovalue(vals[0], vals[1], &tmp, &res);
3882 return res;
3883 }
3884
3885
3886 S_FUNC VALUE
f_mod(int count,VALUE ** vals)3887 f_mod(int count, VALUE **vals)
3888 {
3889 VALUE tmp, res;
3890
3891 /* initialize VALUEs */
3892 res.v_subtype = V_NOSUBTYPE;
3893 tmp.v_subtype = V_NOSUBTYPE;
3894
3895 if (count > 2)
3896 tmp = *vals[2];
3897 else
3898 tmp.v_type = V_NULL;
3899 modvalue(vals[0], vals[1], &tmp, &res);
3900 return res;
3901 }
3902
3903 S_FUNC VALUE
f_quomod(int count,VALUE ** vals)3904 f_quomod(int count, VALUE **vals)
3905 {
3906 VALUE *v1, *v2, *v3, *v4, *v5;
3907 VALUE result;
3908 long rnd;
3909 BOOL res;
3910 short s3, s4; /* to preserve subtypes of v3, v4 */
3911
3912 v1 = vals[0];
3913 v2 = vals[1];
3914 v3 = vals[2];
3915 v4 = vals[3];
3916
3917 if (v3->v_type != V_ADDR || v4->v_type != V_ADDR ||
3918 v3->v_addr == v4->v_addr)
3919 return error_value(E_QUOMOD1);
3920 if (count == 5) {
3921 v5 = vals[4];
3922 if (v5->v_type == V_ADDR)
3923 v5 = v5->v_addr;
3924 if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
3925 qisneg(v5->v_num) || zge31b(v5->v_num->num))
3926 return error_value(E_QUOMOD2);
3927 rnd = qtoi(v5->v_num);
3928 } else
3929 rnd = conf->quomod;
3930
3931 if (v1->v_type == V_ADDR)
3932 v1 = v1->v_addr;
3933 if (v2->v_type == V_ADDR)
3934 v2 = v2->v_addr;
3935 v3 = v3->v_addr;
3936 v4 = v4->v_addr;
3937
3938 if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
3939 (v3->v_type != V_NUM && v3->v_type != V_NULL) ||
3940 (v4->v_type != V_NUM && v4->v_type != V_NULL))
3941 return error_value(E_QUOMOD2);
3942
3943 s3 = v3->v_subtype;
3944 s4 = v4->v_subtype;
3945
3946 if ((s3 | s4) & V_NOASSIGNTO)
3947 return error_value(E_QUOMOD3);
3948
3949 freevalue(v3);
3950 freevalue(v4);
3951
3952 v3->v_type = V_NUM;
3953 v4->v_type = V_NUM;
3954
3955 v3->v_subtype = s3;
3956 v4->v_subtype = s4;
3957
3958 res = qquomod(v1->v_num, v2->v_num, &v3->v_num, &v4->v_num, rnd);
3959 result.v_type = V_NUM;
3960 result.v_subtype = V_NOSUBTYPE;
3961 result.v_num = res ? qlink(&_qone_) : qlink(&_qzero_);
3962 return result;
3963 }
3964
3965
3966 S_FUNC VALUE
f_d2dms(int count,VALUE ** vals)3967 f_d2dms(int count, VALUE **vals)
3968 {
3969 VALUE *v1, *v2, *v3, *v4, *v5;
3970 NUMBER *tmp, *tmp_m;
3971 VALUE result;
3972 long rnd;
3973 short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
3974
3975 /* collect required args */
3976 v1 = vals[0];
3977 v2 = vals[1];
3978 v3 = vals[2];
3979 v4 = vals[3];
3980
3981 /* determine rounding mode */
3982 if (count == 5) {
3983 v5 = vals[4];
3984 if (v5->v_type == V_ADDR) {
3985 v5 = v5->v_addr;
3986 }
3987 if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
3988 qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
3989 return error_value(E_D2DMS4);
3990 }
3991 rnd = qtoi(v5->v_num);
3992 } else {
3993 rnd = conf->quomod;
3994 }
3995
3996 /* type parse args */
3997 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
3998 v4->v_type != V_ADDR) {
3999 return error_value(E_D2DMS1);
4000 }
4001 if (v1->v_type == V_ADDR) {
4002 v1 = v1->v_addr;
4003 }
4004 v2 = v2->v_addr;
4005 v3 = v3->v_addr;
4006 v4 = v4->v_addr;
4007 if (v1->v_type != V_NUM ||
4008 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4009 (v3->v_type != V_NUM && v3->v_type != V_NULL) ||
4010 (v4->v_type != V_NUM && v4->v_type != V_NULL)) {
4011 return error_value(E_D2DMS2);
4012 }
4013
4014 /* remember arg subtypes */
4015 s2 = v2->v_subtype;
4016 s3 = v3->v_subtype;
4017 s4 = v4->v_subtype;
4018 if ((s2 | s3 | s4) & V_NOASSIGNTO) {
4019 return error_value(E_D2DMS3);
4020 }
4021
4022 /* free old args that will be modified */
4023 freevalue(v2);
4024 freevalue(v3);
4025 freevalue(v4);
4026
4027 /* set args that will be modified */
4028 v2->v_type = V_NUM;
4029 v3->v_type = V_NUM;
4030 v4->v_type = V_NUM;
4031
4032 /* restore arg subtypes */
4033 v2->v_subtype = s2;
4034 v3->v_subtype = s3;
4035 v4->v_subtype = s4;
4036
4037 /*
4038 * calculate the normalized return value
4039 *
4040 * return_value = mod(degs, 360, rnd);
4041 */
4042 result.v_type = v1->v_type;
4043 result.v_subtype = v1->v_subtype;
4044 result.v_num = qmod(v1->v_num, &_qthreesixty, rnd);
4045
4046 /*
4047 * integer number of degrees
4048 *
4049 * d = int(return_value);
4050 */
4051 v2->v_num = qint(result.v_num);
4052
4053 /*
4054 * integer number of minutes
4055 *
4056 * tmp = return_value - d;
4057 * tmp_m = tmp * 60;
4058 * free(tmp);
4059 * m = int(tmp_m);
4060 */
4061 tmp = qsub(result.v_num, v2->v_num);
4062 tmp_m = qmuli(tmp, 60);
4063 qfree(tmp);
4064 v3->v_num = qint(tmp_m);
4065
4066 /*
4067 * number of seconds
4068 *
4069 * tmp = tmp_m - m;
4070 * free(tmp_m);
4071 * s = tmp * 60;
4072 * free(tmp);
4073 */
4074 tmp = qsub(tmp_m, v3->v_num);
4075 qfree(tmp_m);
4076 v4->v_num = qmuli(tmp, 60);
4077 qfree(tmp);
4078
4079 /*
4080 * return the normalized value previously calculated
4081 */
4082 return result;
4083 }
4084
4085
4086 S_FUNC VALUE
f_d2dm(int count,VALUE ** vals)4087 f_d2dm(int count, VALUE **vals)
4088 {
4089 VALUE *v1, *v2, *v3, *v4;
4090 NUMBER *tmp;
4091 VALUE result;
4092 long rnd;
4093 short s2, s3; /* to preserve subtypes of v2, v3 */
4094
4095 /* collect required args */
4096 v1 = vals[0];
4097 v2 = vals[1];
4098 v3 = vals[2];
4099
4100 /* determine rounding mode */
4101 if (count == 4) {
4102 v4 = vals[3];
4103 if (v4->v_type == V_ADDR) {
4104 v4 = v4->v_addr;
4105 }
4106 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4107 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4108 return error_value(E_D2DM4);
4109 }
4110 rnd = qtoi(v4->v_num);
4111 } else {
4112 rnd = conf->quomod;
4113 }
4114
4115 /* type parse args */
4116 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
4117 return error_value(E_D2DM1);
4118 }
4119 if (v1->v_type == V_ADDR) {
4120 v1 = v1->v_addr;
4121 }
4122 v2 = v2->v_addr;
4123 v3 = v3->v_addr;
4124 if (v1->v_type != V_NUM ||
4125 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4126 (v3->v_type != V_NUM && v3->v_type != V_NULL)) {
4127 return error_value(E_D2DM2);
4128 }
4129
4130 /* remember arg subtypes */
4131 s2 = v2->v_subtype;
4132 s3 = v3->v_subtype;
4133 if ((s2 | s3) & V_NOASSIGNTO) {
4134 return error_value(E_D2DM3);
4135 }
4136
4137 /* free old args that will be modified */
4138 freevalue(v2);
4139 freevalue(v3);
4140
4141 /* set args that will be modified */
4142 v2->v_type = V_NUM;
4143 v3->v_type = V_NUM;
4144
4145 /* restore arg subtypes */
4146 v2->v_subtype = s2;
4147 v3->v_subtype = s3;
4148
4149 /*
4150 * calculate the normalized return value
4151 *
4152 * return_value = mod(degs, 360, rnd);
4153 */
4154 result.v_type = v1->v_type;
4155 result.v_subtype = v1->v_subtype;
4156 result.v_num = qmod(v1->v_num, &_qthreesixty, rnd);
4157
4158 /*
4159 * integer number of degrees
4160 *
4161 * d = int(return_value);
4162 */
4163 v2->v_num = qint(result.v_num);
4164
4165 /*
4166 * integer number of minutes
4167 *
4168 * tmp = return_value - d;
4169 * m = tmp * 60;
4170 * free(tmp);
4171 */
4172 tmp = qsub(result.v_num, v2->v_num);
4173 v3->v_num = qmuli(tmp, 60);
4174 qfree(tmp);
4175
4176 /*
4177 * return the normalized value previously calculated
4178 */
4179 return result;
4180 }
4181
4182
4183 S_FUNC VALUE
f_g2gms(int count,VALUE ** vals)4184 f_g2gms(int count, VALUE **vals)
4185 {
4186 VALUE *v1, *v2, *v3, *v4, *v5;
4187 NUMBER *tmp, *tmp_m;
4188 VALUE result;
4189 long rnd;
4190 short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
4191
4192 /* collect required args */
4193 v1 = vals[0];
4194 v2 = vals[1];
4195 v3 = vals[2];
4196 v4 = vals[3];
4197
4198 /* determine rounding mode */
4199 if (count == 5) {
4200 v5 = vals[4];
4201 if (v5->v_type == V_ADDR) {
4202 v5 = v5->v_addr;
4203 }
4204 if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
4205 qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
4206 return error_value(E_G2GMS4);
4207 }
4208 rnd = qtoi(v5->v_num);
4209 } else {
4210 rnd = conf->quomod;
4211 }
4212
4213 /* type parse args */
4214 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
4215 v4->v_type != V_ADDR) {
4216 return error_value(E_G2GMS1);
4217 }
4218 if (v1->v_type == V_ADDR) {
4219 v1 = v1->v_addr;
4220 }
4221 v2 = v2->v_addr;
4222 v3 = v3->v_addr;
4223 v4 = v4->v_addr;
4224 if (v1->v_type != V_NUM ||
4225 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4226 (v3->v_type != V_NUM && v3->v_type != V_NULL) ||
4227 (v4->v_type != V_NUM && v4->v_type != V_NULL)) {
4228 return error_value(E_G2GMS2);
4229 }
4230
4231 /* remember arg subtypes */
4232 s2 = v2->v_subtype;
4233 s3 = v3->v_subtype;
4234 s4 = v4->v_subtype;
4235 if ((s2 | s3 | s4) & V_NOASSIGNTO) {
4236 return error_value(E_G2GMS3);
4237 }
4238
4239 /* free old args that will be modified */
4240 freevalue(v2);
4241 freevalue(v3);
4242 freevalue(v4);
4243
4244 /* set args that will be modified */
4245 v2->v_type = V_NUM;
4246 v3->v_type = V_NUM;
4247 v4->v_type = V_NUM;
4248
4249 /* restore arg subtypes */
4250 v2->v_subtype = s2;
4251 v3->v_subtype = s3;
4252 v4->v_subtype = s4;
4253
4254 /*
4255 * calculate the normalized return value
4256 *
4257 * return_value = mod(grads, 400, rnd);
4258 */
4259 result.v_type = v1->v_type;
4260 result.v_subtype = v1->v_subtype;
4261 result.v_num = qmod(v1->v_num, &_qfourhundred, rnd);
4262
4263 /*
4264 * integer number of gradians
4265 *
4266 * g = int(return_value);
4267 */
4268 v2->v_num = qint(result.v_num);
4269
4270 /*
4271 * integer number of minutes
4272 *
4273 * tmp = return_value - g;
4274 * tmp_m = tmp * 60;
4275 * free(tmp);
4276 * m = int(tmp_m);
4277 */
4278 tmp = qsub(result.v_num, v2->v_num);
4279 tmp_m = qmuli(tmp, 60);
4280 qfree(tmp);
4281 v3->v_num = qint(tmp_m);
4282
4283 /*
4284 * number of seconds
4285 *
4286 * tmp = tmp_m - m;
4287 * free(tmp_m);
4288 * s = tmp * 60;
4289 * free(tmp);
4290 */
4291 tmp = qsub(tmp_m, v3->v_num);
4292 qfree(tmp_m);
4293 v4->v_num = qmuli(tmp, 60);
4294 qfree(tmp);
4295
4296 /*
4297 * return the normalized value previously calculated
4298 */
4299 return result;
4300 }
4301
4302
4303 S_FUNC VALUE
f_g2gm(int count,VALUE ** vals)4304 f_g2gm(int count, VALUE **vals)
4305 {
4306 VALUE *v1, *v2, *v3, *v4;
4307 NUMBER *tmp;
4308 VALUE result;
4309 long rnd;
4310 short s2, s3; /* to preserve subtypes of v2, v3 */
4311
4312 /* collect required args */
4313 v1 = vals[0];
4314 v2 = vals[1];
4315 v3 = vals[2];
4316
4317 /* determine rounding mode */
4318 if (count == 4) {
4319 v4 = vals[3];
4320 if (v4->v_type == V_ADDR) {
4321 v4 = v4->v_addr;
4322 }
4323 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4324 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4325 return error_value(E_G2GM4);
4326 }
4327 rnd = qtoi(v4->v_num);
4328 } else {
4329 rnd = conf->quomod;
4330 }
4331
4332 /* type parse args */
4333 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
4334 return error_value(E_G2GM1);
4335 }
4336 if (v1->v_type == V_ADDR) {
4337 v1 = v1->v_addr;
4338 }
4339 v2 = v2->v_addr;
4340 v3 = v3->v_addr;
4341 if (v1->v_type != V_NUM ||
4342 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4343 (v3->v_type != V_NUM && v3->v_type != V_NULL)) {
4344 return error_value(E_G2GM2);
4345 }
4346
4347 /* remember arg subtypes */
4348 s2 = v2->v_subtype;
4349 s3 = v3->v_subtype;
4350 if ((s2 | s3) & V_NOASSIGNTO) {
4351 return error_value(E_G2GM3);
4352 }
4353
4354 /* free old args that will be modified */
4355 freevalue(v2);
4356 freevalue(v3);
4357
4358 /* set args that will be modified */
4359 v2->v_type = V_NUM;
4360 v3->v_type = V_NUM;
4361
4362 /* restore arg subtypes */
4363 v2->v_subtype = s2;
4364 v3->v_subtype = s3;
4365
4366 /*
4367 * calculate the normalized return value
4368 *
4369 * return_value = mod(grads, 400, rnd);
4370 */
4371 result.v_type = v1->v_type;
4372 result.v_subtype = v1->v_subtype;
4373 result.v_num = qmod(v1->v_num, &_qfourhundred, rnd);
4374
4375 /*
4376 * integer number of gradians
4377 *
4378 * g = int(return_value);
4379 */
4380 v2->v_num = qint(result.v_num);
4381
4382 /*
4383 * integer number of minutes
4384 *
4385 * tmp = return_value - g;
4386 * m = tmp * 60;
4387 * free(tmp);
4388 */
4389 tmp = qsub(result.v_num, v2->v_num);
4390 v3->v_num = qmuli(tmp, 60);
4391 qfree(tmp);
4392
4393 /*
4394 * return the normalized value previously calculated
4395 */
4396 return result;
4397 }
4398
4399
4400 S_FUNC VALUE
f_h2hms(int count,VALUE ** vals)4401 f_h2hms(int count, VALUE **vals)
4402 {
4403 VALUE *v1, *v2, *v3, *v4, *v5;
4404 NUMBER *tmp, *tmp_m;
4405 VALUE result;
4406 long rnd;
4407 short s2, s3, s4; /* to preserve subtypes of v2, v3, v4 */
4408
4409 /* collect required args */
4410 v1 = vals[0];
4411 v2 = vals[1];
4412 v3 = vals[2];
4413 v4 = vals[3];
4414
4415 /* determine rounding mode */
4416 if (count == 5) {
4417 v5 = vals[4];
4418 if (v5->v_type == V_ADDR) {
4419 v5 = v5->v_addr;
4420 }
4421 if (v5->v_type != V_NUM || qisfrac(v5->v_num) ||
4422 qisneg(v5->v_num) || zge31b(v5->v_num->num)) {
4423 return error_value(E_H2HMS4);
4424 }
4425 rnd = qtoi(v5->v_num);
4426 } else {
4427 rnd = conf->quomod;
4428 }
4429
4430 /* type parse args */
4431 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR ||
4432 v4->v_type != V_ADDR) {
4433 return error_value(E_H2HMS1);
4434 }
4435 if (v1->v_type == V_ADDR) {
4436 v1 = v1->v_addr;
4437 }
4438 v2 = v2->v_addr;
4439 v3 = v3->v_addr;
4440 v4 = v4->v_addr;
4441 if (v1->v_type != V_NUM ||
4442 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4443 (v3->v_type != V_NUM && v3->v_type != V_NULL) ||
4444 (v4->v_type != V_NUM && v4->v_type != V_NULL)) {
4445 return error_value(E_H2HMS2);
4446 }
4447
4448 /* remember arg subtypes */
4449 s2 = v2->v_subtype;
4450 s3 = v3->v_subtype;
4451 s4 = v4->v_subtype;
4452 if ((s2 | s3 | s4) & V_NOASSIGNTO) {
4453 return error_value(E_H2HMS3);
4454 }
4455
4456 /* free old args that will be modified */
4457 freevalue(v2);
4458 freevalue(v3);
4459 freevalue(v4);
4460
4461 /* set args that will be modified */
4462 v2->v_type = V_NUM;
4463 v3->v_type = V_NUM;
4464 v4->v_type = V_NUM;
4465
4466 /* restore arg subtypes */
4467 v2->v_subtype = s2;
4468 v3->v_subtype = s3;
4469 v4->v_subtype = s4;
4470
4471 /*
4472 * calculate the normalized return value
4473 *
4474 * return_value = mod(hours, 24, rnd);
4475 */
4476 result.v_type = v1->v_type;
4477 result.v_subtype = v1->v_subtype;
4478 result.v_num = qmod(v1->v_num, &_qtwentyfour, rnd);
4479
4480 /*
4481 * integer number of hours
4482 *
4483 * h = int(return_value);
4484 */
4485 v2->v_num = qint(result.v_num);
4486
4487 /*
4488 * integer number of minutes
4489 *
4490 * tmp = return_value - h;
4491 * tmp_m = tmp * 60;
4492 * free(tmp);
4493 * m = int(tmp_m);
4494 */
4495 tmp = qsub(result.v_num, v2->v_num);
4496 tmp_m = qmuli(tmp, 60);
4497 qfree(tmp);
4498 v3->v_num = qint(tmp_m);
4499
4500 /*
4501 * number of seconds
4502 *
4503 * tmp = tmp_m - m;
4504 * free(tmp_m);
4505 * s = tmp * 60;
4506 * free(tmp);
4507 */
4508 tmp = qsub(tmp_m, v3->v_num);
4509 qfree(tmp_m);
4510 v4->v_num = qmuli(tmp, 60);
4511 qfree(tmp);
4512
4513 /*
4514 * return the normalized value previously calculated
4515 */
4516 return result;
4517 }
4518
4519
4520 S_FUNC VALUE
f_h2hm(int count,VALUE ** vals)4521 f_h2hm(int count, VALUE **vals)
4522 {
4523 VALUE *v1, *v2, *v3, *v4;
4524 NUMBER *tmp;
4525 VALUE result;
4526 long rnd;
4527 short s2, s3; /* to preserve subtypes of v2, v3 */
4528
4529 /* collect required args */
4530 v1 = vals[0];
4531 v2 = vals[1];
4532 v3 = vals[2];
4533
4534 /* determine rounding mode */
4535 if (count == 4) {
4536 v4 = vals[3];
4537 if (v4->v_type == V_ADDR) {
4538 v4 = v4->v_addr;
4539 }
4540 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4541 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4542 return error_value(E_H2HM4);
4543 }
4544 rnd = qtoi(v4->v_num);
4545 } else {
4546 rnd = conf->quomod;
4547 }
4548
4549 /* type parse args */
4550 if (v2->v_type != V_ADDR || v3->v_type != V_ADDR) {
4551 return error_value(E_H2HM1);
4552 }
4553 if (v1->v_type == V_ADDR) {
4554 v1 = v1->v_addr;
4555 }
4556 v2 = v2->v_addr;
4557 v3 = v3->v_addr;
4558 if (v1->v_type != V_NUM ||
4559 (v2->v_type != V_NUM && v2->v_type != V_NULL) ||
4560 (v3->v_type != V_NUM && v3->v_type != V_NULL)) {
4561 return error_value(E_H2HM2);
4562 }
4563
4564 /* remember arg subtypes */
4565 s2 = v2->v_subtype;
4566 s3 = v3->v_subtype;
4567 if ((s2 | s3) & V_NOASSIGNTO) {
4568 return error_value(E_H2HM3);
4569 }
4570
4571 /* free old args that will be modified */
4572 freevalue(v2);
4573 freevalue(v3);
4574
4575 /* set args that will be modified */
4576 v2->v_type = V_NUM;
4577 v3->v_type = V_NUM;
4578
4579 /* restore arg subtypes */
4580 v2->v_subtype = s2;
4581 v3->v_subtype = s3;
4582
4583 /*
4584 * calculate the normalized return value
4585 *
4586 * return_value = mod(hours, 24, rnd);
4587 */
4588 result.v_type = v1->v_type;
4589 result.v_subtype = v1->v_subtype;
4590 result.v_num = qmod(v1->v_num, &_qtwentyfour, rnd);
4591
4592 /*
4593 * integer number of gradians
4594 *
4595 * h = int(return_value);
4596 */
4597 v2->v_num = qint(result.v_num);
4598
4599 /*
4600 * integer number of minutes
4601 *
4602 * tmp = return_value - h;
4603 * m = tmp * 60;
4604 * free(tmp);
4605 */
4606 tmp = qsub(result.v_num, v2->v_num);
4607 v3->v_num = qmuli(tmp, 60);
4608 qfree(tmp);
4609
4610 /*
4611 * return the normalized value previously calculated
4612 */
4613 return result;
4614 }
4615
4616
4617 S_FUNC VALUE
f_dms2d(int count,VALUE ** vals)4618 f_dms2d(int count, VALUE **vals)
4619 {
4620 VALUE *v1, *v2, *v3, *v4;
4621 NUMBER *tmp, *tmp2, *tmp3, *tmp4;
4622 VALUE result;
4623 long rnd;
4624
4625 /* collect required args */
4626 v1 = vals[0];
4627 v2 = vals[1];
4628 v3 = vals[2];
4629
4630 /* determine rounding mode */
4631 if (count == 4) {
4632 v4 = vals[3];
4633 if (v4->v_type == V_ADDR) {
4634 v4 = v4->v_addr;
4635 }
4636 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4637 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4638 return error_value(E_DMS2D2);
4639 }
4640 rnd = qtoi(v4->v_num);
4641 } else {
4642 rnd = conf->quomod;
4643 }
4644
4645 /* type parse args */
4646 if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
4647 v3->v_type != V_NUM) {
4648 return error_value(E_DMS2D1);
4649 }
4650
4651 /*
4652 * compute s/3600
4653 */
4654 tmp = qdivi(v3->v_num, 3600);
4655
4656 /*
4657 * compute m/60
4658 */
4659 tmp2 = qdivi(v2->v_num, 60);
4660
4661 /*
4662 * compute m/60 + s/3600
4663 */
4664 tmp3 = qqadd(tmp2, tmp);
4665 qfree(tmp);
4666 qfree(tmp2);
4667
4668 /*
4669 * compute d + m/60 + s/3600
4670 */
4671 tmp4 = qqadd(v1->v_num, tmp3);
4672 qfree(tmp3);
4673
4674 /*
4675 * compute mod(d + m/60 + s/3600, 360, rnd);
4676 */
4677 result.v_type = v1->v_type;
4678 result.v_subtype = v1->v_subtype;
4679 result.v_num = qmod(tmp4, &_qthreesixty, rnd);
4680 qfree(tmp4);
4681
4682 /*
4683 * return mod(d + m/60 + s/3600, 360, rnd);
4684 */
4685 return result;
4686 }
4687
4688
4689 S_FUNC VALUE
f_dm2d(int count,VALUE ** vals)4690 f_dm2d(int count, VALUE **vals)
4691 {
4692 VALUE *v1, *v2, *v3;
4693 NUMBER *tmp, *tmp2;
4694 VALUE result;
4695 long rnd;
4696
4697 /* collect required args */
4698 v1 = vals[0];
4699 v2 = vals[1];
4700
4701 /* determine rounding mode */
4702 if (count == 3) {
4703 v3 = vals[2];
4704 if (v3->v_type == V_ADDR) {
4705 v3 = v3->v_addr;
4706 }
4707 if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
4708 qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
4709 return error_value(E_DM2D2);
4710 }
4711 rnd = qtoi(v3->v_num);
4712 } else {
4713 rnd = conf->quomod;
4714 }
4715
4716 /* type parse args */
4717 if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
4718 return error_value(E_DM2D1);
4719 }
4720
4721 /*
4722 * compute m/60
4723 */
4724 tmp = qdivi(v2->v_num, 60);
4725
4726 /*
4727 * compute d + m/60
4728 */
4729 tmp2 = qqadd(v1->v_num, tmp);
4730 qfree(tmp);
4731
4732 /*
4733 * compute mod(d + m/60, 360, rnd);
4734 */
4735 result.v_type = v1->v_type;
4736 result.v_subtype = v1->v_subtype;
4737 result.v_num = qmod(tmp2, &_qthreesixty, rnd);
4738 qfree(tmp2);
4739
4740 /*
4741 * return mod(d + m/60, 360, rnd);
4742 */
4743 return result;
4744 }
4745
4746
4747 S_FUNC VALUE
f_gms2g(int count,VALUE ** vals)4748 f_gms2g(int count, VALUE **vals)
4749 {
4750 VALUE *v1, *v2, *v3, *v4;
4751 NUMBER *tmp, *tmp2, *tmp3, *tmp4;
4752 VALUE result;
4753 long rnd;
4754
4755 /* collect required args */
4756 v1 = vals[0];
4757 v2 = vals[1];
4758 v3 = vals[2];
4759
4760 /* determine rounding mode */
4761 if (count == 4) {
4762 v4 = vals[3];
4763 if (v4->v_type == V_ADDR) {
4764 v4 = v4->v_addr;
4765 }
4766 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4767 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4768 return error_value(E_GMS2G2);
4769 }
4770 rnd = qtoi(v4->v_num);
4771 } else {
4772 rnd = conf->quomod;
4773 }
4774
4775 /* type parse args */
4776 if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
4777 v3->v_type != V_NUM) {
4778 return error_value(E_GMS2G1);
4779 }
4780
4781 /*
4782 * compute s/3600
4783 */
4784 tmp = qdivi(v3->v_num, 3600);
4785
4786 /*
4787 * compute m/60
4788 */
4789 tmp2 = qdivi(v2->v_num, 60);
4790
4791 /*
4792 * compute m/60 + s/3600
4793 */
4794 tmp3 = qqadd(tmp2, tmp);
4795 qfree(tmp);
4796 qfree(tmp2);
4797
4798 /*
4799 * compute g + m/60 + s/3600
4800 */
4801 tmp4 = qqadd(v1->v_num, tmp3);
4802 qfree(tmp3);
4803
4804 /*
4805 * compute mod(g + m/60 + s/3600, 400, rnd);
4806 */
4807 result.v_type = v1->v_type;
4808 result.v_subtype = v1->v_subtype;
4809 result.v_num = qmod(tmp4, &_qfourhundred, rnd);
4810 qfree(tmp4);
4811
4812 /*
4813 * return mod(g + m/60 + s/3600, 400, rnd);
4814 */
4815 return result;
4816 }
4817
4818
4819 S_FUNC VALUE
f_gm2g(int count,VALUE ** vals)4820 f_gm2g(int count, VALUE **vals)
4821 {
4822 VALUE *v1, *v2, *v3;
4823 NUMBER *tmp, *tmp2;
4824 VALUE result;
4825 long rnd;
4826
4827 /* collect required args */
4828 v1 = vals[0];
4829 v2 = vals[1];
4830
4831 /* determine rounding mode */
4832 if (count == 3) {
4833 v3 = vals[2];
4834 if (v3->v_type == V_ADDR) {
4835 v3 = v3->v_addr;
4836 }
4837 if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
4838 qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
4839 return error_value(E_GM2G2);
4840 }
4841 rnd = qtoi(v3->v_num);
4842 } else {
4843 rnd = conf->quomod;
4844 }
4845
4846 /* type parse args */
4847 if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
4848 return error_value(E_GM2G1);
4849 }
4850
4851 /*
4852 * compute m/60
4853 */
4854 tmp = qdivi(v2->v_num, 60);
4855
4856 /*
4857 * compute g + m/60
4858 */
4859 tmp2 = qqadd(v1->v_num, tmp);
4860 qfree(tmp);
4861
4862 /*
4863 * compute mod(g + m/60, 400, rnd);
4864 */
4865 result.v_type = v1->v_type;
4866 result.v_subtype = v1->v_subtype;
4867 result.v_num = qmod(tmp2, &_qfourhundred, rnd);
4868 qfree(tmp2);
4869
4870 /*
4871 * return mod(g + m/60, 400, rnd);
4872 */
4873 return result;
4874 }
4875
4876
4877 S_FUNC VALUE
f_hms2h(int count,VALUE ** vals)4878 f_hms2h(int count, VALUE **vals)
4879 {
4880 VALUE *v1, *v2, *v3, *v4;
4881 NUMBER *tmp, *tmp2, *tmp3, *tmp4;
4882 VALUE result;
4883 long rnd;
4884
4885 /* collect required args */
4886 v1 = vals[0];
4887 v2 = vals[1];
4888 v3 = vals[2];
4889
4890 /* determine rounding mode */
4891 if (count == 4) {
4892 v4 = vals[3];
4893 if (v4->v_type == V_ADDR) {
4894 v4 = v4->v_addr;
4895 }
4896 if (v4->v_type != V_NUM || qisfrac(v4->v_num) ||
4897 qisneg(v4->v_num) || zge31b(v4->v_num->num)) {
4898 return error_value(E_HMS2H2);
4899 }
4900 rnd = qtoi(v4->v_num);
4901 } else {
4902 rnd = conf->quomod;
4903 }
4904
4905 /* type parse args */
4906 if (v1->v_type != V_NUM || v2->v_type != V_NUM ||
4907 v3->v_type != V_NUM) {
4908 return error_value(E_HMS2H1);
4909 }
4910
4911 /*
4912 * compute s/3600
4913 */
4914 tmp = qdivi(v3->v_num, 3600);
4915
4916 /*
4917 * compute m/60
4918 */
4919 tmp2 = qdivi(v2->v_num, 60);
4920
4921 /*
4922 * compute m/60 + s/3600
4923 */
4924 tmp3 = qqadd(tmp2, tmp);
4925 qfree(tmp);
4926 qfree(tmp2);
4927
4928 /*
4929 * compute h + m/60 + s/3600
4930 */
4931 tmp4 = qqadd(v1->v_num, tmp3);
4932 qfree(tmp3);
4933
4934 /*
4935 * compute mod(h + m/60 + s/3600, 24, rnd);
4936 */
4937 result.v_type = v1->v_type;
4938 result.v_subtype = v1->v_subtype;
4939 result.v_num = qmod(tmp4, &_qtwentyfour, rnd);
4940 qfree(tmp4);
4941
4942 /*
4943 * return mod(d + m/60 + s/3600, 24, rnd);
4944 */
4945 return result;
4946 }
4947
4948
4949 S_FUNC VALUE
f_hm2h(int count,VALUE ** vals)4950 f_hm2h(int count, VALUE **vals)
4951 {
4952 VALUE *v1, *v2, *v3;
4953 NUMBER *tmp, *tmp2;
4954 VALUE result;
4955 long rnd;
4956
4957 /* collect required args */
4958 v1 = vals[0];
4959 v2 = vals[1];
4960
4961 /* determine rounding mode */
4962 if (count == 3) {
4963 v3 = vals[2];
4964 if (v3->v_type == V_ADDR) {
4965 v3 = v3->v_addr;
4966 }
4967 if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
4968 qisneg(v3->v_num) || zge31b(v3->v_num->num)) {
4969 return error_value(E_H2HM2);
4970 }
4971 rnd = qtoi(v3->v_num);
4972 } else {
4973 rnd = conf->quomod;
4974 }
4975
4976 /* type parse args */
4977 if (v1->v_type != V_NUM || v2->v_type != V_NUM) {
4978 return error_value(E_H2HM1);
4979 }
4980
4981 /*
4982 * compute m/60
4983 */
4984 tmp = qdivi(v2->v_num, 60);
4985
4986 /*
4987 * compute d + m/60
4988 */
4989 tmp2 = qqadd(v1->v_num, tmp);
4990 qfree(tmp);
4991
4992 /*
4993 * compute mod(h + m/60, 24, rnd);
4994 */
4995 result.v_type = v1->v_type;
4996 result.v_subtype = v1->v_subtype;
4997 result.v_num = qmod(tmp2, &_qtwentyfour, rnd);
4998 qfree(tmp2);
4999
5000 /*
5001 * return mod(h + m/60, 24, rnd);
5002 */
5003 return result;
5004 }
5005
5006
5007 S_FUNC VALUE
f_mmin(VALUE * v1,VALUE * v2)5008 f_mmin(VALUE *v1, VALUE *v2)
5009 {
5010 VALUE sixteen, res;
5011
5012 /* initialize VALUEs */
5013 sixteen.v_subtype = V_NOSUBTYPE;
5014 res.v_subtype = V_NOSUBTYPE;
5015
5016 sixteen.v_type = V_NUM;
5017 sixteen.v_num = itoq(16);
5018 modvalue(v1, v2, &sixteen, &res);
5019 qfree(sixteen.v_num);
5020 return res;
5021 }
5022
5023
5024 S_FUNC NUMBER *
f_near(int count,NUMBER ** vals)5025 f_near(int count, NUMBER **vals)
5026 {
5027 NUMBER *val;
5028
5029 val = conf->epsilon;
5030 if (count == 3)
5031 val = vals[2];
5032 return itoq((long) qnear(vals[0], vals[1], val));
5033 }
5034
5035
5036 S_FUNC NUMBER *
f_cfsim(int count,NUMBER ** vals)5037 f_cfsim(int count, NUMBER **vals)
5038 {
5039 long R;
5040
5041 R = (count > 1) ? qtoi(vals[1]) : conf->cfsim;
5042 return qcfsim(vals[0], R);
5043 }
5044
5045
5046 S_FUNC NUMBER *
f_cfappr(int count,NUMBER ** vals)5047 f_cfappr(int count, NUMBER **vals)
5048 {
5049 long R;
5050 NUMBER *q;
5051
5052 R = (count > 2) ? qtoi(vals[2]) : conf->cfappr;
5053 q = (count > 1) ? vals[1] : conf->epsilon;
5054
5055 return qcfappr(vals[0], q, R);
5056 }
5057
5058
5059 S_FUNC VALUE
f_ceil(VALUE * val)5060 f_ceil(VALUE *val)
5061 {
5062 VALUE tmp, res;
5063
5064 /* initialize VALUEs */
5065 res.v_subtype = V_NOSUBTYPE;
5066 tmp.v_subtype = V_NOSUBTYPE;
5067
5068 tmp.v_type = V_NUM;
5069 tmp.v_num = qlink(&_qone_);
5070 apprvalue(val, &tmp, &tmp, &res);
5071 return res;
5072 }
5073
5074
5075 S_FUNC VALUE
f_floor(VALUE * val)5076 f_floor(VALUE *val)
5077 {
5078 VALUE tmp1, tmp2, res;
5079
5080 /* initialize VALUEs */
5081 res.v_subtype = V_NOSUBTYPE;
5082 tmp1.v_subtype = V_NOSUBTYPE;
5083 tmp2.v_subtype = V_NOSUBTYPE;
5084
5085 tmp1.v_type = V_NUM;
5086 tmp1.v_num = qlink(&_qone_);
5087 tmp2.v_type = V_NUM;
5088 tmp2.v_num = qlink(&_qzero_);
5089 apprvalue(val, &tmp1, &tmp2, &res);
5090 return res;
5091 }
5092
5093
5094 S_FUNC VALUE
f_sqrt(int count,VALUE ** vals)5095 f_sqrt(int count, VALUE **vals)
5096 {
5097 VALUE tmp1, tmp2, result;
5098
5099 /* initialize VALUEs */
5100 result.v_subtype = V_NOSUBTYPE;
5101 tmp1.v_subtype = V_NOSUBTYPE;
5102 tmp2.v_subtype = V_NOSUBTYPE;
5103
5104 if (count > 2)
5105 tmp2 = *vals[2];
5106 else
5107 tmp2.v_type = V_NULL;
5108 if (count > 1)
5109 tmp1 = *vals[1];
5110 else
5111 tmp1.v_type = V_NULL;
5112 sqrtvalue(vals[0], &tmp1, &tmp2, &result);
5113 return result;
5114 }
5115
5116
5117 S_FUNC VALUE
f_root(int count,VALUE ** vals)5118 f_root(int count, VALUE **vals)
5119 {
5120 VALUE *vp, err, result;
5121
5122 /* initialize VALUEs */
5123 err.v_subtype = V_NOSUBTYPE;
5124 result.v_subtype = V_NOSUBTYPE;
5125
5126 if (count > 2) {
5127 vp = vals[2];
5128 } else {
5129 err.v_num = conf->epsilon;
5130 err.v_type = V_NUM;
5131 vp = &err;
5132 }
5133 rootvalue(vals[0], vals[1], vp, &result);
5134 return result;
5135 }
5136
5137
5138 S_FUNC VALUE
f_power(int count,VALUE ** vals)5139 f_power(int count, VALUE **vals)
5140 {
5141 VALUE *vp, err, result;
5142
5143 /* initialize VALUEs */
5144 err.v_subtype = V_NOSUBTYPE;
5145 result.v_subtype = V_NOSUBTYPE;
5146
5147 if (count > 2) {
5148 vp = vals[2];
5149 } else {
5150 err.v_num = conf->epsilon;
5151 err.v_type = V_NUM;
5152 vp = &err;
5153 }
5154 powervalue(vals[0], vals[1], vp, &result);
5155 return result;
5156 }
5157
5158
5159 S_FUNC VALUE
f_polar(int count,VALUE ** vals)5160 f_polar(int count, VALUE **vals)
5161 {
5162 VALUE *vp, err, result;
5163 COMPLEX *c;
5164
5165 /* initialize VALUEs */
5166 err.v_subtype = V_NOSUBTYPE;
5167 result.v_subtype = V_NOSUBTYPE;
5168
5169 if (count > 2) {
5170 vp = vals[2];
5171 } else {
5172 err.v_num = conf->epsilon;
5173 err.v_type = V_NUM;
5174 vp = &err;
5175 }
5176 if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM))
5177 return error_value(E_POLAR1);
5178 if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num))
5179 return error_value(E_POLAR2);
5180 c = c_polar(vals[0]->v_num, vals[1]->v_num, vp->v_num);
5181 result.v_com = c;
5182 result.v_type = V_COM;
5183 if (cisreal(c)) {
5184 result.v_num = qlink(c->real);
5185 result.v_type = V_NUM;
5186 comfree(c);
5187 }
5188 return result;
5189 }
5190
5191
5192 S_FUNC VALUE
f_ilog(VALUE * v1,VALUE * v2)5193 f_ilog(VALUE *v1, VALUE *v2)
5194 {
5195 VALUE res;
5196
5197 if (v2->v_type != V_NUM || qisfrac(v2->v_num) || qiszero(v2->v_num) ||
5198 qisunit(v2->v_num))
5199 return error_value(E_ILOGB);
5200
5201 switch(v1->v_type) {
5202 case V_NUM:
5203 res.v_num = qilog(v1->v_num, v2->v_num->num);
5204 break;
5205 case V_COM:
5206 res.v_num = c_ilog(v1->v_com, v2->v_num->num);
5207 break;
5208 default:
5209 return error_value(E_ILOG);
5210 }
5211
5212 if (res.v_num == NULL)
5213 return error_value(E_LOGINF);
5214
5215 res.v_type = V_NUM;
5216 res.v_subtype = V_NOSUBTYPE;
5217 return res;
5218 }
5219
5220
5221 S_FUNC VALUE
f_ilog2(VALUE * vp)5222 f_ilog2(VALUE *vp)
5223 {
5224 VALUE res;
5225
5226 switch(vp->v_type) {
5227 case V_NUM:
5228 res.v_num = qilog(vp->v_num, _two_);
5229 break;
5230 case V_COM:
5231 res.v_num = c_ilog(vp->v_com, _two_);
5232 break;
5233 default:
5234 return error_value(E_ILOG2);
5235 }
5236
5237 if (res.v_num == NULL)
5238 return error_value(E_LOGINF);
5239
5240 res.v_type = V_NUM;
5241 res.v_subtype = V_NOSUBTYPE;
5242 return res;
5243 }
5244
5245
5246 S_FUNC VALUE
f_ilog10(VALUE * vp)5247 f_ilog10(VALUE *vp)
5248 {
5249 VALUE res;
5250
5251 switch(vp->v_type) {
5252 case V_NUM:
5253 res.v_num = qilog(vp->v_num, _ten_);
5254 break;
5255 case V_COM:
5256 res.v_num = c_ilog(vp->v_com, _ten_);
5257 break;
5258 default:
5259 return error_value(E_ILOG10);
5260 }
5261
5262 if (res.v_num == NULL)
5263 return error_value(E_LOGINF);
5264
5265 res.v_type = V_NUM;
5266 res.v_subtype = V_NOSUBTYPE;
5267 return res;
5268 }
5269
5270
5271 S_FUNC NUMBER *
f_faccnt(NUMBER * val1,NUMBER * val2)5272 f_faccnt(NUMBER *val1, NUMBER *val2)
5273 {
5274 if (qisfrac(val1) || qisfrac(val2))
5275 math_error("Non-integral argument for fcnt");
5276 return itoq(zdivcount(val1->num, val2->num));
5277 }
5278
5279
5280 S_FUNC VALUE
f_matfill(int count,VALUE ** vals)5281 f_matfill(int count, VALUE **vals)
5282 {
5283 VALUE *v1, *v2, *v3;
5284 VALUE result;
5285
5286 /* initialize VALUE */
5287 result.v_subtype = V_NOSUBTYPE;
5288
5289 v1 = vals[0];
5290 v2 = vals[1];
5291 if (v1->v_type != V_ADDR)
5292 return error_value(E_MATFILL1);
5293 v1 = v1->v_addr;
5294 if (v1->v_subtype & V_NOCOPYTO)
5295 return error_value(E_MATFILL3);
5296 if (v1->v_type != V_MAT)
5297 return error_value(E_MATFILL2);
5298 if (v2->v_type == V_ADDR)
5299 v2 = v2->v_addr;
5300 if (v2->v_subtype & V_NOASSIGNFROM)
5301 return error_value(E_MATFILL4);
5302 if (count == 3) {
5303 v3 = vals[2];
5304 if (v3->v_type == V_ADDR)
5305 v3 = v3->v_addr;
5306 if (v3->v_subtype & V_NOASSIGNFROM)
5307 return error_value(E_MATFILL4);
5308 }
5309 else
5310 v3 = NULL;
5311 matfill(v1->v_mat, v2, v3);
5312 result.v_type = V_NULL;
5313 return result;
5314 }
5315
5316
5317 S_FUNC VALUE
f_matsum(VALUE * vp)5318 f_matsum(VALUE *vp)
5319 {
5320 VALUE result;
5321
5322 /* initialize VALUE */
5323 result.v_subtype = V_NOSUBTYPE;
5324
5325 /* firewall */
5326 if (vp->v_type != V_MAT)
5327 return error_value(E_MATSUM);
5328
5329 /* sum matrix */
5330 matsum(vp->v_mat, &result);
5331 return result;
5332 }
5333
5334
5335 S_FUNC VALUE
f_isident(VALUE * vp)5336 f_isident(VALUE *vp)
5337 {
5338 VALUE result;
5339
5340 /* initialize VALUEs */
5341 result.v_type = V_NUM;
5342 result.v_subtype = V_NOSUBTYPE;
5343
5344 if (vp->v_type == V_MAT) {
5345 result.v_num = itoq((long) matisident(vp->v_mat));
5346 } else {
5347 result.v_num = itoq(0);
5348 }
5349 return result;
5350 }
5351
5352
5353 S_FUNC VALUE
f_mattrace(VALUE * vp)5354 f_mattrace(VALUE *vp)
5355 {
5356 if (vp->v_type != V_MAT)
5357 return error_value(E_MATTRACE1);
5358 return mattrace(vp->v_mat);
5359 }
5360
5361
5362 S_FUNC VALUE
f_mattrans(VALUE * vp)5363 f_mattrans(VALUE *vp)
5364 {
5365 VALUE result;
5366
5367 /* initialize VALUE */
5368 result.v_subtype = V_NOSUBTYPE;
5369
5370 if (vp->v_type != V_MAT)
5371 return error_value(E_MATTRANS1);
5372 if (vp->v_mat->m_dim > 2)
5373 return error_value(E_MATTRANS2);
5374 result.v_type = V_MAT;
5375 result.v_mat = mattrans(vp->v_mat);
5376 return result;
5377 }
5378
5379
5380 S_FUNC VALUE
f_det(VALUE * vp)5381 f_det(VALUE *vp)
5382 {
5383 if (vp->v_type != V_MAT)
5384 return error_value(E_DET1);
5385
5386 return matdet(vp->v_mat);
5387 }
5388
5389
5390 S_FUNC VALUE
f_matdim(VALUE * vp)5391 f_matdim(VALUE *vp)
5392 {
5393 VALUE result;
5394
5395 /* initialize VALUEs */
5396 result.v_type = V_NUM;
5397 result.v_subtype = V_NOSUBTYPE;
5398
5399 switch(vp->v_type) {
5400 case V_OBJ:
5401 result.v_num = itoq(vp->v_obj->o_actions->oa_count);
5402 break;
5403 case V_MAT:
5404 result.v_num = itoq((long) vp->v_mat->m_dim);
5405 break;
5406 default:
5407 return error_value(E_MATDIM);
5408 }
5409 return result;
5410 }
5411
5412
5413 S_FUNC VALUE
f_matmin(VALUE * v1,VALUE * v2)5414 f_matmin(VALUE *v1, VALUE *v2)
5415 {
5416 VALUE result;
5417 NUMBER *q;
5418 long i;
5419
5420 /* initialize VALUE */
5421 result.v_subtype = V_NOSUBTYPE;
5422
5423 if (v1->v_type != V_MAT)
5424 return error_value(E_MATMIN1);
5425 if (v2->v_type != V_NUM)
5426 return error_value(E_MATMIN2);
5427 q = v2->v_num;
5428 if (qisfrac(q) || qisneg(q) || qiszero(q))
5429 return error_value(E_MATMIN2);
5430 i = qtoi(q);
5431 if (i > v1->v_mat->m_dim)
5432 return error_value(E_MATMIN3);
5433 result.v_type = V_NUM;
5434 result.v_num = itoq(v1->v_mat->m_min[i - 1]);
5435 return result;
5436 }
5437
5438
5439 S_FUNC VALUE
f_matmax(VALUE * v1,VALUE * v2)5440 f_matmax(VALUE *v1, VALUE *v2)
5441 {
5442 VALUE result;
5443 NUMBER *q;
5444 long i;
5445
5446 /* initialize VALUE */
5447 result.v_subtype = V_NOSUBTYPE;
5448
5449 if (v1->v_type != V_MAT)
5450 return error_value(E_MATMAX1);
5451 if (v2->v_type != V_NUM)
5452 return error_value(E_MATMAX2);
5453 q = v2->v_num;
5454 if (qisfrac(q) || qisneg(q) || qiszero(q))
5455 return error_value(E_MATMAX2);
5456 i = qtoi(q);
5457 if (i > v1->v_mat->m_dim)
5458 return error_value(E_MATMAX3);
5459 result.v_type = V_NUM;
5460 result.v_num = itoq(v1->v_mat->m_max[i - 1]);
5461 return result;
5462 }
5463
5464
5465 S_FUNC VALUE
f_cp(VALUE * v1,VALUE * v2)5466 f_cp(VALUE *v1, VALUE *v2)
5467 {
5468 MATRIX *m1, *m2;
5469 VALUE result;
5470
5471 /* initialize VALUE */
5472 result.v_subtype = V_NOSUBTYPE;
5473
5474 if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
5475 return error_value(E_CP1);
5476 m1 = v1->v_mat;
5477 m2 = v2->v_mat;
5478 if ((m1->m_dim != 1) || (m2->m_dim != 1))
5479 return error_value(E_CP2);
5480 if ((m1->m_size != 3) || (m2->m_size != 3))
5481 return error_value(E_CP3);
5482 result.v_type = V_MAT;
5483 result.v_mat = matcross(m1, m2);
5484 return result;
5485 }
5486
5487
5488 S_FUNC VALUE
f_dp(VALUE * v1,VALUE * v2)5489 f_dp(VALUE *v1, VALUE *v2)
5490 {
5491 MATRIX *m1, *m2;
5492
5493 if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
5494 return error_value(E_DP1);
5495 m1 = v1->v_mat;
5496 m2 = v2->v_mat;
5497 if ((m1->m_dim != 1) || (m2->m_dim != 1))
5498 return error_value(E_DP2);
5499 if (m1->m_size != m2->m_size)
5500 return error_value(E_DP3);
5501 return matdot(m1, m2);
5502 }
5503
5504
5505 S_FUNC VALUE
f_strlen(VALUE * vp)5506 f_strlen(VALUE *vp)
5507 {
5508 VALUE result;
5509 long len = 0;
5510 char *c;
5511
5512 /* initialize VALUE */
5513 result.v_subtype = V_NOSUBTYPE;
5514
5515 if (vp->v_type != V_STR)
5516 return error_value(E_STRLEN);
5517 c = vp->v_str->s_str;
5518 while (*c++)
5519 len++;
5520 result.v_type = V_NUM;
5521 result.v_num = itoq(len);
5522 return result;
5523 }
5524
5525
5526 S_FUNC VALUE
f_strcmp(VALUE * v1,VALUE * v2)5527 f_strcmp(VALUE *v1, VALUE *v2)
5528 {
5529 VALUE result;
5530 FLAG flag;
5531
5532 /* initialize VALUE */
5533 result.v_subtype = V_NOSUBTYPE;
5534
5535 if (v1->v_type != V_STR || v2->v_type != V_STR)
5536 return error_value(E_STRCMP);
5537
5538 flag = stringrel(v1->v_str, v2->v_str);
5539
5540 result.v_type = V_NUM;
5541 result.v_num = itoq((long) flag);
5542 return result;
5543 }
5544
5545 S_FUNC VALUE
f_strcasecmp(VALUE * v1,VALUE * v2)5546 f_strcasecmp(VALUE *v1, VALUE *v2)
5547 {
5548 VALUE result;
5549 FLAG flag;
5550
5551 /* initialize VALUE */
5552 result.v_subtype = V_NOSUBTYPE;
5553
5554 if (v1->v_type != V_STR || v2->v_type != V_STR)
5555 return error_value(E_STRCASECMP);
5556
5557 flag = stringcaserel(v1->v_str, v2->v_str);
5558
5559 result.v_type = V_NUM;
5560 result.v_num = itoq((long) flag);
5561 return result;
5562 }
5563
5564 S_FUNC VALUE
f_strncmp(VALUE * v1,VALUE * v2,VALUE * v3)5565 f_strncmp(VALUE *v1, VALUE *v2, VALUE *v3)
5566 {
5567 long n1, n2, n;
5568 FLAG flag;
5569 VALUE result;
5570
5571 /* initialize VALUE */
5572 result.v_subtype = V_NOSUBTYPE;
5573
5574 if (v1->v_type != V_STR || v2->v_type != V_STR ||
5575 v3->v_type != V_NUM || qisneg(v3->v_num) ||
5576 qisfrac(v3->v_num) || zge31b(v3->v_num->num))
5577 return error_value(E_STRNCMP);
5578 n1 = v1->v_str->s_len;
5579 n2 = v2->v_str->s_len;
5580 n = qtoi(v3->v_num);
5581 if (n < n1)
5582 v1->v_str->s_len = n;
5583 if (n < n2)
5584 v2->v_str->s_len = n;
5585
5586 flag = stringrel(v1->v_str, v2->v_str);
5587
5588 v1->v_str->s_len = n1;
5589 v2->v_str->s_len = n2;
5590
5591 result.v_type = V_NUM;
5592 result.v_num = itoq((long) flag);
5593 return result;
5594 }
5595 S_FUNC VALUE
f_strncasecmp(VALUE * v1,VALUE * v2,VALUE * v3)5596 f_strncasecmp(VALUE *v1, VALUE *v2, VALUE *v3)
5597 {
5598 long n1, n2, n;
5599 FLAG flag;
5600 VALUE result;
5601
5602 /* initialize VALUE */
5603 result.v_subtype = V_NOSUBTYPE;
5604
5605 if (v1->v_type != V_STR || v2->v_type != V_STR ||
5606 v3->v_type != V_NUM || qisneg(v3->v_num) ||
5607 qisfrac(v3->v_num) || zge31b(v3->v_num->num))
5608 return error_value(E_STRNCASECMP);
5609 n1 = v1->v_str->s_len;
5610 n2 = v2->v_str->s_len;
5611 n = qtoi(v3->v_num);
5612 if (n < n1)
5613 v1->v_str->s_len = n;
5614 if (n < n2)
5615 v2->v_str->s_len = n;
5616
5617 flag = stringcaserel(v1->v_str, v2->v_str);
5618
5619 v1->v_str->s_len = n1;
5620 v2->v_str->s_len = n2;
5621
5622 result.v_type = V_NUM;
5623 result.v_num = itoq((long) flag);
5624 return result;
5625 }
5626
5627 S_FUNC VALUE
f_strtoupper(VALUE * vp)5628 f_strtoupper(VALUE *vp)
5629 {
5630 VALUE result;
5631
5632 /* initialize VALUE */
5633 result.v_subtype = V_NOSUBTYPE;
5634
5635 if (vp->v_type != V_STR)
5636 return error_value(E_STRTOUPPER);
5637
5638 result.v_str = stringtoupper(vp->v_str);
5639 result.v_type = V_STR;
5640 return result;
5641 }
5642
5643 S_FUNC VALUE
f_strtolower(VALUE * vp)5644 f_strtolower(VALUE *vp)
5645 {
5646 VALUE result;
5647
5648 /* initialize VALUE */
5649 result.v_subtype = V_NOSUBTYPE;
5650
5651 if (vp->v_type != V_STR)
5652 return error_value(E_STRTOLOWER);
5653
5654 result.v_str = stringtolower(vp->v_str);
5655 result.v_type = V_STR;
5656 return result;
5657 }
5658
5659
5660 S_FUNC VALUE
f_strcat(int count,VALUE ** vals)5661 f_strcat(int count, VALUE **vals)
5662 {
5663 VALUE **vp;
5664 char *c, *c1;
5665 int i;
5666 long len;
5667 VALUE result;
5668
5669 /* initialize VALUE */
5670 result.v_subtype = V_NOSUBTYPE;
5671
5672 len = 0;
5673 result.v_type = V_STR;
5674 vp = vals;
5675 for (i = 0; i < count; i++, vp++) {
5676 if ((*vp)->v_type != V_STR)
5677 return error_value(E_STRCAT);
5678 c = (*vp)->v_str->s_str;
5679 while (*c++)
5680 len++;
5681 }
5682 if (len == 0) {
5683 result.v_str = slink(&_nullstring_);
5684 return result;
5685 }
5686 c = (char *) malloc(len + 1) ;
5687 if (c == NULL) {
5688 math_error("No memory for strcat");
5689 /*NOTREACHED*/
5690 }
5691 result.v_str = stralloc();
5692 result.v_str->s_str = c;
5693 result.v_str->s_len = len;
5694 for (vp = vals; count-- > 0; vp++) {
5695 c1 = (*vp)->v_str->s_str;
5696 while (*c1)
5697 *c++ = *c1++;
5698 }
5699 *c = '\0';
5700 return result;
5701 }
5702
5703
5704 S_FUNC VALUE
f_strcpy(VALUE * v1,VALUE * v2)5705 f_strcpy(VALUE *v1, VALUE *v2)
5706 {
5707 VALUE result;
5708
5709 /* initialize VALUE */
5710 result.v_subtype = V_NOSUBTYPE;
5711
5712 if (v1->v_type != V_STR || v2->v_type != V_STR)
5713 return error_value(E_STRCPY);
5714 result.v_str = stringcpy(v1->v_str, v2->v_str);
5715 result.v_type = V_STR;
5716 return result;
5717 }
5718
5719
5720 S_FUNC VALUE
f_strncpy(VALUE * v1,VALUE * v2,VALUE * v3)5721 f_strncpy(VALUE *v1, VALUE *v2, VALUE *v3)
5722 {
5723 VALUE result;
5724 long num;
5725
5726 /* initialize VALUE */
5727 result.v_subtype = V_NOSUBTYPE;
5728
5729 if (v1->v_type != V_STR || v2->v_type != V_STR ||
5730 v3->v_type != V_NUM || qisfrac(v3->v_num) || qisneg(v3->v_num))
5731 return error_value(E_STRNCPY);
5732 if (zge31b(v3->v_num->num))
5733 num = v2->v_str->s_len;
5734 else
5735 num = qtoi(v3->v_num);
5736 result.v_str = stringncpy(v1->v_str, v2->v_str, num);
5737 result.v_type = V_STR;
5738 return result;
5739 }
5740
5741
5742 S_FUNC VALUE
f_substr(VALUE * v1,VALUE * v2,VALUE * v3)5743 f_substr(VALUE *v1, VALUE *v2, VALUE *v3)
5744 {
5745 NUMBER *q1, *q2;
5746 size_t start, len;
5747 char *cp;
5748 char *ccp;
5749 VALUE result;
5750
5751 /* initialize VALUE */
5752 result.v_subtype = V_NOSUBTYPE;
5753
5754 if (v1->v_type != V_STR)
5755 return error_value(E_SUBSTR1);
5756 if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
5757 return error_value(E_SUBSTR2);
5758 q1 = v2->v_num;
5759 q2 = v3->v_num;
5760 if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
5761 return error_value(E_SUBSTR2);
5762 start = qtoi(q1);
5763 len = qtoi(q2);
5764 if (start > 0)
5765 start--;
5766 result.v_type = V_STR;
5767 if (start >= v1->v_str->s_len || len == 0) {
5768 result.v_str = slink(&_nullstring_);
5769 return result;
5770 }
5771 if (len > v1->v_str->s_len - start)
5772 len = v1->v_str->s_len - start;
5773 cp = v1->v_str->s_str + start;
5774 ccp = (char *) malloc(len + 1);
5775 if (ccp == NULL) {
5776 math_error("No memory for substr");
5777 /*NOTREACHED*/
5778 }
5779 result.v_str = stralloc();
5780 result.v_str->s_len = len;
5781 result.v_str->s_str = ccp;
5782 while (len-- > 0)
5783 *ccp++ = *cp++;
5784 *ccp = '\0';
5785 return result;
5786 }
5787
5788 S_FUNC VALUE
f_char(VALUE * vp)5789 f_char(VALUE *vp)
5790 {
5791 char ch;
5792 VALUE result;
5793
5794 /* initialize VALUE */
5795 result.v_subtype = V_NOSUBTYPE;
5796
5797 switch(vp->v_type) {
5798 case V_NUM:
5799 if (qisfrac(vp->v_num))
5800 return error_value(E_CHAR);
5801 ch = (char) vp->v_num->num.v[0];
5802 if (qisneg(vp->v_num))
5803 ch = -ch;
5804 break;
5805 case V_OCTET:
5806 ch = *vp->v_octet;
5807 break;
5808 case V_STR:
5809 ch = *vp->v_str->s_str;
5810 break;
5811 default:
5812 return error_value(E_CHAR);
5813 }
5814 result.v_type = V_STR;
5815 result.v_str = charstring(ch);
5816 return result;
5817 }
5818
5819
5820 S_FUNC VALUE
f_ord(VALUE * vp)5821 f_ord(VALUE *vp)
5822 {
5823 OCTET *c;
5824 VALUE result;
5825
5826 /* initialize VALUE */
5827 result.v_subtype = V_NOSUBTYPE;
5828
5829 switch(vp->v_type) {
5830 case V_STR:
5831 c = (OCTET *)vp->v_str->s_str;
5832 break;
5833 case V_OCTET:
5834 c = vp->v_octet;
5835 break;
5836 default:
5837 return error_value(E_ORD);
5838 }
5839
5840 result.v_type = V_NUM;
5841 result.v_num = itoq((long) (*c & 0xff));
5842 return result;
5843 }
5844
5845 S_FUNC VALUE
f_isupper(VALUE * vp)5846 f_isupper(VALUE *vp)
5847 {
5848 char c;
5849 VALUE result;
5850
5851 /* initialize VALUE */
5852 result.v_subtype = V_NOSUBTYPE;
5853
5854 switch(vp->v_type) {
5855 case V_STR:
5856 c = *vp->v_str->s_str;
5857 break;
5858 case V_OCTET:
5859 c = *vp->v_octet;
5860 break;
5861 default:
5862 return error_value(E_ISUPPER);
5863 }
5864
5865 result.v_type = V_NUM;
5866 result.v_num = itoq( (isupper( c ))?1l:0l);
5867 return result;
5868 }
5869
5870 S_FUNC VALUE
f_islower(VALUE * vp)5871 f_islower(VALUE *vp)
5872 {
5873 char c;
5874 VALUE result;
5875
5876 /* initialize VALUE */
5877 result.v_subtype = V_NOSUBTYPE;
5878
5879 switch(vp->v_type) {
5880 case V_STR:
5881 c = *vp->v_str->s_str;
5882 break;
5883 case V_OCTET:
5884 c = *vp->v_octet;
5885 break;
5886 default:
5887 return error_value(E_ISLOWER);
5888 }
5889
5890 result.v_type = V_NUM;
5891 result.v_num = itoq( (islower( c ))?1l:0l);
5892 return result;
5893 }
5894
5895 S_FUNC VALUE
f_isalnum(VALUE * vp)5896 f_isalnum(VALUE *vp)
5897 {
5898 char c;
5899 VALUE result;
5900
5901 /* initialize VALUE */
5902 result.v_subtype = V_NOSUBTYPE;
5903
5904 switch(vp->v_type) {
5905 case V_STR:
5906 c = *vp->v_str->s_str;
5907 break;
5908 case V_OCTET:
5909 c = *vp->v_octet;
5910 break;
5911 default:
5912 return error_value(E_ISALNUM);
5913 }
5914
5915 result.v_type = V_NUM;
5916 result.v_num = itoq( (isalnum( c ))?1l:0l);
5917 return result;
5918 }
5919
5920 S_FUNC VALUE
f_isalpha(VALUE * vp)5921 f_isalpha(VALUE *vp)
5922 {
5923 char c;
5924 VALUE result;
5925
5926 /* initialize VALUE */
5927 result.v_subtype = V_NOSUBTYPE;
5928
5929 switch(vp->v_type) {
5930 case V_STR:
5931 c = *vp->v_str->s_str;
5932 break;
5933 case V_OCTET:
5934 c = *vp->v_octet;
5935 break;
5936 default:
5937 return error_value(E_ISALPHA);
5938 }
5939
5940 result.v_type = V_NUM;
5941 result.v_num = itoq( (isalpha( c ))?1l:0l);
5942 return result;
5943 }
5944
5945 #if 0
5946 /* Not in C-standard, marked as obsolete in POSIX.1-2008 */
5947 S_FUNC VALUE
5948 f_isascii(VALUE *vp)
5949 {
5950 char c;
5951 VALUE result;
5952
5953 result.v_subtype = V_NOSUBTYPE;
5954
5955 switch(vp->v_type) {
5956 case V_STR:
5957 c = *vp->v_str->s_str;
5958 break;
5959 case V_OCTET:
5960 c = *vp->v_octet;
5961 break;
5962 default:
5963 return error_value(E_ISASCII);
5964 }
5965
5966 result.v_type = V_NUM;
5967 result.v_num = itoq( (isascii( c ))?1l:0l);
5968 return result;
5969 }
5970 #endif /* 0 */
5971
5972 S_FUNC VALUE
f_iscntrl(VALUE * vp)5973 f_iscntrl(VALUE *vp)
5974 {
5975 char c;
5976 VALUE result;
5977
5978 /* initialize VALUE */
5979 result.v_subtype = V_NOSUBTYPE;
5980
5981 switch(vp->v_type) {
5982 case V_STR:
5983 c = *vp->v_str->s_str;
5984 break;
5985 case V_OCTET:
5986 c = *vp->v_octet;
5987 break;
5988 default:
5989 return error_value(E_ISCNTRL);
5990 }
5991
5992 result.v_type = V_NUM;
5993 result.v_num = itoq( (iscntrl( c ))?1l:0l);
5994 return result;
5995 }
5996
5997 S_FUNC VALUE
f_isdigit(VALUE * vp)5998 f_isdigit(VALUE *vp)
5999 {
6000 char c;
6001 VALUE result;
6002
6003 /* initialize VALUE */
6004 result.v_subtype = V_NOSUBTYPE;
6005
6006 switch(vp->v_type) {
6007 case V_STR:
6008 c = *vp->v_str->s_str;
6009 break;
6010 case V_OCTET:
6011 c = *vp->v_octet;
6012 break;
6013 default:
6014 return error_value(E_ISDIGIT);
6015 }
6016
6017 result.v_type = V_NUM;
6018 result.v_num = itoq( (isdigit( c ))?1l:0l);
6019 return result;
6020 }
6021
6022 S_FUNC VALUE
f_isgraph(VALUE * vp)6023 f_isgraph(VALUE *vp)
6024 {
6025 char c;
6026 VALUE result;
6027
6028 /* initialize VALUE */
6029 result.v_subtype = V_NOSUBTYPE;
6030
6031 switch(vp->v_type) {
6032 case V_STR:
6033 c = *vp->v_str->s_str;
6034 break;
6035 case V_OCTET:
6036 c = *vp->v_octet;
6037 break;
6038 default:
6039 return error_value(E_ISGRAPH);
6040 }
6041
6042 result.v_type = V_NUM;
6043 result.v_num = itoq( (isgraph( c ))?1l:0l);
6044 return result;
6045 }
6046
6047 S_FUNC VALUE
f_isprint(VALUE * vp)6048 f_isprint(VALUE *vp)
6049 {
6050 char c;
6051 VALUE result;
6052
6053 /* initialize VALUE */
6054 result.v_subtype = V_NOSUBTYPE;
6055
6056 switch(vp->v_type) {
6057 case V_STR:
6058 c = *vp->v_str->s_str;
6059 break;
6060 case V_OCTET:
6061 c = *vp->v_octet;
6062 break;
6063 default:
6064 return error_value(E_ISPRINT);
6065 }
6066
6067 result.v_type = V_NUM;
6068 result.v_num = itoq( (isprint( c ))?1l:0l);
6069 return result;
6070 }
6071
6072 S_FUNC VALUE
f_ispunct(VALUE * vp)6073 f_ispunct(VALUE *vp)
6074 {
6075 char c;
6076 VALUE result;
6077
6078 /* initialize VALUE */
6079 result.v_subtype = V_NOSUBTYPE;
6080
6081 switch(vp->v_type) {
6082 case V_STR:
6083 c = *vp->v_str->s_str;
6084 break;
6085 case V_OCTET:
6086 c = *vp->v_octet;
6087 break;
6088 default:
6089 return error_value(E_ISPUNCT);
6090 }
6091
6092 result.v_type = V_NUM;
6093 result.v_num = itoq( (ispunct( c ))?1l:0l);
6094 return result;
6095 }
6096
6097 S_FUNC VALUE
f_isspace(VALUE * vp)6098 f_isspace(VALUE *vp)
6099 {
6100 char c;
6101 VALUE result;
6102
6103 /* initialize VALUE */
6104 result.v_subtype = V_NOSUBTYPE;
6105
6106 switch(vp->v_type) {
6107 case V_STR:
6108 c = *vp->v_str->s_str;
6109 break;
6110 case V_OCTET:
6111 c = *vp->v_octet;
6112 break;
6113 default:
6114 return error_value(E_ISSPACE);
6115 }
6116
6117 result.v_type = V_NUM;
6118 result.v_num = itoq( (isspace( c ))?1l:0l);
6119 return result;
6120 }
6121
6122 S_FUNC VALUE
f_isxdigit(VALUE * vp)6123 f_isxdigit(VALUE *vp)
6124 {
6125 char c;
6126 VALUE result;
6127
6128 /* initialize VALUE */
6129 result.v_subtype = V_NOSUBTYPE;
6130
6131 switch(vp->v_type) {
6132 case V_STR:
6133 c = *vp->v_str->s_str;
6134 break;
6135 case V_OCTET:
6136 c = *vp->v_octet;
6137 break;
6138 default:
6139 return error_value(E_ISXDIGIT);
6140 }
6141
6142 result.v_type = V_NUM;
6143 result.v_num = itoq( (isxdigit( c ))?1l:0l);
6144 return result;
6145 }
6146
6147 S_FUNC VALUE
f_protect(int count,VALUE ** vals)6148 f_protect(int count, VALUE **vals)
6149 {
6150 int i, depth;
6151 VALUE *v1, *v2, *v3;
6152
6153 VALUE result;
6154 BOOL have_nblock;
6155
6156 /* initialize VALUE */
6157 result.v_type = V_NULL;
6158 result.v_subtype = V_NOSUBTYPE;
6159
6160 v1 = vals[0];
6161 have_nblock = (v1->v_type == V_NBLOCK);
6162 if (!have_nblock) {
6163 if (v1->v_type != V_ADDR)
6164 return error_value(E_PROTECT1);
6165 v1 = v1->v_addr;
6166 }
6167 if (count == 1) {
6168 result.v_type = V_NUM;
6169 if (have_nblock)
6170 result.v_num = itoq(v1->v_nblock->subtype);
6171 else
6172 result.v_num = itoq(v1->v_subtype);
6173 return result;
6174 }
6175 v2 = vals[1];
6176 if (v2->v_type == V_ADDR)
6177 v2 = v2->v_addr;
6178 if (v2->v_type != V_NUM||qisfrac(v2->v_num)||zge16b(v2->v_num->num))
6179 return error_value(E_PROTECT2);
6180 i = qtoi(v2->v_num);
6181 depth = 0;
6182 if (count > 2) {
6183 v3 = vals[2];
6184 if (v3->v_type == V_ADDR)
6185 v3 = v3->v_addr;
6186 if (v3->v_type != V_NUM || qisfrac(v3->v_num) ||
6187 qisneg(v3->v_num) || zge31b(v3->v_num->num))
6188 return error_value(E_PROTECT3);
6189 depth = qtoi(v3->v_num);
6190 }
6191 protecttodepth(v1, i, depth);
6192 return result;
6193 }
6194
6195
6196 S_FUNC VALUE
f_size(VALUE * vp)6197 f_size(VALUE *vp)
6198 {
6199 VALUE result;
6200
6201 /* initialize VALUE */
6202 result.v_subtype = V_NOSUBTYPE;
6203
6204 /*
6205 * return information about the number of elements
6206 *
6207 * This is not the sizeof, see f_sizeof() for that information.
6208 * This is not the memsize, see f_memsize() for that information.
6209 *
6210 * The size of a file is treated in a special way ... we do
6211 * not use the number of elements, but rather the length
6212 * of the file as would be reported by fsize().
6213 */
6214 if (vp->v_type == V_FILE) {
6215 return f_fsize(vp);
6216 } else {
6217 result.v_type = V_NUM;
6218 result.v_num = itoq(elm_count(vp));
6219 }
6220 return result;
6221 }
6222
6223
6224 S_FUNC VALUE
f_sizeof(VALUE * vp)6225 f_sizeof(VALUE *vp)
6226 {
6227 VALUE result;
6228
6229 /* initialize VALUE */
6230 result.v_type = V_NUM;
6231 result.v_subtype = V_NOSUBTYPE;
6232
6233 /*
6234 * return information about memory footprint
6235 *
6236 * This is not the number of elements, see f_size() for that info.
6237 * This is not the memsize, see f_memsize() for that information.
6238 */
6239 result.v_num = itoq(lsizeof(vp));
6240 return result;
6241 }
6242
6243
6244 S_FUNC VALUE
f_memsize(VALUE * vp)6245 f_memsize(VALUE *vp)
6246 {
6247 VALUE result;
6248
6249 /* initialize VALUE */
6250 result.v_type = V_NUM;
6251 result.v_subtype = V_NOSUBTYPE;
6252
6253 /*
6254 * return information about memory footprint
6255 *
6256 * This is not the number of elements, see f_size() for that info.
6257 * This is not the sizeof, see f_sizeof() for that information.
6258 */
6259 result.v_num = itoq(memsize(vp));
6260 return result;
6261 }
6262
6263
6264 S_FUNC VALUE
f_search(int count,VALUE ** vals)6265 f_search(int count, VALUE **vals)
6266 {
6267 VALUE *v1, *v2, *v3, *v4;
6268 NUMBER *start, *end;
6269 VALUE vsize;
6270 NUMBER *size;
6271 ZVALUE pos;
6272 ZVALUE indx;
6273 long len;
6274 ZVALUE zlen, tmp;
6275 VALUE result;
6276 long l_start = 0, l_end = 0;
6277 int i = 0;
6278
6279 /* initialize VALUEs */
6280 result.v_subtype = V_NOSUBTYPE;
6281 vsize.v_subtype = V_NOSUBTYPE;
6282
6283 v1 = *vals++;
6284 v2 = *vals++;
6285 if ((v1->v_type == V_FILE || v1->v_type == V_STR) &&
6286 v2->v_type != V_STR)
6287 return error_value(E_SEARCH2);
6288 start = end = NULL;
6289 if (count > 2) {
6290 v3 = *vals++;
6291 if (v3->v_type != V_NUM && v3->v_type != V_NULL)
6292 return error_value(E_SEARCH3);
6293 if (v3->v_type == V_NUM) {
6294 start = v3->v_num;
6295 if (qisfrac(start))
6296 return error_value(E_SEARCH3);
6297 }
6298 }
6299 if (count > 3) {
6300 v4 = *vals;
6301 if (v4->v_type != V_NUM && v4->v_type != V_NULL)
6302 return error_value(E_SEARCH4);
6303 if (v4->v_type == V_NUM) {
6304 end = v4->v_num;
6305 if (qisfrac(end))
6306 return error_value(E_SEARCH4);
6307 }
6308 }
6309 result.v_type = V_NULL;
6310 vsize = f_size(v1);
6311 if (vsize.v_type != V_NUM)
6312 return error_value(E_SEARCH5);
6313 size = vsize.v_num;
6314 if (start) {
6315 if (qisneg(start)) {
6316 start = qqadd(size, start);
6317 if (qisneg(start)) {
6318 qfree(start);
6319 start = qlink(&_qzero_);
6320 }
6321 } else {
6322 start = qlink(start);
6323 }
6324 }
6325 if (end) {
6326 if (!qispos(end)) {
6327 end = qqadd(size, end);
6328 } else {
6329 if (qrel(end, size) > 0)
6330 end = qlink(size);
6331 else
6332 end = qlink(end);
6333 }
6334 }
6335 if (v1->v_type == V_FILE) {
6336 if (count == 2|| (count == 4 &&
6337 (start == NULL || end == NULL))) {
6338 i = ftellid(v1->v_file, &pos);
6339 if (i < 0) {
6340 qfree(size);
6341 if (start)
6342 qfree(start);
6343 if (end)
6344 qfree(end);
6345 return error_value(E_SEARCH5);
6346 }
6347 if (count == 2 || (count == 4 && end != NULL)) {
6348 start = qalloc();
6349 start->num = pos;
6350 } else {
6351 end = qalloc();
6352 end->num = pos;
6353 }
6354 }
6355 if (start == NULL)
6356 start = qlink(&_qzero_);
6357 if (end == NULL)
6358 end = size;
6359 else
6360 qfree(size);
6361 len = v2->v_str->s_len;
6362 utoz(len, &zlen);
6363 zsub(end->num, zlen, &tmp);
6364 zfree(zlen);
6365 i = fsearch(v1->v_file, v2->v_str->s_str,
6366 start->num, tmp, &indx);
6367 zfree(tmp);
6368 if (i == 2) {
6369 result.v_type = V_NUM;
6370 result.v_num = start;
6371 qfree(end);
6372 return result;
6373 }
6374 qfree(start);
6375 qfree(end);
6376 if (i == EOF)
6377 return error_value(errno);
6378 if (i < 0)
6379 return error_value(E_SEARCH6);
6380 if (i == 0) {
6381 result.v_type = V_NUM;
6382 result.v_num = qalloc();
6383 result.v_num->num = indx;
6384 }
6385 return result;
6386 }
6387 if (start == NULL)
6388 start = qlink(&_qzero_);
6389 if (end == NULL)
6390 end = qlink(size);
6391 if (qrel(start, end) >= 0) {
6392 qfree(size);
6393 qfree(start);
6394 qfree(end);
6395 return result;
6396 }
6397 qfree(size);
6398 l_start = ztolong(start->num);
6399 l_end = ztolong(end->num);
6400 switch (v1->v_type) {
6401 case V_MAT:
6402 i = matsearch(v1->v_mat, v2, l_start, l_end, &indx);
6403 break;
6404 case V_LIST:
6405 i = listsearch(v1->v_list, v2, l_start, l_end, &indx);
6406 break;
6407 case V_ASSOC:
6408 i = assocsearch(v1->v_assoc, v2, l_start, l_end, &indx);
6409 break;
6410 case V_STR:
6411 i = stringsearch(v1->v_str, v2->v_str, l_start, l_end,
6412 &indx);
6413 break;
6414 default:
6415 qfree(start);
6416 qfree(end);
6417 return error_value(E_SEARCH1);
6418 }
6419 qfree(start);
6420 qfree(end);
6421 if (i == 0) {
6422 result.v_type = V_NUM;
6423 result.v_num = qalloc();
6424 result.v_num->num = indx;
6425 }
6426 return result;
6427 }
6428
6429
6430 S_FUNC VALUE
f_rsearch(int count,VALUE ** vals)6431 f_rsearch(int count, VALUE **vals)
6432 {
6433 VALUE *v1, *v2, *v3, *v4;
6434 NUMBER *start, *end;
6435 VALUE vsize;
6436 NUMBER *size;
6437 NUMBER *qlen;
6438 NUMBER *qtmp;
6439 ZVALUE pos;
6440 ZVALUE indx;
6441 VALUE result;
6442 long l_start = 0, l_end = 0;
6443 int i;
6444
6445 /* initialize VALUEs */
6446 vsize.v_subtype = V_NOSUBTYPE;
6447 result.v_subtype = V_NOSUBTYPE;
6448
6449 v1 = *vals++;
6450 v2 = *vals++;
6451 if ((v1->v_type == V_FILE || v1->v_type == V_STR) &&
6452 v2->v_type != V_STR)
6453 return error_value(E_RSEARCH2);
6454 start = end = NULL;
6455 if (count > 2) {
6456 v3 = *vals++;
6457 if (v3->v_type != V_NUM && v3->v_type != V_NULL)
6458 return error_value(E_RSEARCH3);
6459 if (v3->v_type == V_NUM) {
6460 start = v3->v_num;
6461 if (qisfrac(start))
6462 return error_value(E_RSEARCH3);
6463 }
6464 }
6465 if (count > 3) {
6466 v4 = *vals;
6467 if (v4->v_type != V_NUM && v4->v_type != V_NULL)
6468 return error_value(E_RSEARCH4);
6469 if (v4->v_type == V_NUM) {
6470 end = v4->v_num;
6471 if (qisfrac(end))
6472 return error_value(E_RSEARCH3);
6473 }
6474 }
6475 result.v_type = V_NULL;
6476 vsize = f_size(v1);
6477 if (vsize.v_type != V_NUM)
6478 return error_value(E_RSEARCH5);
6479 size = vsize.v_num;
6480 if (start) {
6481 if (qisneg(start)) {
6482 start = qqadd(size, start);
6483 if (qisneg(start)) {
6484 qfree(start);
6485 start = qlink(&_qzero_);
6486 }
6487 }
6488 else
6489 start = qlink(start);
6490 }
6491 if (end) {
6492 if (!qispos(end)) {
6493 end = qqadd(size, end);
6494 } else {
6495 if (qrel(end, size) > 0)
6496 end = qlink(size);
6497 else
6498 end = qlink(end);
6499 }
6500 }
6501 if (v1->v_type == V_FILE) {
6502 if (count == 2 || (count == 4 &&
6503 (start == NULL || end == NULL))) {
6504 i = ftellid(v1->v_file, &pos);
6505 if (i < 0) {
6506 qfree(size);
6507 if (start)
6508 qfree(start);
6509 if (end)
6510 qfree(end);
6511 return error_value(E_RSEARCH5);
6512 }
6513 if (count == 2 || (count == 4 && end != NULL)) {
6514 start = qalloc();
6515 start->num = pos;
6516 } else {
6517 end = qalloc();
6518 end->num = pos;
6519 }
6520 }
6521 qlen = utoq(v2->v_str->s_len);
6522 qtmp = qsub(size, qlen);
6523 qfree(size);
6524 size = qtmp;
6525 if (count < 4) {
6526 end = start;
6527 start = NULL;
6528 } else {
6529 qtmp = qsub(end, qlen);
6530 qfree(end);
6531 end = qtmp;
6532 }
6533 if (end == NULL)
6534 end = qlink(size);
6535 if (start == NULL)
6536 start = qlink(&_qzero_);
6537 if (qrel(end, size) > 0) {
6538 qfree(end);
6539 end = qlink(size);
6540 }
6541 qfree(qlen);
6542 qfree(size);
6543 if (qrel(start, end) > 0) {
6544 qfree(start);
6545 qfree(end);
6546 return result;
6547 }
6548 i = frsearch(v1->v_file, v2->v_str->s_str,
6549 end->num,start->num, &indx);
6550 qfree(start);
6551 qfree(end);
6552 if (i == EOF)
6553 return error_value(errno);
6554 if (i < 0)
6555 return error_value(E_RSEARCH6);
6556 if (i == 0) {
6557 result.v_type = V_NUM;
6558 result.v_num = qalloc();
6559 result.v_num->num = indx;
6560 }
6561 return result;
6562 }
6563 if (count < 4) {
6564 if (start) {
6565 end = qinc(start);
6566 qfree(start);
6567 }
6568 else
6569 end = qlink(size);
6570 start = qlink(&_qzero_);
6571 } else {
6572 if (start == NULL)
6573 start = qlink(&_qzero_);
6574 if (end == NULL)
6575 end = qlink(size);
6576 }
6577
6578 qfree(size);
6579 if (qrel(start, end) >= 0) {
6580 qfree(start);
6581 qfree(end);
6582 return result;
6583 }
6584 l_start = ztolong(start->num);
6585 l_end = ztolong(end->num);
6586 switch (v1->v_type) {
6587 case V_MAT:
6588 i = matrsearch(v1->v_mat, v2, l_start, l_end, &indx);
6589 break;
6590 case V_LIST:
6591 i = listrsearch(v1->v_list, v2, l_start, l_end, &indx);
6592 break;
6593 case V_ASSOC:
6594 i = assocrsearch(v1->v_assoc, v2, l_start,
6595 l_end, &indx);
6596 break;
6597 case V_STR:
6598 i = stringrsearch(v1->v_str, v2->v_str, l_start,
6599 l_end, &indx);
6600 break;
6601 default:
6602 qfree(start);
6603 qfree(end);
6604 return error_value(E_RSEARCH1);
6605 }
6606 qfree(start);
6607 qfree(end);
6608 if (i == 0) {
6609 result.v_type = V_NUM;
6610 result.v_num = qalloc();
6611 result.v_num->num = indx;
6612 }
6613 return result;
6614 }
6615
6616
6617 S_FUNC VALUE
f_list(int count,VALUE ** vals)6618 f_list(int count, VALUE **vals)
6619 {
6620 VALUE result;
6621
6622 /* initialize VALUE */
6623 result.v_type = V_LIST;
6624 result.v_subtype = V_NOSUBTYPE;
6625
6626 result.v_list = listalloc();
6627 while (count-- > 0)
6628 insertlistlast(result.v_list, *vals++);
6629 return result;
6630 }
6631
6632
6633 /*ARGSUSED*/
6634 S_FUNC VALUE
f_assoc(int UNUSED (count),VALUE ** UNUSED (vals))6635 f_assoc(int UNUSED(count), VALUE **UNUSED(vals))
6636 {
6637 VALUE result;
6638
6639 /* initialize VALUE */
6640 result.v_type = V_ASSOC;
6641 result.v_subtype = V_NOSUBTYPE;
6642
6643 result.v_assoc = assocalloc(0L);
6644 return result;
6645 }
6646
6647
6648 S_FUNC VALUE
f_indices(VALUE * v1,VALUE * v2)6649 f_indices(VALUE *v1, VALUE *v2)
6650 {
6651 VALUE result;
6652 LIST *lp;
6653
6654 if (v2->v_type != V_NUM || zge31b(v2->v_num->num))
6655 return error_value(E_INDICES2);
6656
6657 switch (v1->v_type) {
6658 case V_ASSOC:
6659 lp = associndices(v1->v_assoc, qtoi(v2->v_num));
6660 break;
6661 case V_MAT:
6662 lp = matindices(v1->v_mat, qtoi(v2->v_num));
6663 break;
6664 default:
6665 return error_value(E_INDICES1);
6666 }
6667
6668 result.v_type = V_NULL;
6669 result.v_subtype = V_NOSUBTYPE;
6670 if (lp) {
6671 result.v_type = V_LIST;
6672 result.v_list = lp;
6673 }
6674 return result;
6675 }
6676
6677
6678 S_FUNC VALUE
f_listinsert(int count,VALUE ** vals)6679 f_listinsert(int count, VALUE **vals)
6680 {
6681 VALUE *v1, *v2, *v3;
6682 VALUE result;
6683 long pos;
6684
6685 /* initialize VALUE */
6686 result.v_subtype = V_NOSUBTYPE;
6687
6688 v1 = *vals++;
6689 if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
6690 return error_value(E_INSERT1);
6691 if (v1->v_addr->v_subtype & V_NOREALLOC)
6692 return error_value(E_LIST1);
6693
6694 v2 = *vals++;
6695 if (v2->v_type == V_ADDR)
6696 v2 = v2->v_addr;
6697 if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
6698 return error_value(E_INSERT2);
6699 pos = qtoi(v2->v_num);
6700 count--;
6701 while (--count > 0) {
6702 v3 = *vals++;
6703 if (v3->v_type == V_ADDR)
6704 v3 = v3->v_addr;
6705 insertlistmiddle(v1->v_addr->v_list, pos++, v3);
6706 }
6707 result.v_type = V_NULL;
6708 return result;
6709 }
6710
6711
6712 S_FUNC VALUE
f_listpush(int count,VALUE ** vals)6713 f_listpush(int count, VALUE **vals)
6714 {
6715 VALUE result;
6716 VALUE *v1, *v2;
6717
6718 /* initialize VALUE */
6719 result.v_subtype = V_NOSUBTYPE;
6720
6721 v1 = *vals++;
6722 if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
6723 return error_value(E_PUSH);
6724 if (v1->v_addr->v_subtype & V_NOREALLOC)
6725 return error_value(E_LIST3);
6726
6727 while (--count > 0) {
6728 v2 = *vals++;
6729 if (v2->v_type == V_ADDR)
6730 v2 = v2->v_addr;
6731 insertlistfirst(v1->v_addr->v_list, v2);
6732 }
6733 result.v_type = V_NULL;
6734 return result;
6735 }
6736
6737
6738 S_FUNC VALUE
f_listappend(int count,VALUE ** vals)6739 f_listappend(int count, VALUE **vals)
6740 {
6741 VALUE *v1, *v2;
6742 VALUE result;
6743
6744 /* initialize VALUE */
6745 result.v_subtype = V_NOSUBTYPE;
6746
6747 v1 = *vals++;
6748 if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
6749 return error_value(E_APPEND);
6750 if (v1->v_addr->v_subtype & V_NOREALLOC)
6751 return error_value(E_LIST4);
6752
6753 while (--count > 0) {
6754 v2 = *vals++;
6755 if (v2->v_type == V_ADDR)
6756 v2 = v2->v_addr;
6757 insertlistlast(v1->v_addr->v_list, v2);
6758 }
6759 result.v_type = V_NULL;
6760 return result;
6761 }
6762
6763
6764 S_FUNC VALUE
f_listdelete(VALUE * v1,VALUE * v2)6765 f_listdelete(VALUE *v1, VALUE *v2)
6766 {
6767 VALUE result;
6768
6769 /* initialize VALUE */
6770 result.v_subtype = V_NOSUBTYPE;
6771
6772 if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
6773 return error_value(E_DELETE1);
6774 if (v1->v_addr->v_subtype & V_NOREALLOC)
6775 return error_value(E_LIST2);
6776
6777 if (v2->v_type == V_ADDR)
6778 v2 = v2->v_addr;
6779 if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
6780 return error_value(E_DELETE2);
6781 removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result);
6782 return result;
6783 }
6784
6785
6786 S_FUNC VALUE
f_listpop(VALUE * vp)6787 f_listpop(VALUE *vp)
6788 {
6789 VALUE result;
6790
6791 if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
6792 return error_value(E_POP);
6793
6794 if (vp->v_addr->v_subtype & V_NOREALLOC)
6795 return error_value(E_LIST5);
6796
6797 removelistfirst(vp->v_addr->v_list, &result);
6798 return result;
6799 }
6800
6801
6802 S_FUNC VALUE
f_listremove(VALUE * vp)6803 f_listremove(VALUE *vp)
6804 {
6805 VALUE result;
6806
6807 if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
6808 return error_value(E_REMOVE);
6809
6810 if (vp->v_addr->v_subtype & V_NOREALLOC)
6811 return error_value(E_LIST6);
6812
6813 removelistlast(vp->v_addr->v_list, &result);
6814 return result;
6815 }
6816
6817
6818 /*
6819 * Return the current user time of calc in seconds.
6820 */
6821 S_FUNC NUMBER *
f_usertime(void)6822 f_usertime(void)
6823 {
6824 #if defined(HAVE_GETRUSAGE)
6825 struct rusage usage; /* system resource usage */
6826 int who = RUSAGE_SELF; /* obtain time for just this process */
6827 int status; /* getrusage() return code */
6828 NUMBER *ret; /* CPU time to return */
6829 NUMBER *secret; /* whole seconds of CPU time to return */
6830 NUMBER *usecret; /* microseconds of CPU time to return */
6831
6832 /* get the resource information for ourself */
6833 status = getrusage(who, &usage);
6834 if (status < 0) {
6835 /* system call error, so return 0 */
6836 return qlink(&_qzero_);
6837 }
6838
6839 /* add user time */
6840 secret = stoq(usage.ru_utime.tv_sec);
6841 usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L);
6842 ret = qqadd(secret, usecret);
6843 qfree(secret);
6844 qfree(usecret);
6845
6846 /* return user CPU time */
6847 return ret;
6848
6849 #else /* HAVE_GETRUSAGE */
6850 /* not a POSIX system */
6851 return qlink(&_qzero_);
6852 #endif /* HAVE_GETRUSAGE */
6853 }
6854
6855
6856 /*
6857 * Return the current kernel time of calc in seconds.
6858 * This is the kernel mode time only.
6859 */
6860 S_FUNC NUMBER *
f_systime(void)6861 f_systime(void)
6862 {
6863 #if defined(HAVE_GETRUSAGE)
6864 struct rusage usage; /* system resource usage */
6865 int who = RUSAGE_SELF; /* obtain time for just this process */
6866 int status; /* getrusage() return code */
6867 NUMBER *ret; /* CPU time to return */
6868 NUMBER *secret; /* whole seconds of CPU time to return */
6869 NUMBER *usecret; /* microseconds of CPU time to return */
6870
6871 /* get the resource information for ourself */
6872 status = getrusage(who, &usage);
6873 if (status < 0) {
6874 /* system call error, so return 0 */
6875 return qlink(&_qzero_);
6876 }
6877
6878 /* add kernel time */
6879 secret = stoq(usage.ru_stime.tv_sec);
6880 usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L);
6881 ret = qqadd(secret, usecret);
6882 qfree(secret);
6883 qfree(usecret);
6884
6885 /* return kernel CPU time */
6886 return ret;
6887
6888 #else /* HAVE_GETRUSAGE */
6889 /* not a POSIX system */
6890 return qlink(&_qzero_);
6891 #endif /* HAVE_GETRUSAGE */
6892 }
6893
6894
6895 /*
6896 * Return the current user and kernel time of calc in seconds.
6897 */
6898 S_FUNC NUMBER *
f_runtime(void)6899 f_runtime(void)
6900 {
6901 #if defined(HAVE_GETRUSAGE)
6902 struct rusage usage; /* system resource usage */
6903 int who = RUSAGE_SELF; /* obtain time for just this process */
6904 int status; /* getrusage() return code */
6905 NUMBER *user; /* user CPU time to return */
6906 NUMBER *sys; /* kernel CPU time to return */
6907 NUMBER *ret; /* total CPU time to return */
6908 NUMBER *secret; /* whole seconds of CPU time to return */
6909 NUMBER *usecret; /* microseconds of CPU time to return */
6910
6911 /* get the resource information for ourself */
6912 status = getrusage(who, &usage);
6913 if (status < 0) {
6914 /* system call error, so return 0 */
6915 return qlink(&_qzero_);
6916 }
6917
6918 /* add kernel time */
6919 secret = stoq(usage.ru_stime.tv_sec);
6920 usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L);
6921 sys = qqadd(secret, usecret);
6922 qfree(secret);
6923 qfree(usecret);
6924
6925 /* add user time */
6926 secret = stoq(usage.ru_utime.tv_sec);
6927 usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L);
6928 user = qqadd(secret, usecret);
6929 qfree(secret);
6930 qfree(usecret);
6931
6932 /* total time is user + kernel */
6933 ret = qqadd(user, sys);
6934 qfree(user);
6935 qfree(sys);
6936
6937 /* return CPU time */
6938 return ret;
6939
6940 #else /* HAVE_GETRUSAGE */
6941 /* not a POSIX system */
6942 return qlink(&_qzero_);
6943 #endif /* HAVE_GETRUSAGE */
6944 }
6945
6946
6947 /*
6948 * return the number of second since the Epoch (00:00:00 1 Jan 1970 UTC).
6949 */
6950 S_FUNC NUMBER *
f_time(void)6951 f_time(void)
6952 {
6953 return itoq((long) time(0));
6954 }
6955
6956
6957 /*
6958 * time in asctime()/ctime() format
6959 */
6960 S_FUNC VALUE
f_ctime(void)6961 f_ctime(void)
6962 {
6963 VALUE res;
6964 time_t now; /* the current time */
6965
6966 /* initialize VALUE */
6967 res.v_subtype = V_NOSUBTYPE;
6968 res.v_type = V_STR;
6969
6970 /* get the time */
6971 now = time(NULL);
6972 res.v_str = makenewstring(ctime(&now));
6973 return res;
6974 }
6975
6976
6977 S_FUNC VALUE
f_fopen(VALUE * v1,VALUE * v2)6978 f_fopen(VALUE *v1, VALUE *v2)
6979 {
6980 VALUE result;
6981 FILEID id;
6982 char *mode;
6983
6984 /* initialize VALUE */
6985 result.v_subtype = V_NOSUBTYPE;
6986
6987 /* check for a valid mode [rwa][b+\0][b+\0] */
6988 if (v1->v_type != V_STR || v2->v_type != V_STR)
6989 return error_value(E_FOPEN1);
6990 mode = v2->v_str->s_str;
6991 if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
6992 return error_value(E_FOPEN2);
6993 if (mode[1] != '\0') {
6994 if (mode[1] != '+' && mode[1] != 'b')
6995 return error_value(E_FOPEN2);
6996 if (mode[2] != '\0') {
6997 if ((mode[2] != '+' && mode[2] != 'b') ||
6998 mode[1] == mode[2])
6999 return error_value(E_FOPEN2);
7000 if (mode[3] != '\0')
7001 return error_value(E_FOPEN2);
7002 }
7003 }
7004
7005 /* try to open */
7006 errno = 0;
7007 id = openid(v1->v_str->s_str, v2->v_str->s_str);
7008 if (id == FILEID_NONE)
7009 return error_value(errno);
7010 if (id < 0)
7011 return error_value(-id);
7012 result.v_type = V_FILE;
7013 result.v_file = id;
7014 return result;
7015 }
7016
7017
7018 S_FUNC VALUE
f_fpathopen(int count,VALUE ** vals)7019 f_fpathopen(int count, VALUE **vals)
7020 {
7021 VALUE result;
7022 FILEID id;
7023 char *mode;
7024
7025 /* initialize VALUE */
7026 result.v_subtype = V_NOSUBTYPE;
7027
7028 /* check for valid strong */
7029 if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) {
7030 return error_value(E_FPATHOPEN1);
7031 }
7032 if (count == 3 && vals[2]->v_type != V_STR) {
7033 return error_value(E_FPATHOPEN1);
7034 }
7035
7036 /* check for a valid mode [rwa][b+\0][b+\0] */
7037 mode = vals[1]->v_str->s_str;
7038 if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
7039 return error_value(E_FPATHOPEN2);
7040 if (mode[1] != '\0') {
7041 if (mode[1] != '+' && mode[1] != 'b')
7042 return error_value(E_FPATHOPEN2);
7043 if (mode[2] != '\0') {
7044 if ((mode[2] != '+' && mode[2] != 'b') ||
7045 mode[1] == mode[2])
7046 return error_value(E_FPATHOPEN2);
7047 if (mode[3] != '\0')
7048 return error_value(E_FPATHOPEN2);
7049 }
7050 }
7051
7052 /* try to open along a path */
7053 errno = 0;
7054 if (count == 2) {
7055 id = openpathid(vals[0]->v_str->s_str,
7056 vals[1]->v_str->s_str,
7057 calcpath);
7058 } else {
7059 id = openpathid(vals[0]->v_str->s_str,
7060 vals[1]->v_str->s_str,
7061 vals[2]->v_str->s_str);
7062 }
7063 if (id == FILEID_NONE)
7064 return error_value(errno);
7065 if (id < 0)
7066 return error_value(-id);
7067 result.v_type = V_FILE;
7068 result.v_file = id;
7069 return result;
7070 }
7071
7072
7073 S_FUNC VALUE
f_freopen(int count,VALUE ** vals)7074 f_freopen(int count, VALUE **vals)
7075 {
7076 VALUE result;
7077 FILEID id;
7078 char *mode;
7079
7080 /* initialize VALUE */
7081 result.v_subtype = V_NOSUBTYPE;
7082
7083 /* check for a valid mode [rwa][b+\0][b+\0] */
7084 if (vals[0]->v_type != V_FILE)
7085 return error_value(E_FREOPEN1);
7086 if (vals[1]->v_type != V_STR)
7087 return error_value(E_FREOPEN2);
7088 mode = vals[1]->v_str->s_str;
7089 if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a'))
7090 return error_value(E_FREOPEN2);
7091 if (mode[1] != '\0') {
7092 if (mode[1] != '+' && mode[1] != 'b')
7093 return error_value(E_FREOPEN2);
7094 if (mode[2] != '\0') {
7095 if ((mode[2] != '+' && mode[2] != 'b') ||
7096 mode[1] == mode[2])
7097 return error_value(E_FOPEN2);
7098 if (mode[3] != '\0')
7099 return error_value(E_FREOPEN2);
7100 }
7101 }
7102
7103 /* try to reopen */
7104 errno = 0;
7105 if (count == 2) {
7106 id = reopenid(vals[0]->v_file, mode, NULL);
7107 } else {
7108 if (vals[2]->v_type != V_STR)
7109 return error_value(E_FREOPEN3);
7110 id = reopenid(vals[0]->v_file, mode,
7111 vals[2]->v_str->s_str);
7112 }
7113
7114 if (id == FILEID_NONE)
7115 return error_value(errno);
7116 result.v_type = V_NULL;
7117 return result;
7118 }
7119
7120
7121 S_FUNC VALUE
f_errno(int count,VALUE ** vals)7122 f_errno(int count, VALUE **vals)
7123 {
7124 int newerr, olderr;
7125 VALUE *vp;
7126 VALUE result;
7127
7128 /* initialize VALUE */
7129 result.v_type = V_NUM;
7130 result.v_subtype = V_NOSUBTYPE;
7131
7132 newerr = -1;
7133 if (count > 0) {
7134 vp = vals[0];
7135
7136 if (vp->v_type <= 0) {
7137 newerr = (int) -vp->v_type;
7138 (void) set_errno(newerr);
7139 result.v_num = itoq((long) newerr);
7140 return result;
7141 }
7142
7143 /* arg must be an integer */
7144 if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
7145 qisneg(vp->v_num) || zge16b(vp->v_num->num)) {
7146 math_error("errno argument out of range");
7147 /*NOTREACHED*/
7148 }
7149 newerr = (int) ztoi(vp->v_num->num);
7150 }
7151 olderr = set_errno(newerr);
7152
7153 result.v_num = itoq((long) olderr);
7154 return result;
7155 }
7156
7157
7158
7159 S_FUNC VALUE
f_errcount(int count,VALUE ** vals)7160 f_errcount(int count, VALUE **vals)
7161 {
7162 int newcount, oldcount;
7163 VALUE *vp;
7164 VALUE result;
7165
7166 /* initialize VALUE */
7167 result.v_subtype = V_NOSUBTYPE;
7168
7169 newcount = -1;
7170 if (count > 0) {
7171 vp = vals[0];
7172
7173 /* arg must be an integer */
7174 if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
7175 qisneg(vp->v_num) || zge31b(vp->v_num->num)) {
7176 math_error("errcount argument out of range");
7177 /*NOTREACHED*/
7178 }
7179 newcount = (int) ztoi(vp->v_num->num);
7180 }
7181 oldcount = set_errcount(newcount);
7182
7183 result.v_type = V_NUM;
7184 result.v_num = itoq((long) oldcount);
7185 return result;
7186 }
7187
7188
7189 S_FUNC VALUE
f_errmax(int count,VALUE ** vals)7190 f_errmax(int count, VALUE **vals)
7191 {
7192 long oldmax;
7193 VALUE *vp;
7194 VALUE result;
7195
7196 /* initialize VALUE */
7197 result.v_subtype = V_NOSUBTYPE;
7198
7199 oldmax = errmax;
7200 if (count > 0) {
7201 vp = vals[0];
7202
7203 if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
7204 zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) {
7205 fprintf(stderr,
7206 "Out-of-range arg for errmax ignored\n");
7207 } else {
7208 errmax = ztoi(vp->v_num->num);
7209 }
7210 }
7211
7212 result.v_type = V_NUM;
7213 result.v_num = itoq((long) oldmax);
7214 return result;
7215 }
7216
7217
7218 S_FUNC VALUE
f_stoponerror(int count,VALUE ** vals)7219 f_stoponerror(int count, VALUE **vals)
7220 {
7221 long oldval;
7222 VALUE *vp;
7223 VALUE result;
7224
7225 /* initialize VALUE */
7226 result.v_subtype = V_NOSUBTYPE;
7227
7228 oldval = stoponerror;
7229 if (count > 0) {
7230 vp = vals[0];
7231
7232 if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
7233 zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) {
7234 fprintf(stderr,
7235 "Out-of-range arg for stoponerror ignored\n");
7236 } else {
7237 stoponerror = ztoi(vp->v_num->num);
7238 }
7239 }
7240
7241 result.v_type = V_NUM;
7242 result.v_num = itoq((long) oldval);
7243 return result;
7244 }
7245
7246 S_FUNC VALUE
f_fclose(int count,VALUE ** vals)7247 f_fclose(int count, VALUE **vals)
7248 {
7249 VALUE result;
7250 VALUE *vp;
7251 int n, i=0;
7252
7253 /* initialize VALUE */
7254 result.v_subtype = V_NOSUBTYPE;
7255
7256 errno = 0;
7257 if (count == 0) {
7258 i = closeall();
7259 } else {
7260 for (n = 0; n < count; n++) {
7261 vp = vals[n];
7262 if (vp->v_type != V_FILE)
7263 return error_value(E_FCLOSE1);
7264 }
7265 for (n = 0; n < count; n++) {
7266 vp = vals[n];
7267 i = closeid(vp->v_file);
7268 if (i < 0)
7269 return error_value(E_REWIND2);
7270 }
7271 }
7272 if (i < 0)
7273 return error_value(errno);
7274 result.v_type = V_NULL;
7275 return result;
7276 }
7277
7278
7279 S_FUNC VALUE
f_rm(int count,VALUE ** vals)7280 f_rm(int count, VALUE **vals)
7281 {
7282 VALUE result;
7283 int force; /* TRUE -> -f was given as 1st arg */
7284 int i;
7285 int j;
7286
7287 /* initialize VALUE */
7288 result.v_subtype = V_NOSUBTYPE;
7289
7290 /*
7291 * firewall
7292 */
7293 if (!allow_write)
7294 return error_value(E_WRPERM);
7295
7296 /*
7297 * check on each arg
7298 */
7299 for (i=0; i < count; ++i) {
7300 if (vals[i]->v_type != V_STR)
7301 return error_value(E_RM1);
7302 if (vals[i]->v_str->s_str[0] == '\0')
7303 return error_value(E_RM1);
7304 }
7305
7306 /*
7307 * look for a leading -f option
7308 */
7309 force = (strcmp(vals[0]->v_str->s_str, "-f") == 0);
7310 if (force) {
7311 --count;
7312 ++vals;
7313 }
7314
7315 /*
7316 * remove file(s)
7317 */
7318 for (i=0; i < count; ++i) {
7319 j = remove(vals[i]->v_str->s_str);
7320 if (!force && j < 0)
7321 return error_value(errno);
7322 }
7323 result.v_type = V_NULL;
7324 result.v_subtype = V_NOSUBTYPE;
7325 return result;
7326 }
7327
7328
7329 S_FUNC VALUE
f_newerror(int count,VALUE ** vals)7330 f_newerror(int count, VALUE **vals)
7331 {
7332 char *str;
7333 int index;
7334 int errnum;
7335
7336 str = NULL;
7337 if (count > 0 && vals[0]->v_type == V_STR)
7338 str = vals[0]->v_str->s_str;
7339 if (str == NULL || str[0] == '\0')
7340 str = "???";
7341 if (nexterrnum == E_USERDEF)
7342 initstr(&newerrorstr);
7343 index = findstr(&newerrorstr, str);
7344 if (index >= 0) {
7345 errnum = E_USERDEF + index;
7346 } else {
7347 if (nexterrnum == 32767)
7348 math_error("Too many new error values");
7349 errnum = nexterrnum++;
7350 addstr(&newerrorstr, str);
7351 }
7352 return error_value(errnum);
7353 }
7354
7355
7356 S_FUNC VALUE
f_strerror(int count,VALUE ** vals)7357 f_strerror(int count, VALUE **vals)
7358 {
7359 VALUE *vp;
7360 VALUE result;
7361 long i;
7362 char *cp;
7363
7364 /* initialize VALUE */
7365 result.v_subtype = V_NOSUBTYPE;
7366
7367 /* parse args */
7368 if (count > 0) {
7369 vp = vals[0];
7370 if (vp->v_type < 0) {
7371 i = (long) -vp->v_type;
7372 } else {
7373 if (vp->v_type != V_NUM || qisfrac(vp->v_num))
7374 return error_value(E_STRERROR1);
7375 i = qtoi(vp->v_num);
7376 if (i < 0 || i > 32767)
7377 return error_value(E_STRERROR2);
7378 }
7379 } else {
7380 i = set_errno(-1);
7381 }
7382
7383 /* setup return type */
7384 result.v_type = V_STR;
7385
7386 /* change the meaning of error 0 */
7387 if (i == 0)
7388 i = E__BASE;
7389
7390 /* firewall - return generic error string if it is not assigned */
7391 if (i >= nexterrnum || (i > E__HIGHEST && i < E_USERDEF)
7392 || (i < E__BASE && strerror(i) == NULL)) {
7393 size_t snprintf_len; /* malloced snprintf buffer length */
7394 snprintf_len = sizeof("Unknown error 12345678901234567890")+1;
7395 cp = (char *) malloc(snprintf_len+1);
7396 if (cp == NULL) {
7397 math_error("Out of memory for strerror");
7398 /*NOTREACHED*/
7399 }
7400 snprintf(cp, snprintf_len, "Unknown error %ld", i);
7401 cp[snprintf_len] = '\0'; /* paranoia */
7402 result.v_str = makestring(cp);
7403 return result;
7404 }
7405
7406 /* system error */
7407 if (i < E__BASE) {
7408 cp = strerror(i);
7409
7410 /* user-described error */
7411 } else if (i >= E_USERDEF) {
7412 cp = namestr(&newerrorstr, i - E_USERDEF);
7413
7414 /* calc-described error */
7415 } else {
7416 cp = (char *)error_table[i - E__BASE];
7417 }
7418
7419 /* return result as a V_STR */
7420 result.v_str = makenewstring(cp);
7421 return result;
7422 }
7423
7424
7425 S_FUNC VALUE
f_ferror(VALUE * vp)7426 f_ferror(VALUE *vp)
7427 {
7428 VALUE result;
7429 int i;
7430
7431 /* initialize VALUE */
7432 result.v_subtype = V_NOSUBTYPE;
7433
7434 if (vp->v_type != V_FILE)
7435 return error_value(E_FERROR1);
7436 i = errorid(vp->v_file);
7437 if (i < 0)
7438 return error_value(E_FERROR2);
7439 result.v_type = V_NUM;
7440 result.v_num = itoq((long) i);
7441 return result;
7442 }
7443
7444
7445 S_FUNC VALUE
f_feof(VALUE * vp)7446 f_feof(VALUE *vp)
7447 {
7448 VALUE result;
7449 int i;
7450
7451 /* initialize VALUE */
7452 result.v_subtype = V_NOSUBTYPE;
7453
7454 if (vp->v_type != V_FILE)
7455 return error_value(E_FEOF1);
7456 i = eofid(vp->v_file);
7457 if (i < 0)
7458 return error_value(E_FEOF2);
7459 result.v_type = V_NUM;
7460 result.v_num = itoq((long) i);
7461 return result;
7462 }
7463
7464
7465 S_FUNC VALUE
f_fflush(int count,VALUE ** vals)7466 f_fflush(int count, VALUE **vals)
7467 {
7468 VALUE result;
7469 int i, n;
7470
7471 /* initialize VALUE */
7472 result.v_subtype = V_NOSUBTYPE;
7473
7474 i = 0;
7475 errno = 0;
7476 if (count == 0) {
7477 #if !defined(_WIN32) && !defined(_WIN64)
7478 i = flushall();
7479 #endif /* Windows free systems */
7480 } else {
7481 for (n = 0; n < count; n++) {
7482 if (vals[n]->v_type != V_FILE)
7483 return error_value(E_FFLUSH);
7484 }
7485 for (n = 0; n < count; n++) {
7486 i |= flushid(vals[n]->v_file);
7487 }
7488 }
7489 if (i == EOF)
7490 return error_value(errno);
7491 result.v_type = V_NULL;
7492 return result;
7493 }
7494
7495
7496 S_FUNC VALUE
f_error(int count,VALUE ** vals)7497 f_error(int count, VALUE **vals)
7498 {
7499 VALUE *vp;
7500 long r;
7501
7502 if (count > 0) {
7503 vp = vals[0];
7504
7505 if (vp->v_type <= 0) {
7506 r = (long) -vp->v_type;
7507 } else {
7508 if (vp->v_type != V_NUM || qisfrac(vp->v_num)) {
7509 r = E_ERROR1;
7510 } else {
7511 r = qtoi(vp->v_num);
7512 if (r < 0 || r >= 32768)
7513 r = E_ERROR2;
7514 }
7515 }
7516 } else {
7517 r = set_errno(-1);
7518 }
7519
7520 return error_value(r);
7521 }
7522
7523
7524 S_FUNC VALUE
f_iserror(VALUE * vp)7525 f_iserror(VALUE *vp)
7526 {
7527 VALUE res;
7528
7529 /* initialize VALUE */
7530 res.v_subtype = V_NOSUBTYPE;
7531
7532 res.v_type = V_NUM;
7533 res.v_num = itoq((long)((vp->v_type < 0) ? - vp->v_type : 0));
7534 return res;
7535 }
7536
7537
7538 S_FUNC VALUE
f_fsize(VALUE * vp)7539 f_fsize(VALUE *vp)
7540 {
7541 VALUE result;
7542 ZVALUE len; /* file length */
7543 int i;
7544
7545 /* initialize VALUE */
7546 result.v_subtype = V_NOSUBTYPE;
7547
7548 if (vp->v_type != V_FILE)
7549 return error_value(E_FSIZE1);
7550 i = getsize(vp->v_file, &len);
7551 if (i == EOF)
7552 return error_value(errno);
7553 if (i)
7554 return error_value(E_FSIZE2);
7555 result.v_type = V_NUM;
7556 result.v_num = qalloc();
7557 result.v_num->num = len;
7558 return result;
7559 }
7560
7561
7562 S_FUNC VALUE
f_fseek(int count,VALUE ** vals)7563 f_fseek(int count, VALUE **vals)
7564 {
7565 VALUE result;
7566 int whence;
7567 int i;
7568
7569 /* initialize VALUE */
7570 result.v_subtype = V_NOSUBTYPE;
7571
7572 /* firewalls */
7573 errno = 0;
7574 if (vals[0]->v_type != V_FILE)
7575 return error_value(E_FSEEK1);
7576 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
7577 return error_value(E_FSEEK2);
7578 if (count == 2) {
7579 whence = 0;
7580 } else {
7581 if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num) ||
7582 qisneg(vals[2]->v_num))
7583 return error_value(E_FSEEK2);
7584 if (vals[2]->v_num->num.len > 1)
7585 return error_value (E_FSEEK2);
7586 whence = (int)(unsigned int)(vals[2]->v_num->num.v[0]);
7587 if (whence > 2)
7588 return error_value (E_FSEEK2);
7589 }
7590
7591 i = fseekid(vals[0]->v_file, vals[1]->v_num->num, whence);
7592 result.v_type = V_NULL;
7593 if (i == EOF)
7594 return error_value(errno);
7595 if (i < 0)
7596 return error_value(E_FSEEK3);
7597 return result;
7598 }
7599
7600
7601 S_FUNC VALUE
f_ftell(VALUE * vp)7602 f_ftell(VALUE *vp)
7603 {
7604 VALUE result;
7605 ZVALUE pos; /* current file position */
7606 int i;
7607
7608 /* initialize VALUE */
7609 result.v_subtype = V_NOSUBTYPE;
7610
7611 errno = 0;
7612 if (vp->v_type != V_FILE)
7613 return error_value(E_FTELL1);
7614 i = ftellid(vp->v_file, &pos);
7615 if (i < 0)
7616 return error_value(E_FTELL2);
7617
7618 result.v_type = V_NUM;
7619 result.v_num = qalloc();
7620 result.v_num->num = pos;
7621 return result;
7622 }
7623
7624
7625 S_FUNC VALUE
f_rewind(int count,VALUE ** vals)7626 f_rewind(int count, VALUE **vals)
7627 {
7628 VALUE result;
7629 int n;
7630
7631 /* initialize VALUE */
7632 result.v_subtype = V_NOSUBTYPE;
7633
7634 if (count == 0) {
7635 rewindall();
7636
7637 } else {
7638 for (n = 0; n < count; n++) {
7639 if (vals[n]->v_type != V_FILE)
7640 return error_value(E_REWIND1);
7641 }
7642 for (n = 0; n < count; n++) {
7643 if (rewindid(vals[n]->v_file) != 0) {
7644 return error_value(E_REWIND2);
7645 }
7646 }
7647 }
7648 result.v_type = V_NULL;
7649 return result;
7650 }
7651
7652
7653 S_FUNC VALUE
f_fprintf(int count,VALUE ** vals)7654 f_fprintf(int count, VALUE **vals)
7655 {
7656 VALUE result;
7657 int i;
7658
7659 /* initialize VALUE */
7660 result.v_subtype = V_NOSUBTYPE;
7661
7662 if (vals[0]->v_type != V_FILE)
7663 return error_value(E_FPRINTF1);
7664 if (vals[1]->v_type != V_STR)
7665 return error_value(E_FPRINTF2);
7666 i = idprintf(vals[0]->v_file, vals[1]->v_str->s_str,
7667 count - 2, vals + 2);
7668 if (i > 0)
7669 return error_value(E_FPRINTF3);
7670 result.v_type = V_NULL;
7671 return result;
7672 }
7673
7674
7675 S_FUNC int
strscan(char * s,int count,VALUE ** vals)7676 strscan(char *s, int count, VALUE **vals)
7677 {
7678 char ch, chtmp;
7679 char *s0;
7680 int n = 0;
7681 VALUE val, result;
7682 VALUE *var;
7683
7684 /* initialize VALUEs */
7685 val.v_subtype = V_NOSUBTYPE;
7686 result.v_subtype = V_NOSUBTYPE;
7687
7688 val.v_type = V_STR;
7689 while (*s != '\0') {
7690 s--;
7691 while ((ch = *++s)) {
7692 if (!isspace((int)ch))
7693 break;
7694 }
7695 if (ch == '\0' || count-- == 0)
7696 return n;
7697 s0 = s;
7698 while ((ch = *++s)) {
7699 if (isspace((int)ch))
7700 break;
7701 }
7702 chtmp = ch;
7703 *s = '\0';
7704 n++;
7705 val.v_str = makenewstring(s0);
7706 result = f_eval(&val);
7707 var = *vals++;
7708 if (var->v_type == V_ADDR) {
7709 var = var->v_addr;
7710 freevalue(var);
7711 *var = result;
7712 }
7713 *s = chtmp;
7714 }
7715 return n;
7716 }
7717
7718
7719 S_FUNC int
filescan(FILEID id,int count,VALUE ** vals)7720 filescan(FILEID id, int count, VALUE **vals)
7721 {
7722 STRING *str;
7723 int i;
7724 int n = 0;
7725 VALUE val;
7726 VALUE result;
7727 VALUE *var;
7728
7729 /* initialize VALUEs */
7730 val.v_type = V_STR;
7731 val.v_subtype = V_NOSUBTYPE;
7732 result.v_subtype = V_NOSUBTYPE;
7733
7734 while (count-- > 0) {
7735
7736 i = readid(id, 6, &str);
7737
7738 if (i == EOF)
7739 break;
7740 if (i > 0)
7741 return EOF;
7742 n++;
7743 val.v_str = str;
7744 result = f_eval(&val);
7745 var = *vals++;
7746 if (var->v_type == V_ADDR) {
7747 var = var->v_addr;
7748 freevalue(var);
7749 *var = result;
7750 }
7751 }
7752 return n;
7753 }
7754
7755
7756 S_FUNC VALUE
f_scan(int count,VALUE ** vals)7757 f_scan(int count, VALUE **vals)
7758 {
7759 char *cp;
7760 VALUE result;
7761 int i;
7762
7763 /* initialize VALUEs */
7764 result.v_subtype = V_NOSUBTYPE;
7765
7766 cp = nextline();
7767 if (cp == NULL) {
7768 result.v_type = V_NULL;
7769 return result;
7770 }
7771
7772 i = strscan(cp, count, vals);
7773 result.v_type = V_NUM;
7774 result.v_num = itoq((long) i);
7775 return result;
7776 }
7777
7778
7779 S_FUNC VALUE
f_strscan(int count,VALUE ** vals)7780 f_strscan(int count, VALUE **vals)
7781 {
7782 VALUE *vp;
7783 VALUE result;
7784 int i;
7785
7786 /* initialize VALUE */
7787 result.v_subtype = V_NOSUBTYPE;
7788
7789 vp = *vals;
7790 if (vp->v_type == V_ADDR)
7791 vp = vp->v_addr;
7792 if (vp->v_type != V_STR)
7793 return error_value(E_STRSCAN);
7794
7795 i = strscan(vp->v_str->s_str, count - 1, vals + 1);
7796
7797 result.v_type = V_NUM;
7798 result.v_num = itoq((long) i);
7799 return result;
7800 }
7801
7802
7803 S_FUNC VALUE
f_fscan(int count,VALUE ** vals)7804 f_fscan(int count, VALUE **vals)
7805 {
7806 VALUE *vp;
7807 VALUE result;
7808 int i;
7809
7810 /* initialize VALUE */
7811 result.v_subtype = V_NOSUBTYPE;
7812
7813 errno = 0;
7814 vp = *vals;
7815 if (vp->v_type == V_ADDR)
7816 vp = vp->v_addr;
7817 if (vp->v_type != V_FILE)
7818 return error_value(E_FSCAN1);
7819
7820 i = filescan(vp->v_file, count - 1, vals + 1);
7821
7822 if (i == EOF)
7823 return error_value(errno);
7824 if (i < 0)
7825 return error_value(E_FSCAN2);
7826
7827 result.v_type = V_NUM;
7828 result.v_num = itoq((long) i);
7829 return result;
7830 }
7831
7832
7833 S_FUNC VALUE
f_scanf(int count,VALUE ** vals)7834 f_scanf(int count, VALUE **vals)
7835 {
7836 VALUE *vp;
7837 VALUE result;
7838 int i;
7839
7840 /* initialize VALUE */
7841 result.v_subtype = V_NOSUBTYPE;
7842
7843 vp = *vals;
7844 if (vp->v_type == V_ADDR)
7845 vp = vp->v_addr;
7846 if (vp->v_type != V_STR)
7847 return error_value(E_SCANF1);
7848 for (i = 1; i < count; i++) {
7849 if (vals[i]->v_type != V_ADDR)
7850 return error_value(E_SCANF2);
7851 }
7852 i = fscanfid(FILEID_STDIN, vp->v_str->s_str, count - 1, vals + 1);
7853 if (i < 0)
7854 return error_value(E_SCANF3);
7855 result.v_type = V_NUM;
7856 result.v_num = itoq((long) i);
7857 return result;
7858 }
7859
7860
7861 S_FUNC VALUE
f_strscanf(int count,VALUE ** vals)7862 f_strscanf(int count, VALUE **vals)
7863 {
7864 VALUE *vp, *vq;
7865 VALUE result;
7866 int i;
7867
7868 /* initialize VALUE */
7869 result.v_subtype = V_NOSUBTYPE;
7870
7871 errno = 0;
7872 vp = vals[0];
7873 if (vp->v_type == V_ADDR)
7874 vp = vp->v_addr;
7875 if (vp->v_type != V_STR)
7876 return error_value(E_STRSCANF1);
7877 vq = vals[1];
7878 if (vq->v_type == V_ADDR)
7879 vq = vq->v_addr;
7880 if (vq->v_type != V_STR)
7881 return error_value(E_STRSCANF2);
7882 for (i = 2; i < count; i++) {
7883 if (vals[i]->v_type != V_ADDR)
7884 return error_value(E_STRSCANF3);
7885 }
7886 i = scanfstr(vp->v_str->s_str, vq->v_str->s_str,
7887 count - 2, vals + 2);
7888 if (i == EOF)
7889 return error_value(errno);
7890 if (i < 0)
7891 return error_value(E_STRSCANF4);
7892 result.v_type = V_NUM;
7893 result.v_num = itoq((long) i);
7894 return result;
7895 }
7896
7897
7898 S_FUNC VALUE
f_fscanf(int count,VALUE ** vals)7899 f_fscanf(int count, VALUE **vals)
7900 {
7901 VALUE *vp, *sp;
7902 VALUE result;
7903 int i;
7904
7905 /* initialize VALUE */
7906 result.v_subtype = V_NOSUBTYPE;
7907
7908 vp = *vals++;
7909 if (vp->v_type == V_ADDR)
7910 vp = vp->v_addr;
7911 if (vp->v_type != V_FILE)
7912 return error_value(E_FSCANF1);
7913 sp = *vals++;
7914 if (sp->v_type == V_ADDR)
7915 sp = sp->v_addr;
7916 if (sp->v_type != V_STR)
7917 return error_value(E_FSCANF2);
7918 for (i = 0; i < count - 2; i++) {
7919 if (vals[i]->v_type != V_ADDR)
7920 return error_value(E_FSCANF3);
7921 }
7922 i = fscanfid(vp->v_file, sp->v_str->s_str, count - 2, vals);
7923 if (i == EOF) {
7924 result.v_type = V_NULL;
7925 return result;
7926 }
7927 if (i < 0)
7928 return error_value(E_FSCANF4);
7929 result.v_type = V_NUM;
7930 result.v_num = itoq((long) i);
7931 return result;
7932 }
7933
7934
7935 S_FUNC VALUE
f_fputc(VALUE * v1,VALUE * v2)7936 f_fputc(VALUE *v1, VALUE *v2)
7937 {
7938 VALUE result;
7939 NUMBER *q;
7940 int ch;
7941 int i;
7942
7943 /* initialize VALUE */
7944 result.v_subtype = V_NOSUBTYPE;
7945
7946 if (v1->v_type != V_FILE)
7947 return error_value(E_FPUTC1);
7948 switch (v2->v_type) {
7949 case V_STR:
7950 ch = v2->v_str->s_str[0];
7951 break;
7952 case V_NUM:
7953 q = v2->v_num;
7954 if (!qisint(q))
7955 return error_value(E_FPUTC2);
7956
7957 ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) :
7958 (int)(q->num.v[0] & 0xff);
7959 break;
7960 case V_NULL:
7961 ch = 0;
7962 break;
7963 default:
7964 return error_value(E_FPUTC2);
7965 }
7966 i = idfputc(v1->v_file, ch);
7967 if (i > 0)
7968 return error_value(E_FPUTC3);
7969 result.v_type = V_NULL;
7970 return result;
7971 }
7972
7973
7974 S_FUNC VALUE
f_fputs(int count,VALUE ** vals)7975 f_fputs(int count, VALUE **vals)
7976 {
7977 VALUE result;
7978 int i, err;
7979
7980 /* initialize VALUE */
7981 result.v_subtype = V_NOSUBTYPE;
7982
7983 if (vals[0]->v_type != V_FILE)
7984 return error_value(E_FPUTS1);
7985 for (i = 1; i < count; i++) {
7986 if (vals[i]->v_type != V_STR)
7987 return error_value(E_FPUTS2);
7988 }
7989 for (i = 1; i < count; i++) {
7990 err = idfputs(vals[0]->v_file, vals[i]->v_str);
7991 if (err > 0)
7992 return error_value(E_FPUTS3);
7993 }
7994 result.v_type = V_NULL;
7995 return result;
7996 }
7997
7998
7999 S_FUNC VALUE
f_fputstr(int count,VALUE ** vals)8000 f_fputstr(int count, VALUE **vals)
8001 {
8002 VALUE result;
8003 int i, err;
8004
8005 /* initialize VALUE */
8006 result.v_subtype = V_NOSUBTYPE;
8007
8008 if (vals[0]->v_type != V_FILE)
8009 return error_value(E_FPUTSTR1);
8010 for (i = 1; i < count; i++) {
8011 if (vals[i]->v_type != V_STR)
8012 return error_value(E_FPUTSTR2);
8013 }
8014 for (i = 1; i < count; i++) {
8015 err = idfputstr(vals[0]->v_file,
8016 vals[i]->v_str->s_str);
8017 if (err > 0)
8018 return error_value(E_FPUTSTR3);
8019 }
8020 result.v_type = V_NULL;
8021 return result;
8022 }
8023
8024
8025 S_FUNC VALUE
f_printf(int count,VALUE ** vals)8026 f_printf(int count, VALUE **vals)
8027 {
8028 VALUE result;
8029 int i;
8030
8031 /* initialize VALUE */
8032 result.v_subtype = V_NOSUBTYPE;
8033
8034 if (vals[0]->v_type != V_STR)
8035 return error_value(E_PRINTF1);
8036 i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str,
8037 count - 1, vals + 1);
8038 if (i)
8039 return error_value(E_PRINTF2);
8040 result.v_type = V_NULL;
8041 return result;
8042 }
8043
8044
8045 S_FUNC VALUE
f_strprintf(int count,VALUE ** vals)8046 f_strprintf(int count, VALUE **vals)
8047 {
8048 VALUE result;
8049 int i;
8050 char *cp;
8051
8052 /* initialize VALUE */
8053 result.v_subtype = V_NOSUBTYPE;
8054
8055 if (vals[0]->v_type != V_STR)
8056 return error_value(E_STRPRINTF1);
8057 math_divertio();
8058 i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str,
8059 count - 1, vals + 1);
8060 if (i) {
8061 free(math_getdivertedio());
8062 return error_value(E_STRPRINTF2);
8063 }
8064 cp = math_getdivertedio();
8065 result.v_type = V_STR;
8066 result.v_str = makenewstring(cp);
8067 free(cp);
8068 return result;
8069 }
8070
8071
8072 S_FUNC VALUE
f_fgetc(VALUE * vp)8073 f_fgetc(VALUE *vp)
8074 {
8075 VALUE result;
8076 int ch;
8077
8078 /* initialize VALUE */
8079 result.v_subtype = V_NOSUBTYPE;
8080
8081 if (vp->v_type != V_FILE)
8082 return error_value(E_FGETC1);
8083 ch = getcharid(vp->v_file);
8084 if (ch == -2)
8085 return error_value(E_FGETC2);
8086 result.v_type = V_NULL;
8087 if (ch != EOF) {
8088 result.v_type = V_STR;
8089 result.v_str = charstring(ch);
8090 }
8091 return result;
8092 }
8093
8094
8095 S_FUNC VALUE
f_ungetc(VALUE * v1,VALUE * v2)8096 f_ungetc(VALUE *v1, VALUE *v2)
8097 {
8098 VALUE result;
8099 NUMBER *q;
8100 int ch;
8101 int i;
8102
8103 /* initialize VALUE */
8104 result.v_subtype = V_NOSUBTYPE;
8105
8106 errno = 0;
8107 if (v1->v_type != V_FILE)
8108 return error_value(E_UNGETC1);
8109 switch (v2->v_type) {
8110 case V_STR:
8111 ch = v2->v_str->s_str[0];
8112 break;
8113 case V_NUM:
8114 q = v2->v_num;
8115 if (!qisint(q))
8116 return error_value(E_UNGETC2);
8117 ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) :
8118 (int)(q->num.v[0] & 0xff);
8119 break;
8120 default:
8121 return error_value(E_UNGETC2);
8122 }
8123 i = idungetc(v1->v_file, ch);
8124 if (i == EOF)
8125 return error_value(errno);
8126 if (i == -2)
8127 return error_value(E_UNGETC3);
8128 result.v_type = V_NULL;
8129 return result;
8130 }
8131
8132
8133 S_FUNC VALUE
f_fgetline(VALUE * vp)8134 f_fgetline(VALUE *vp)
8135 {
8136 VALUE result;
8137 STRING *str;
8138 int i;
8139
8140 /* initialize VALUE */
8141 result.v_subtype = V_NOSUBTYPE;
8142
8143 if (vp->v_type != V_FILE)
8144 return error_value(E_FGETLINE1);
8145 i = readid(vp->v_file, 9, &str);
8146 if (i > 0)
8147 return error_value(E_FGETLINE2);
8148 result.v_type = V_NULL;
8149 if (i == 0) {
8150 result.v_type = V_STR;
8151 result.v_str = str;
8152 }
8153 return result;
8154 }
8155
8156
8157 S_FUNC VALUE
f_fgets(VALUE * vp)8158 f_fgets(VALUE *vp)
8159 {
8160 VALUE result;
8161 STRING *str;
8162 int i;
8163
8164 /* initialize VALUE */
8165 result.v_subtype = V_NOSUBTYPE;
8166
8167 if (vp->v_type != V_FILE)
8168 return error_value(E_FGETS1);
8169 i = readid(vp->v_file, 1, &str);
8170 if (i > 0)
8171 return error_value(E_FGETS2);
8172 result.v_type = V_NULL;
8173 if (i == 0) {
8174 result.v_type = V_STR;
8175 result.v_str = str;
8176 }
8177 return result;
8178 }
8179
8180
8181 S_FUNC VALUE
f_fgetstr(VALUE * vp)8182 f_fgetstr(VALUE *vp)
8183 {
8184 VALUE result;
8185 STRING *str;
8186 int i;
8187
8188 /* initialize VALUE */
8189 result.v_subtype = V_NOSUBTYPE;
8190
8191 if (vp->v_type != V_FILE)
8192 return error_value(E_FGETSTR1);
8193 i = readid(vp->v_file, 10, &str);
8194 if (i > 0)
8195 return error_value(E_FGETSTR2);
8196 result.v_type = V_NULL;
8197 if (i == 0) {
8198 result.v_type = V_STR;
8199 result.v_str = str;
8200 }
8201 return result;
8202 }
8203
8204
8205 S_FUNC VALUE
f_fgetfield(VALUE * vp)8206 f_fgetfield(VALUE *vp)
8207 {
8208 VALUE result;
8209 STRING *str;
8210 int i;
8211
8212 /* initialize VALUE */
8213 result.v_subtype = V_NOSUBTYPE;
8214
8215 if (vp->v_type != V_FILE)
8216 return error_value(E_FGETFIELD1);
8217 i = readid(vp->v_file, 14, &str);
8218 if (i > 0)
8219 return error_value(E_FGETFIELD2);
8220 result.v_type = V_NULL;
8221 if (i == 0) {
8222 result.v_type = V_STR;
8223 result.v_str = str;
8224 }
8225 return result;
8226 }
8227
8228 S_FUNC VALUE
f_fgetfile(VALUE * vp)8229 f_fgetfile(VALUE *vp)
8230 {
8231 VALUE result;
8232 STRING *str;
8233 int i;
8234
8235 /* initialize VALUE */
8236 result.v_subtype = V_NOSUBTYPE;
8237
8238 if (vp->v_type != V_FILE)
8239 return error_value(E_FGETFILE1);
8240 i = readid(vp->v_file, 0, &str);
8241 if (i == 1)
8242 return error_value(E_FGETFILE2);
8243 if (i == 3)
8244 return error_value(E_FGETFILE3);
8245 result.v_type = V_NULL;
8246 if (i == 0) {
8247 result.v_type = V_STR;
8248 result.v_str = str;
8249 }
8250 return result;
8251 }
8252
8253
8254 S_FUNC VALUE
f_files(int count,VALUE ** vals)8255 f_files(int count, VALUE **vals)
8256 {
8257 VALUE result;
8258
8259 /* initialize VALUE */
8260 result.v_subtype = V_NOSUBTYPE;
8261
8262 if (count == 0) {
8263 result.v_type = V_NUM;
8264 result.v_num = itoq((long) MAXFILES);
8265 return result;
8266 }
8267 if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num))
8268 return error_value(E_FILES);
8269 result.v_type = V_NULL;
8270 result.v_file = indexid(qtoi(vals[0]->v_num));
8271 if (result.v_file != FILEID_NONE)
8272 result.v_type = V_FILE;
8273 return result;
8274 }
8275
8276
8277 S_FUNC VALUE
f_reverse(VALUE * val)8278 f_reverse(VALUE *val)
8279 {
8280 VALUE res;
8281
8282 res.v_type = val->v_type;
8283 res.v_subtype = val->v_subtype;
8284 switch(val->v_type) {
8285 case V_MAT:
8286 res.v_mat = matcopy(val->v_mat);
8287 matreverse(res.v_mat);
8288 break;
8289 case V_LIST:
8290 res.v_list = listcopy(val->v_list);
8291 listreverse(res.v_list);
8292 break;
8293 case V_STR:
8294 res.v_str = stringneg(val->v_str);
8295 if (res.v_str == NULL)
8296 return error_value(E_STRNEG);
8297 break;
8298 default:
8299 math_error("Bad argument type for reverse");
8300 /*NOTREACHED*/
8301 }
8302 return res;
8303 }
8304
8305
8306 S_FUNC VALUE
f_sort(VALUE * val)8307 f_sort(VALUE *val)
8308 {
8309 VALUE res;
8310
8311 res.v_type = val->v_type;
8312 res.v_subtype = val->v_subtype;
8313 switch (val->v_type) {
8314 case V_MAT:
8315 res.v_mat = matcopy(val->v_mat);
8316 matsort(res.v_mat);
8317 break;
8318 case V_LIST:
8319 res.v_list = listcopy(val->v_list);
8320 listsort(res.v_list);
8321 break;
8322 default:
8323 math_error("Bad argument type for sort");
8324 /*NOTREACHED*/
8325 }
8326 return res;
8327 }
8328
8329
8330 S_FUNC VALUE
f_join(int count,VALUE ** vals)8331 f_join(int count, VALUE **vals)
8332 {
8333 LIST *lp;
8334 LISTELEM *ep;
8335 VALUE res;
8336
8337 /* initialize VALUE */
8338 res.v_subtype = V_NOSUBTYPE;
8339
8340 lp = listalloc();
8341 while (count-- > 0) {
8342 if (vals[0]->v_type != V_LIST) {
8343 listfree(lp);
8344 printf("Non-list argument for join\n");
8345 res.v_type = V_NULL;
8346 return res;
8347 }
8348 for (ep = vals[0]->v_list->l_first; ep; ep = ep->e_next)
8349 insertlistlast(lp, &ep->e_value);
8350 vals++;
8351 }
8352 res.v_type = V_LIST;
8353 res.v_list = lp;
8354 return res;
8355 }
8356
8357
8358 S_FUNC VALUE
f_head(VALUE * v1,VALUE * v2)8359 f_head(VALUE *v1, VALUE *v2)
8360 {
8361 VALUE res;
8362 long n;
8363
8364 /* initialize VALUE */
8365 res.v_subtype = V_NOSUBTYPE;
8366
8367 if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
8368 zge31b(v2->v_num->num))
8369 return error_value(E_HEAD2);
8370 n = qtoi(v2->v_num);
8371
8372 res.v_type = v1->v_type;
8373 switch (v1->v_type) {
8374 case V_LIST:
8375 if (n == 0)
8376 res.v_list = listalloc();
8377 else if (n > 0)
8378 res.v_list = listsegment(v1->v_list,0,n-1);
8379 else
8380 res.v_list = listsegment(v1->v_list,-n-1,0);
8381 return res;
8382 case V_STR:
8383 if (n == 0)
8384 res.v_str = slink(&_nullstring_);
8385 else if (n > 0)
8386 res.v_str = stringsegment(v1->v_str,0,n-1);
8387 else
8388 res.v_str = stringsegment(v1->v_str,-n-1,0);
8389 if (res.v_str == NULL)
8390 return error_value(E_STRHEAD);
8391 return res;
8392 default:
8393 return error_value(E_HEAD1);
8394 }
8395 }
8396
8397
8398 S_FUNC VALUE
f_tail(VALUE * v1,VALUE * v2)8399 f_tail(VALUE *v1, VALUE *v2)
8400 {
8401 long n;
8402 VALUE res;
8403
8404 /* initialize VALUE */
8405 res.v_subtype = V_NOSUBTYPE;
8406
8407 if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
8408 zge31b(v2->v_num->num))
8409 return error_value(E_TAIL1);
8410 n = qtoi(v2->v_num);
8411 res.v_type = v1->v_type;
8412 switch (v1->v_type) {
8413 case V_LIST:
8414 if (n == 0) {
8415 res.v_list = listalloc();
8416 } else if (n > 0) {
8417 res.v_list = listsegment(v1->v_list,
8418 v1->v_list->l_count - n,
8419 v1->v_list->l_count - 1);
8420 } else {
8421 res.v_list = listsegment(v1->v_list,
8422 v1->v_list->l_count - 1,
8423 v1->v_list->l_count + n);
8424 }
8425 return res;
8426 case V_STR:
8427 if (n == 0) {
8428 res.v_str = slink(&_nullstring_);
8429 } else if (n > 0) {
8430 res.v_str = stringsegment(v1->v_str,
8431 v1->v_str->s_len - n,
8432 v1->v_str->s_len - 1);
8433 } else {
8434 res.v_str = stringsegment(v1->v_str,
8435 v1->v_str->s_len - 1,
8436 v1->v_str->s_len + n);
8437 }
8438 if (res.v_str == V_NULL)
8439 return error_value(E_STRTAIL);
8440 return res;
8441 default:
8442 return error_value(E_TAIL1);
8443 }
8444 }
8445
8446
8447 S_FUNC VALUE
f_segment(int count,VALUE ** vals)8448 f_segment(int count, VALUE **vals)
8449 {
8450 VALUE *vp;
8451 long n1, n2;
8452 VALUE result;
8453
8454 /* initialize VALUE */
8455 result.v_subtype = V_NOSUBTYPE;
8456
8457 vp = vals[1];
8458
8459 if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num))
8460 return error_value(E_SEG2);
8461 n1 = qtoi(vp->v_num);
8462 n2 = n1;
8463 if (count == 3) {
8464 vp = vals[2];
8465 if (vp->v_type != V_NUM || qisfrac(vp->v_num) ||
8466 zge31b(vp->v_num->num))
8467 return error_value(E_SEG3);
8468 n2 = qtoi(vp->v_num);
8469 }
8470 vp = vals[0];
8471 result.v_type = vp->v_type;
8472 switch (vp->v_type) {
8473 case V_LIST:
8474 result.v_list = listsegment(vp->v_list, n1, n2);
8475 return result;
8476 case V_STR:
8477 result.v_str = stringsegment(vp->v_str, n1, n2);
8478 if (result.v_str == NULL)
8479 return error_value(E_STRSEG);
8480 return result;
8481 default:
8482 return error_value(E_SEG1);
8483 }
8484 }
8485
8486
8487 S_FUNC VALUE
f_modify(VALUE * v1,VALUE * v2)8488 f_modify(VALUE *v1, VALUE *v2)
8489 {
8490 FUNC *fp;
8491 LISTELEM *ep;
8492 long s;
8493 VALUE res;
8494 VALUE *vp;
8495 unsigned short subtype;
8496
8497 if (v1->v_type != V_ADDR)
8498 return error_value(E_MODIFY1);
8499 v1 = v1->v_addr;
8500 if (v2->v_type == V_ADDR)
8501 v2 = v2->v_addr;
8502 if (v2->v_type != V_STR)
8503 return error_value(E_MODIFY2);
8504 if (v1->v_subtype & V_NONEWVALUE)
8505 return error_value(E_MODIFY3);
8506 fp = findfunc(adduserfunc(v2->v_str->s_str));
8507 if (!fp)
8508 return error_value(E_MODIFY4);
8509 switch (v1->v_type) {
8510 case V_LIST:
8511 for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
8512 subtype = ep->e_value.v_subtype;
8513 *++stack = ep->e_value;
8514 calculate(fp, 1);
8515 stack->v_subtype |= subtype;
8516 ep->e_value = *stack--;
8517 }
8518 break;
8519 case V_MAT:
8520 vp = v1->v_mat->m_table;
8521 s = v1->v_mat->m_size;
8522 while (s-- > 0) {
8523 subtype = vp->v_subtype;
8524 *++stack = *vp;
8525 calculate(fp, 1);
8526 stack->v_subtype |= subtype;
8527 *vp++ = *stack--;
8528 }
8529 break;
8530 case V_OBJ:
8531 vp = v1->v_obj->o_table;
8532 s = v1->v_obj->o_actions->oa_count;
8533 while (s-- > 0) {
8534 subtype = vp->v_subtype;
8535 *++stack = *vp;
8536 calculate(fp, 1);
8537 stack->v_subtype |= subtype;
8538 *vp++ = *stack--;
8539 }
8540 break;
8541 default:
8542 return error_value(E_MODIFY5);
8543 }
8544 res.v_type = V_NULL;
8545 res.v_subtype = V_NOSUBTYPE;
8546 return res;
8547 }
8548
8549
8550 S_FUNC VALUE
f_forall(VALUE * v1,VALUE * v2)8551 f_forall(VALUE *v1, VALUE *v2)
8552 {
8553 FUNC *fp;
8554 LISTELEM *ep;
8555 long s;
8556 VALUE res;
8557 VALUE *vp;
8558
8559 /* initialize VALUE */
8560 res.v_type = V_NULL;
8561 res.v_subtype = V_NOSUBTYPE;
8562
8563 if (v2->v_type != V_STR) {
8564 math_error("Non-string second argument for forall");
8565 /*NOTREACHED*/
8566 }
8567 fp = findfunc(adduserfunc(v2->v_str->s_str));
8568 if (!fp) {
8569 math_error("Undefined function for forall");
8570 /*NOTREACHED*/
8571 }
8572 switch (v1->v_type) {
8573 case V_LIST:
8574 for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
8575 copyvalue(&ep->e_value, ++stack);
8576 calculate(fp, 1);
8577 stack--;
8578 }
8579 break;
8580 case V_MAT:
8581 vp = v1->v_mat->m_table;
8582 s = v1->v_mat->m_size;
8583 while (s-- > 0) {
8584 copyvalue(vp++, ++stack);
8585 calculate(fp, 1);
8586 stack--;
8587 }
8588 break;
8589 default:
8590 math_error("Non list or matrix first argument for forall");
8591 /*NOTREACHED*/
8592 }
8593 return res;
8594 }
8595
8596
8597 S_FUNC VALUE
f_select(VALUE * v1,VALUE * v2)8598 f_select(VALUE *v1, VALUE *v2)
8599 {
8600 LIST *lp;
8601 LISTELEM *ep;
8602 FUNC *fp;
8603 VALUE res;
8604
8605 /* initialize VALUE */
8606 res.v_type = V_LIST;
8607 res.v_subtype = V_NOSUBTYPE;
8608
8609 if (v1->v_type != V_LIST) {
8610 math_error("Non-list first argument for select");
8611 /*NOTREACHED*/
8612 }
8613 if (v2->v_type != V_STR) {
8614 math_error("Non-string second argument for select");
8615 /*NOTREACHED*/
8616 }
8617 fp = findfunc(adduserfunc(v2->v_str->s_str));
8618 if (!fp) {
8619 math_error("Undefined function for select");
8620 /*NOTREACHED*/
8621 }
8622 lp = listalloc();
8623 for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
8624 copyvalue(&ep->e_value, ++stack);
8625 calculate(fp, 1);
8626 if (testvalue(stack))
8627 insertlistlast(lp, &ep->e_value);
8628 freevalue(stack--);
8629 }
8630 res.v_list = lp;
8631 return res;
8632 }
8633
8634
8635 S_FUNC VALUE
f_count(VALUE * v1,VALUE * v2)8636 f_count(VALUE *v1, VALUE *v2)
8637 {
8638 LISTELEM *ep;
8639 FUNC *fp;
8640 long s;
8641 long n = 0;
8642 VALUE res;
8643 VALUE *vp;
8644
8645 /* initialize VALUE */
8646 res.v_type = V_NUM;
8647 res.v_subtype = V_NOSUBTYPE;
8648
8649 if (v2->v_type != V_STR) {
8650 math_error("Non-string second argument for select");
8651 /*NOTREACHED*/
8652 }
8653 fp = findfunc(adduserfunc(v2->v_str->s_str));
8654 if (!fp) {
8655 math_error("Undefined function for select");
8656 /*NOTREACHED*/
8657 }
8658 switch (v1->v_type) {
8659 case V_LIST:
8660 for (ep = v1->v_list->l_first; ep; ep = ep->e_next) {
8661 copyvalue(&ep->e_value, ++stack);
8662 calculate(fp, 1);
8663 if (testvalue(stack))
8664 n++;
8665 freevalue(stack--);
8666 }
8667 break;
8668 case V_MAT:
8669 s = v1->v_mat->m_size;
8670 vp = v1->v_mat->m_table;
8671 while (s-- > 0) {
8672 copyvalue(vp++, ++stack);
8673 calculate(fp, 1);
8674 if (testvalue(stack))
8675 n++;
8676 freevalue(stack--);
8677 }
8678 break;
8679 default:
8680 math_error("Bad argument type for count");
8681 /*NOTREACHED*/
8682 }
8683 res.v_num = itoq(n);
8684 return res;
8685 }
8686
8687
8688 S_FUNC VALUE
f_makelist(VALUE * v1)8689 f_makelist(VALUE *v1)
8690 {
8691 LIST *lp;
8692 VALUE res;
8693 long n;
8694
8695 /* initialize VALUE */
8696 res.v_type = V_NULL;
8697 res.v_subtype = V_NOSUBTYPE;
8698
8699 if (v1->v_type != V_NUM || qisfrac(v1->v_num) || qisneg(v1->v_num)) {
8700 math_error("Bad argument for makelist");
8701 /*NOTREACHED*/
8702 }
8703 if (zge31b(v1->v_num->num)) {
8704 math_error("makelist count >= 2^31");
8705 /*NOTREACHED*/
8706 }
8707 n = qtoi(v1->v_num);
8708 lp = listalloc();
8709 while (n-- > 0)
8710 insertlistlast(lp, &res);
8711 res.v_type = V_LIST;
8712 res.v_list = lp;
8713 return res;
8714 }
8715
8716
8717 S_FUNC VALUE
f_randperm(VALUE * val)8718 f_randperm(VALUE *val)
8719 {
8720 VALUE res;
8721
8722 /* initialize VALUE */
8723 res.v_subtype = V_NOSUBTYPE;
8724
8725 res.v_type = val->v_type;
8726 switch (val->v_type) {
8727 case V_MAT:
8728 res.v_mat = matcopy(val->v_mat);
8729 matrandperm(res.v_mat);
8730 break;
8731 case V_LIST:
8732 res.v_list = listcopy(val->v_list);
8733 listrandperm(res.v_list);
8734 break;
8735 default:
8736 math_error("Bad argument type for randperm");
8737 /*NOTREACHED*/
8738 }
8739 return res;
8740 }
8741
8742
8743 S_FUNC VALUE
f_cmdbuf(void)8744 f_cmdbuf(void)
8745 {
8746 VALUE result;
8747 char *newcp;
8748 size_t cmdbuf_len; /* length of cmdbuf string */
8749
8750 /* initialize VALUE */
8751 result.v_type = V_STR;
8752 result.v_subtype = V_NOSUBTYPE;
8753
8754 cmdbuf_len = strlen(cmdbuf);
8755 newcp = (char *)malloc(cmdbuf_len+1);
8756 if (newcp == NULL) {
8757 math_error("Cannot allocate string in cmdbuf");
8758 /*NOTREACHED*/
8759 }
8760 strlcpy(newcp, cmdbuf, cmdbuf_len+1);
8761 result.v_str = makestring(newcp);
8762 return result;
8763 }
8764
8765
8766 S_FUNC VALUE
f_getenv(VALUE * v1)8767 f_getenv(VALUE *v1)
8768 {
8769 VALUE result;
8770 char *str;
8771
8772 /* initialize VALUE */
8773 result.v_subtype = V_NOSUBTYPE;
8774
8775 if (v1->v_type != V_STR) {
8776 math_error("Non-string argument for getenv");
8777 /*NOTREACHED*/
8778 }
8779 result.v_type = V_STR;
8780 str = getenv(v1->v_str->s_str);
8781 if (str == NULL)
8782 result.v_type = V_NULL;
8783 else
8784 result.v_str = makenewstring(str);
8785 return result;
8786 }
8787
8788
8789 S_FUNC VALUE
f_isatty(VALUE * vp)8790 f_isatty(VALUE *vp)
8791 {
8792 VALUE result;
8793
8794 /* initialize VALUE */
8795 result.v_subtype = V_NOSUBTYPE;
8796
8797 result.v_type = V_NUM;
8798 if (vp->v_type == V_FILE && isattyid(vp->v_file) == 1) {
8799 result.v_num = itoq(1);
8800 } else {
8801 result.v_num = itoq(0);
8802 }
8803 return result;
8804 }
8805
8806
8807 S_FUNC VALUE
f_calc_tty(void)8808 f_calc_tty(void)
8809 {
8810 VALUE res;
8811
8812 if (!calc_tty(FILEID_STDIN))
8813 return error_value(E_TTY);
8814 res.v_type = V_NULL;
8815 res.v_subtype = V_NOSUBTYPE;
8816 return res;
8817 }
8818
8819
8820 S_FUNC VALUE
f_inputlevel(void)8821 f_inputlevel (void)
8822 {
8823 VALUE result;
8824
8825 /* initialize VALUE */
8826 result.v_type = V_NUM;
8827 result.v_subtype = V_NOSUBTYPE;
8828
8829 result.v_num = itoq((long) inputlevel());
8830 return result;
8831 }
8832
8833
8834 S_FUNC VALUE
f_calclevel(void)8835 f_calclevel(void)
8836 {
8837 VALUE result;
8838
8839 /* initialize VALUE */
8840 result.v_type = V_NUM;
8841 result.v_subtype = V_NOSUBTYPE;
8842
8843 result.v_num = itoq(calclevel());
8844 return result;
8845 }
8846
8847
8848 S_FUNC VALUE
f_calcpath(void)8849 f_calcpath(void)
8850 {
8851 VALUE result;
8852
8853 /* initialize VALUE */
8854 result.v_type = V_STR;
8855 result.v_subtype = V_NOSUBTYPE;
8856
8857 result.v_str = makenewstring(calcpath);
8858 return result;
8859 }
8860
8861
8862 S_FUNC VALUE
f_access(int count,VALUE ** vals)8863 f_access(int count, VALUE **vals)
8864 {
8865 NUMBER *q;
8866 int m;
8867 char *s, *fname;
8868 VALUE result;
8869 size_t len;
8870 int i;
8871
8872 /* initialize VALUE */
8873 result.v_type = V_NULL;
8874 result.v_subtype = V_NOSUBTYPE;
8875
8876 errno = 0;
8877 if (vals[0]->v_type != V_STR)
8878 return error_value(E_ACCESS1);
8879 fname = vals[0]->v_str->s_str;
8880 m = 0;
8881 if (count == 2) {
8882 switch (vals[1]->v_type) {
8883 case V_NUM:
8884 q = vals[1]->v_num;
8885 if (qisfrac(q) || qisneg(q))
8886 return error_value(E_ACCESS2);
8887 m = (int)(q->num.v[0] & 7);
8888 break;
8889 case V_STR:
8890 s = vals[1]->v_str->s_str;
8891 len = (long)strlen(s);
8892 while (len-- > 0) {
8893 switch (*s++) {
8894 case 'r': m |= 4; break;
8895 case 'w': m |= 2; break;
8896 case 'x': m |= 1; break;
8897 default: return error_value(E_ACCESS2);
8898 }
8899 }
8900 break;
8901 case V_NULL:
8902 break;
8903 default:
8904 return error_value(E_ACCESS2);
8905 }
8906 }
8907 i = access(fname, m);
8908 if (i)
8909 return error_value(errno);
8910 return result;
8911 }
8912
8913
8914 S_FUNC VALUE
f_putenv(int count,VALUE ** vals)8915 f_putenv(int count, VALUE **vals)
8916 {
8917 VALUE result;
8918 char *putenv_str;
8919
8920 /* initialize VALUE */
8921 result.v_type = V_NUM;
8922 result.v_subtype = V_NOSUBTYPE;
8923
8924 /*
8925 * parse args
8926 */
8927 if (count == 2) {
8928 size_t snprintf_len; /* malloced snprintf buffer length */
8929
8930 /* firewall */
8931 if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) {
8932 math_error("Non-string argument for putenv");
8933 /*NOTREACHED*/
8934 }
8935
8936 /* convert putenv("foo","bar") into putenv("foo=bar") */
8937 snprintf_len = vals[0]->v_str->s_len + 1 +
8938 vals[1]->v_str->s_len;
8939 putenv_str = (char *)malloc(snprintf_len+1);
8940 if (putenv_str == NULL) {
8941 math_error("Cannot allocate string in putenv");
8942 /*NOTREACHED*/
8943 }
8944 /*
8945 * The next statement could be:
8946 *
8947 * snprintf(putenv_str, snprintf_len,
8948 * "%s=%s", vals[0]->v_str->s_str,
8949 * vals[1]->v_str->s_str);
8950 *
8951 * however compilers like gcc would issue warnings such as:
8952 *
8953 * null destination pointer
8954 *
8955 * even though we check that putenv_str is non-NULL
8956 * above before using it. Therefore we call strlcpy()
8957 * twice and make an assignment instead to avoid such warnings.
8958 */
8959 strlcpy(putenv_str,
8960 vals[0]->v_str->s_str,
8961 vals[0]->v_str->s_len+1);
8962 putenv_str[vals[0]->v_str->s_len] = '=';
8963 strlcpy(putenv_str + vals[0]->v_str->s_len + 1,
8964 vals[1]->v_str->s_str,
8965 vals[1]->v_str->s_len+1);
8966 putenv_str[snprintf_len] = '\0';
8967
8968 } else {
8969 /* firewall */
8970 if (vals[0]->v_type != V_STR) {
8971 math_error("Non-string argument for putenv");
8972 /*NOTREACHED*/
8973 }
8974
8975 /* putenv(arg) must be of the form "foo=bar" */
8976 if ((char *)strchr(vals[0]->v_str->s_str, '=') == NULL) {
8977 math_error("putenv single arg string missing =");
8978 /*NOTREACHED*/
8979 }
8980
8981 /*
8982 * make a copy of the arg because subsequent changes
8983 * would change the environment.
8984 */
8985 putenv_str = (char *)malloc(vals[0]->v_str->s_len + 1);
8986 if (putenv_str == NULL) {
8987 math_error("Cannot allocate string in putenv");
8988 /*NOTREACHED*/
8989 }
8990 strlcpy(putenv_str, vals[0]->v_str->s_str,
8991 vals[0]->v_str->s_len+1);
8992 }
8993
8994 /* return putenv result */
8995 result.v_num = itoq((long) malloced_putenv(putenv_str));
8996 return result;
8997 }
8998
8999
9000 S_FUNC VALUE
f_strpos(VALUE * haystack,VALUE * needle)9001 f_strpos(VALUE *haystack, VALUE *needle)
9002 {
9003 VALUE result;
9004 char *cpointer;
9005 int cindex;
9006
9007 /* initialize VALUE */
9008 result.v_type = V_NUM;
9009 result.v_subtype = V_NOSUBTYPE;
9010
9011 if (haystack->v_type != V_STR || needle->v_type != V_STR) {
9012 math_error("Non-string argument for index");
9013 /*NOTREACHED*/
9014 }
9015 cpointer = strstr(haystack->v_str->s_str,
9016 needle->v_str->s_str);
9017 if (cpointer == NULL)
9018 cindex = 0;
9019 else
9020 cindex = cpointer - haystack->v_str->s_str + 1;
9021 result.v_num = itoq((long) cindex);
9022 return result;
9023 }
9024
9025
9026 S_FUNC VALUE
f_system(VALUE * vp)9027 f_system(VALUE *vp)
9028 {
9029 VALUE result;
9030
9031 /* initialize VALUE */
9032 result.v_type = V_NUM;
9033 result.v_subtype = V_NOSUBTYPE;
9034
9035 if (vp->v_type != V_STR) {
9036 math_error("Non-string argument for system");
9037 /*NOTREACHED*/
9038 }
9039 if (!allow_exec) {
9040 math_error("execution disallowed by -m");
9041 /*NOTREACHED*/
9042 }
9043 if (conf->calc_debug & CALCDBG_SYSTEM) {
9044 printf("%s\n", vp->v_str->s_str);
9045 }
9046 #if defined(_WIN32) || defined(_WIN64)
9047 /* if the execute length is 0 then just return 0 */
9048 if (vp->v_str->s_len == 0) {
9049 result.v_num = itoq((long)0);
9050 } else {
9051 result.v_num = itoq((long)system(vp->v_str->s_str));
9052 }
9053 #else /* Windows free systems */
9054 result.v_num = itoq((long)system(vp->v_str->s_str));
9055 #endif /* Windows free systems */
9056 return result;
9057 }
9058
9059
9060 S_FUNC VALUE
f_sleep(int count,VALUE ** vals)9061 f_sleep(int count, VALUE **vals)
9062 {
9063 long time;
9064 VALUE res;
9065 NUMBER *q1, *q2;
9066
9067 res.v_type = V_NULL;
9068 res.v_subtype = V_NOSUBTYPE;
9069 #if !defined(_WIN32) && !defined(_WIN64)
9070 if (count > 0) {
9071 if (vals[0]->v_type != V_NUM || qisneg(vals[0]->v_num))
9072 return error_value(E_SLEEP);
9073 if (qisint(vals[0]->v_num)) {
9074 if (zge31b(vals[0]->v_num->num))
9075 return error_value(E_SLEEP);
9076 time = ztoi(vals[0]->v_num->num);
9077 time = sleep(time);
9078 }
9079 else {
9080 q1 = qscale(vals[0]->v_num, 20);
9081 q2 = qint(q1);
9082 qfree(q1);
9083 if (zge31b(q2->num)) {
9084 qfree(q2);
9085 return error_value(E_SLEEP);
9086 }
9087 time = ztoi(q2->num);
9088 qfree(q2);
9089 /* BSD 4.3 usleep has void return */
9090 usleep(time);
9091 return res;
9092 }
9093 } else {
9094 time = sleep(1);
9095 }
9096 if (time) {
9097 res.v_type = V_NUM;
9098 res.v_num = itoq(time);
9099 }
9100 #endif /* Windows free systems */
9101 return res;
9102 }
9103
9104
9105 /*
9106 * set the default output base/mode
9107 */
9108 S_FUNC NUMBER *
f_base(int count,NUMBER ** vals)9109 f_base(int count, NUMBER **vals)
9110 {
9111 long base; /* output base/mode */
9112 long oldbase=0; /* output base/mode */
9113
9114 /* deal with just a query */
9115 if (count != 1) {
9116 return base_value(conf->outmode, conf->outmode);
9117 }
9118
9119 /* deal with the special modes first */
9120 if (qisfrac(vals[0])) {
9121 return base_value(math_setmode(MODE_FRAC), conf->outmode);
9122 }
9123 if (vals[0]->num.len > 64/BASEB) {
9124 return base_value(math_setmode(MODE_EXP), conf->outmode);
9125 }
9126
9127 /* set the base, if possible */
9128 base = qtoi(vals[0]);
9129 switch (base) {
9130 case -10:
9131 oldbase = math_setmode(MODE_INT);
9132 break;
9133 case 2:
9134 oldbase = math_setmode(MODE_BINARY);
9135 break;
9136 case 8:
9137 oldbase = math_setmode(MODE_OCTAL);
9138 break;
9139 case 10:
9140 oldbase = math_setmode(MODE_REAL);
9141 break;
9142 case 16:
9143 oldbase = math_setmode(MODE_HEX);
9144 break;
9145 case 1000:
9146 oldbase = math_setmode(MODE_ENG);
9147 break;
9148 default:
9149 math_error("Unsupported base");
9150 /*NOTREACHED*/
9151 break;
9152 }
9153
9154 /* return the old base */
9155 return base_value(oldbase, conf->outmode);
9156 }
9157
9158
9159 /*
9160 * set the default secondary output base/mode
9161 */
9162 S_FUNC NUMBER *
f_base2(int count,NUMBER ** vals)9163 f_base2(int count, NUMBER **vals)
9164 {
9165 long base; /* output base/mode */
9166 long oldbase=0; /* output base/mode */
9167
9168 /* deal with just a query */
9169 if (count != 1) {
9170 return base_value(conf->outmode2, conf->outmode2);
9171 }
9172
9173 /* deal with the special modes first */
9174 if (qisfrac(vals[0])) {
9175 return base_value(math_setmode2(MODE_FRAC), conf->outmode2);
9176 }
9177 if (vals[0]->num.len > 64/BASEB) {
9178 return base_value(math_setmode2(MODE_EXP), conf->outmode2);
9179 }
9180
9181 /* set the base, if possible */
9182 base = qtoi(vals[0]);
9183 switch (base) {
9184 case 0:
9185 oldbase = math_setmode2(MODE2_OFF);
9186 break;
9187 case -10:
9188 oldbase = math_setmode2(MODE_INT);
9189 break;
9190 case 2:
9191 oldbase = math_setmode2(MODE_BINARY);
9192 break;
9193 case 8:
9194 oldbase = math_setmode2(MODE_OCTAL);
9195 break;
9196 case 10:
9197 oldbase = math_setmode2(MODE_REAL);
9198 break;
9199 case 16:
9200 oldbase = math_setmode2(MODE_HEX);
9201 break;
9202 case 1000:
9203 oldbase = math_setmode2(MODE_ENG);
9204 break;
9205 default:
9206 math_error("Unsupported base");
9207 /*NOTREACHED*/
9208 break;
9209 }
9210
9211 /* return the old base */
9212 return base_value(oldbase, conf->outmode2);
9213 }
9214
9215
9216 /*
9217 * return a numerical 'value' of the mode/base
9218 */
9219 S_FUNC NUMBER *
base_value(long mode,int defval)9220 base_value(long mode, int defval)
9221 {
9222 NUMBER *result;
9223
9224 /* return the old base */
9225 switch (mode) {
9226 case MODE_DEFAULT:
9227 switch (defval) {
9228 case MODE_DEFAULT:
9229 result = itoq(10);
9230 break;
9231 case MODE_FRAC:
9232 result = qalloc();
9233 itoz(3, &result->den);
9234 break;
9235 case MODE_INT:
9236 result = itoq(-10);
9237 break;
9238 case MODE_REAL:
9239 result = itoq(10);
9240 break;
9241 case MODE_EXP:
9242 result = qalloc();
9243 ztenpow(20, &result->num);
9244 break;
9245 case MODE_ENG:
9246 result = itoq(1000);
9247 break;
9248 case MODE_HEX:
9249 result = itoq(16);
9250 break;
9251 case MODE_OCTAL:
9252 result = itoq(8);
9253 break;
9254 case MODE_BINARY:
9255 result = itoq(2);
9256 break;
9257 case MODE2_OFF:
9258 result = itoq(0);
9259 break;
9260 default:
9261 result = itoq(0);
9262 break;
9263 }
9264 break;
9265 case MODE_FRAC:
9266 result = qalloc();
9267 itoz(3, &result->den);
9268 break;
9269 case MODE_INT:
9270 result = itoq(-10);
9271 break;
9272 case MODE_REAL:
9273 result = itoq(10);
9274 break;
9275 case MODE_EXP:
9276 result = qalloc();
9277 ztenpow(20, &result->num);
9278 break;
9279 case MODE_ENG:
9280 result = itoq(1000);
9281 break;
9282 case MODE_HEX:
9283 result = itoq(16);
9284 break;
9285 case MODE_OCTAL:
9286 result = itoq(8);
9287 break;
9288 case MODE_BINARY:
9289 result = itoq(2);
9290 break;
9291 case MODE2_OFF:
9292 result = itoq(0);
9293 break;
9294 default:
9295 result = itoq(0);
9296 break;
9297 }
9298 return result;
9299 }
9300
9301
9302 S_FUNC VALUE
f_custom(int count,VALUE ** vals)9303 f_custom(int count, VALUE **vals)
9304 {
9305 VALUE result;
9306
9307 /* initialize VALUE */
9308 result.v_type = V_NULL;
9309 result.v_subtype = V_NOSUBTYPE;
9310
9311 /*
9312 * disable custom functions unless -C was given
9313 */
9314 if (!allow_custom) {
9315 fprintf(stderr,
9316 #if defined(CUSTOM)
9317 "%sCalc must be run with a -C argument to "
9318 "use custom function\n",
9319 #else /* CUSTOM */
9320 "%sCalc was built with custom functions disabled\n",
9321 #endif /* CUSTOM */
9322 (conf->tab_ok ? "\t" : ""));
9323 return error_value(E_CUSTOM_ERROR);
9324 }
9325
9326 /*
9327 * perform the custom operation
9328 */
9329 if (count <= 0) {
9330 /* perform the usage function function */
9331 showcustom();
9332 } else {
9333 /* firewall */
9334 if (vals[0]->v_type != V_STR) {
9335 math_error("custom: 1st arg not a string name");
9336 /*NOTREACHED*/
9337 }
9338
9339 /* perform the custom function */
9340 result = custom(vals[0]->v_str->s_str, count-1, vals+1);
9341 }
9342
9343 /*
9344 * return the custom result
9345 */
9346 return result;
9347 }
9348
9349
9350 S_FUNC VALUE
f_blk(int count,VALUE ** vals)9351 f_blk(int count, VALUE **vals)
9352 {
9353 int len; /* number of octets to malloc */
9354 int chunk; /* block chunk size */
9355 VALUE result;
9356 int id;
9357 VALUE *vp = NULL;
9358 int type;
9359
9360 /* initialize VALUE */
9361 result.v_type = V_BLOCK;
9362 result.v_subtype = V_NOSUBTYPE;
9363
9364 type = V_NULL;
9365 if (count > 0) {
9366 vp = *vals;
9367 type = vp->v_type;
9368 if (type == V_STR || type == V_NBLOCK || type == V_BLOCK) {
9369 vals++;
9370 count--;
9371 }
9372 }
9373
9374 len = -1; /* signal to use old or zero len */
9375 chunk = -1; /* signal to use old or default chunksize */
9376 if (count > 0 && vals[0]->v_type != V_NULL) {
9377 /* parse len */
9378 if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num))
9379 return error_value(E_BLK1);
9380 if (qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num))
9381 return error_value(E_BLK2);
9382 len = qtoi(vals[0]->v_num);
9383 }
9384 if (count > 1 && vals[1]->v_type != V_NULL) {
9385 /* parse chunk */
9386 if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num))
9387 return error_value(E_BLK3);
9388 if (qisneg(vals[1]->v_num) || zge31b(vals[1]->v_num->num))
9389 return error_value(E_BLK4);
9390 chunk = qtoi(vals[1]->v_num);
9391 }
9392
9393 if (type == V_STR) {
9394 result.v_type = V_NBLOCK;
9395 id = findnblockid(vp->v_str->s_str);
9396 if (id < 0) {
9397 /* create new named block */
9398 result.v_nblock = createnblock(vp->v_str->s_str,
9399 len, chunk);
9400 return result;
9401 }
9402 /* reallocate nblock */
9403 result.v_nblock = reallocnblock(id, len, chunk);
9404 return result;
9405 }
9406
9407 if (type == V_NBLOCK) {
9408 /* reallocate nblock */
9409 result.v_type = V_NBLOCK;
9410 id = vp->v_nblock->id;
9411 result.v_nblock = reallocnblock(id, len, chunk);
9412 return result;
9413 }
9414 if (type == V_BLOCK) {
9415 /* reallocate block */
9416 result.v_type = V_BLOCK;
9417 result.v_block = copyrealloc(vp->v_block, len, chunk);
9418 return result;
9419 }
9420
9421 /* allocate block */
9422 result.v_block = blkalloc(len, chunk);
9423 return result;
9424 }
9425
9426
9427 S_FUNC VALUE
f_blkfree(VALUE * vp)9428 f_blkfree(VALUE *vp)
9429 {
9430 int id;
9431 VALUE result;
9432
9433 /* initialize VALUE */
9434 result.v_type = V_NULL;
9435 result.v_subtype = V_NOSUBTYPE;
9436
9437 id = 0;
9438 switch (vp->v_type) {
9439 case V_NBLOCK:
9440 id = vp->v_nblock->id;
9441 break;
9442 case V_STR:
9443 id = findnblockid(vp->v_str->s_str);
9444 if (id < 0)
9445 return error_value(E_BLKFREE1);
9446 break;
9447 case V_NUM:
9448 if (qisfrac(vp->v_num) || qisneg(vp->v_num))
9449 return error_value(E_BLKFREE2);
9450 if (zge31b(vp->v_num->num))
9451 return error_value(E_BLKFREE3);
9452 id = qtoi(vp->v_num);
9453 break;
9454 default:
9455 return error_value(E_BLKFREE4);
9456 }
9457 id = removenblock(id);
9458 if (id)
9459 return error_value(id);
9460 return result;
9461 }
9462
9463
9464 S_FUNC VALUE
f_blocks(int count,VALUE ** vals)9465 f_blocks(int count, VALUE **vals)
9466 {
9467 NBLOCK *nblk;
9468 VALUE result;
9469 int id;
9470
9471 /* initialize VALUE */
9472 result.v_subtype = V_NOSUBTYPE;
9473
9474 if (count == 0) {
9475 result.v_type = V_NUM;
9476 result.v_num = itoq((long) countnblocks());
9477 return result;
9478 }
9479 if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num))
9480 return error_value(E_BLOCKS1);
9481 id = (int) qtoi(vals[0]->v_num);
9482
9483 nblk = findnblock(id);
9484
9485 if (nblk == NULL) {
9486 return error_value(E_BLOCKS2);
9487 } else {
9488 result.v_type = V_NBLOCK;
9489 result.v_nblock = nblk;
9490 }
9491 return result;
9492 }
9493
9494
9495 S_FUNC VALUE
f_free(int count,VALUE ** vals)9496 f_free(int count, VALUE **vals)
9497 {
9498 VALUE result;
9499 VALUE *val;
9500
9501 /* initialize VALUE */
9502 result.v_subtype = V_NOSUBTYPE;
9503
9504 result.v_type = V_NULL;
9505 while (count-- > 0) {
9506 val = *vals++;
9507 if (val->v_type == V_ADDR)
9508 freevalue(val->v_addr);
9509 }
9510 return result;
9511 }
9512
9513
9514 S_FUNC VALUE
f_freeglobals(void)9515 f_freeglobals(void)
9516 {
9517 VALUE result;
9518
9519 /* initialize VALUE */
9520 result.v_type = V_NULL;
9521 result.v_subtype = V_NOSUBTYPE;
9522
9523 freeglobals();
9524 return result;
9525 }
9526
9527
9528 S_FUNC VALUE
f_freeredc(void)9529 f_freeredc(void)
9530 {
9531 VALUE result;
9532
9533 /* initialize VALUE */
9534 result.v_type = V_NULL;
9535 result.v_subtype = V_NOSUBTYPE;
9536
9537 freeredcdata();
9538 return result;
9539 }
9540
9541
9542 S_FUNC VALUE
f_freestatics(void)9543 f_freestatics(void)
9544 {
9545 VALUE result;
9546
9547 /* initialize VALUE */
9548 result.v_type = V_NULL;
9549 result.v_subtype = V_NOSUBTYPE;
9550
9551 freestatics();
9552 return result;
9553 }
9554
9555
9556 /*
9557 * f_copy - copy consecutive items between values
9558 *
9559 * copy(src, dst [, ssi [, num [, dsi]]])
9560 *
9561 * Copy 'num' consecutive items from 'src' with index 'ssi' to
9562 * 'dest', starting at position with index 'dsi'.
9563 */
9564 S_FUNC VALUE
f_copy(int count,VALUE ** vals)9565 f_copy(int count, VALUE **vals)
9566 {
9567 long ssi = 0; /* source start index */
9568 long num = -1; /* number of items to copy (-1 ==> all) */
9569 long dsi = -1; /* destination start index, -1 ==> default */
9570 int errtype; /* error type if unable to perform copy */
9571 VALUE result; /* null if successful */
9572
9573 /* initialize VALUE */
9574 result.v_type = V_NULL;
9575 result.v_subtype = V_NOSUBTYPE;
9576
9577 /*
9578 * parse args
9579 */
9580 switch(count) {
9581 case 5:
9582 /* parse dsi */
9583 if (vals[4]->v_type != V_NULL) {
9584 if (vals[4]->v_type != V_NUM ||
9585 qisfrac(vals[4]->v_num) ||
9586 qisneg(vals[4]->v_num)) {
9587 return error_value(E_COPY6);
9588 }
9589 if (zge31b(vals[4]->v_num->num)) {
9590 return error_value(E_COPY7);
9591 }
9592 dsi = qtoi(vals[4]->v_num);
9593 }
9594 /*FALLTHRU*/
9595
9596 case 4:
9597 /* parse num */
9598 if (vals[3]->v_type != V_NULL) {
9599 if (vals[3]->v_type != V_NUM ||
9600 qisfrac(vals[3]->v_num) ||
9601 qisneg(vals[3]->v_num)) {
9602 return error_value(E_COPY1);
9603 }
9604 if (zge31b(vals[3]->v_num->num)) {
9605 return error_value(E_COPY2);
9606 }
9607 num = qtoi(vals[3]->v_num);
9608 }
9609 /*FALLTHRU*/
9610
9611 case 3:
9612 /* parse ssi */
9613 if (vals[2]->v_type != V_NULL) {
9614 if (vals[2]->v_type != V_NUM ||
9615 qisfrac(vals[2]->v_num) ||
9616 qisneg(vals[2]->v_num)) {
9617 return error_value(E_COPY4);
9618 }
9619 if (zge31b(vals[2]->v_num->num)) {
9620 return error_value(E_COPY5);
9621 }
9622 ssi = qtoi(vals[2]->v_num);
9623 }
9624 break;
9625 }
9626
9627 /*
9628 * copy
9629 */
9630 errtype = copystod(vals[0], ssi, num, vals[1], dsi);
9631 if (errtype > 0)
9632 return error_value(errtype);
9633 return result;
9634 }
9635
9636
9637 /*
9638 * f_blkcpy - copy consecutive items between values
9639 *
9640 * copy(dst, src [, num [, dsi [, ssi]]])
9641 *
9642 * Copy 'num' consecutive items from 'src' with index 'ssi' to
9643 * 'dest', starting at position with index 'dsi'.
9644 */
9645 S_FUNC VALUE
f_blkcpy(int count,VALUE ** vals)9646 f_blkcpy(int count, VALUE **vals)
9647 {
9648 VALUE *args[5]; /* args to re-order */
9649 VALUE null_value; /* dummy argument */
9650
9651 /* initialize VALUE */
9652 null_value.v_subtype = V_NOSUBTYPE;
9653
9654 /*
9655 * parse args into f_copy order
9656 */
9657 args[0] = vals[1];
9658 args[1] = vals[0];
9659 null_value.v_type = V_NULL;
9660 args[2] = &null_value;
9661 args[3] = &null_value;
9662 args[4] = &null_value;
9663 switch(count) {
9664 case 5:
9665 args[2] = vals[4];
9666 args[4] = vals[3];
9667 args[3] = vals[2];
9668 break;
9669 case 4:
9670 count = 5;
9671 args[4] = vals[3];
9672 args[3] = vals[2];
9673 break;
9674 case 3:
9675 count = 4;
9676 args[3] = vals[2];
9677 break;
9678 }
9679
9680 /*
9681 * copy
9682 */
9683 return f_copy(count, args);
9684 }
9685
9686
9687 S_FUNC VALUE
f_sha1(int count,VALUE ** vals)9688 f_sha1(int count, VALUE **vals)
9689 {
9690 VALUE result;
9691 HASH *state; /* pointer to hash state to use */
9692 int i; /* vals[i] to hash */
9693
9694 /* initialize VALUE */
9695 result.v_subtype = V_NOSUBTYPE;
9696
9697 /*
9698 * arg check
9699 */
9700 if (count == 0) {
9701
9702 /* return an initial hash state */
9703 result.v_type = V_HASH;
9704 result.v_hash = hash_init(SHA1_HASH_TYPE, NULL);
9705
9706 } else if (count == 1 && vals[0]->v_type == V_HASH &&
9707 vals[0]->v_hash->hashtype == SHA1_HASH_TYPE) {
9708
9709 /* if just a hash value, finalize it */
9710 state = hash_copy(vals[0]->v_hash);
9711 result.v_type = V_NUM;
9712 result.v_num = qalloc();
9713 result.v_num->num = hash_final(state);
9714 hash_free(state);
9715
9716 } else {
9717
9718 /*
9719 * If the first value is a hash, use that as
9720 * the initial hash state
9721 */
9722 if (vals[0]->v_type == V_HASH &&
9723 vals[0]->v_hash->hashtype == SHA1_HASH_TYPE) {
9724 state = hash_copy(vals[0]->v_hash);
9725 i = 1;
9726
9727 /*
9728 * otherwise use the default initial state
9729 */
9730 } else {
9731 state = hash_init(SHA1_HASH_TYPE, NULL);
9732 i = 0;
9733 }
9734
9735 /*
9736 * hash the remaining values
9737 */
9738 do {
9739 state = hash_value(SHA1_HASH_TYPE, vals[i], state);
9740 } while (++i < count);
9741
9742 /*
9743 * return the current hash state
9744 */
9745 result.v_type = V_HASH;
9746 result.v_hash = state;
9747 }
9748
9749 /* return the result */
9750 return result;
9751 }
9752
9753
9754 S_FUNC VALUE
f_argv(int count,VALUE ** vals)9755 f_argv(int count, VALUE **vals)
9756 {
9757 int arg; /* the argv_value string index */
9758 VALUE result;
9759
9760 /* initialize VALUE */
9761 result.v_subtype = V_NOSUBTYPE;
9762
9763 /*
9764 * arg check
9765 */
9766 if (count == 0) {
9767
9768 /* return the argc count */
9769 result.v_type = V_NUM;
9770 result.v_num = itoq((long) argc_value);
9771
9772 } else {
9773
9774 /* firewall */
9775 if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) ||
9776 qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num)) {
9777
9778 math_error("argv argument must be a integer [0,2^31)");
9779 /*NOTREACHED*/
9780 }
9781
9782 /* determine the arg value of the argv() function */
9783 arg = qtoi(vals[0]->v_num);
9784
9785 /* argv(0) is program or script_name if -f filename was used */
9786 if (arg == 0) {
9787 if (script_name == NULL) {
9788 /* paranoia */
9789 result.v_type = V_NULL;
9790 } else {
9791 result.v_type = V_STR;
9792 result.v_str = makenewstring(script_name);
9793 }
9794
9795 /* return the n-th argv string */
9796 } else if (arg < argc_value && argv_value[arg-1] != NULL) {
9797 result.v_type = V_STR;
9798 result.v_str = makestring(strdup(argv_value[arg-1]));
9799 } else {
9800 result.v_type = V_NULL;
9801 }
9802 }
9803
9804 /* return the result */
9805 return result;
9806 }
9807
9808
9809 S_FUNC VALUE
f_version(void)9810 f_version(void)
9811 {
9812 VALUE result;
9813
9814 /* return the calc version string */
9815 result.v_type = V_STR;
9816 result.v_subtype = V_NOSUBTYPE;
9817 result.v_str = makestring(strdup(version()));
9818
9819 return result;
9820 }
9821
9822
9823 #endif /* !FUNCLIST */
9824
9825
9826 /*
9827 * builtins - List of primitive built-in functions
9828 *
9829 * NOTE: This table is also used by the help/Makefile builtin rule to
9830 * form the builtin help file. This rule will cause a sed script
9831 * to strip this table down into a just the information needed
9832 * to print builtin function list: b_name, b_minargs, b_maxargs
9833 * and b_desc. All other struct elements will be converted to 0.
9834 * The sed script expects to find entries of the form:
9835 *
9836 * {"...", number, number, stuff, stuff, stuff, stuff,
9837 * "...."},
9838 *
9839 * please keep this table in that form.
9840 *
9841 * For nice output, when the description of function (b_desc)
9842 * gets too long (extends into col 79) you should chop the
9843 * line and add "\n\t\t\t", that's newline and 3 tabs.
9844 * For example the description:
9845 *
9846 * ... very long description that goes beyond col 79
9847 *
9848 * should be written as:
9849 *
9850 * "... very long description that\n\t\t\tgoes beyond col 79"},
9851 *
9852 * fields:
9853 * b_name name of built-in function
9854 * b_minargs minimum number of arguments
9855 * b_maxargs maximum number of arguments
9856 * b_flags special handling flags
9857 * b_opcode opcode which makes the call quick
9858 * b_numfunc routine to calculate numeric function
9859 * b_valfunc routine to calculate general values
9860 * b_desc description of function
9861 */
9862 STATIC CONST struct builtin builtins[] = {
9863 {"abs", 1, 2, 0, OP_ABS, 0, 0,
9864 "absolute value within accuracy b"},
9865 {"access", 1, 2, 0, OP_NOP, 0, f_access,
9866 "determine accessibility of file a for mode b"},
9867 {"acos", 1, 2, 0, OP_NOP, 0, f_acos,
9868 "arccosine of a within accuracy b"},
9869 {"acosh", 1, 2, 0, OP_NOP, 0, f_acosh,
9870 "inverse hyperbolic cosine of a within accuracy b"},
9871 {"acot", 1, 2, 0, OP_NOP, 0, f_acot,
9872 "arccotangent of a within accuracy b"},
9873 {"acoth", 1, 2, 0, OP_NOP, 0, f_acoth,
9874 "inverse hyperbolic cotangent of a within accuracy b"},
9875 {"acsc", 1, 2, 0, OP_NOP, 0, f_acsc,
9876 "arccosecant of a within accuracy b"},
9877 {"acsch", 1, 2, 0, OP_NOP, 0, f_acsch,
9878 "inverse csch of a within accuracy b"},
9879 {"agd", 1, 2, 0, OP_NOP, 0, f_agd,
9880 "inverse Gudermannian function"},
9881 {"append", 1, IN, FA, OP_NOP, 0, f_listappend,
9882 "append values to end of list"},
9883 {"appr", 1, 3, 0, OP_NOP, 0, f_appr,
9884 "approximate a by multiple of b using rounding c"},
9885 {"arg", 1, 2, 0, OP_NOP, 0, f_arg,
9886 "argument (the angle) of complex number"},
9887 {"argv", 0, 1, 0, OP_NOP, 0, f_argv,
9888 "calc argc or argv string"},
9889 {"asec", 1, 2, 0, OP_NOP, 0, f_asec,
9890 "arcsecant of a within accuracy b"},
9891 {"asech", 1, 2, 0, OP_NOP, 0, f_asech,
9892 "inverse hyperbolic secant of a within accuracy b"},
9893 {"asin", 1, 2, 0, OP_NOP, 0, f_asin,
9894 "arcsine of a within accuracy b"},
9895 {"asinh", 1, 2, 0, OP_NOP, 0, f_asinh,
9896 "inverse hyperbolic sine of a within accuracy b"},
9897 {"assoc", 0, 0, 0, OP_NOP, 0, f_assoc,
9898 "create new association array"},
9899 {"atan", 1, 2, 0, OP_NOP, 0, f_atan,
9900 "arctangent of a within accuracy b"},
9901 {"atan2", 2, 3, FE, OP_NOP, qatan2, 0,
9902 "angle to point (b,a) within accuracy c"},
9903 {"atanh", 1, 2, 0, OP_NOP, 0, f_atanh,
9904 "inverse hyperbolic tangent of a within accuracy b"},
9905 {"avg", 0, IN, 0, OP_NOP, 0, f_avg,
9906 "arithmetic mean of values"},
9907 {"base", 0, 1, 0, OP_NOP, f_base, 0,
9908 "set default output base"},
9909 {"base2", 0, 1, 0, OP_NOP, f_base2, 0,
9910 "set default secondary output base"},
9911 {"bernoulli", 1, 1, 0, OP_NOP, 0, f_bern,
9912 "Bernoulli number for index a"},
9913 {"bit", 2, 2, 0, OP_BIT, 0, 0,
9914 "whether bit b in value a is set"},
9915 {"blk", 0, 3, 0, OP_NOP, 0, f_blk,
9916 "block with or without name, octet number, chunksize"},
9917 {"blkcpy", 2, 5, 0, OP_NOP, 0, f_blkcpy,
9918 "copy value to/from a block: blkcpy(d,s,len,di,si)"},
9919 {"blkfree", 1, 1, 0, OP_NOP, 0, f_blkfree,
9920 "free all storage from a named block"},
9921 {"blocks", 0, 1, 0, OP_NOP, 0, f_blocks,
9922 "named block with specified index, or null value"},
9923 {"bround", 1, 3, 0, OP_NOP, 0, f_bround,
9924 "round value a to b number of binary places"},
9925 {"btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0,
9926 "truncate a to b number of binary places"},
9927 {"calc_tty", 0, 0, 0, OP_NOP, 0, f_calc_tty,
9928 "set tty for interactivity"},
9929 {"calclevel", 0, 0, 0, OP_NOP, 0, f_calclevel,
9930 "current calculation level"},
9931 {"calcpath", 0, 0, 0, OP_NOP, 0, f_calcpath,
9932 "current CALCPATH search path value"},
9933 {"catalan", 1, 1, 0, OP_NOP, 0, f_catalan,
9934 "catalan number for index a"},
9935 {"ceil", 1, 1, 0, OP_NOP, 0, f_ceil,
9936 "smallest integer greater than or equal to number"},
9937 {"cfappr", 1, 3, 0, OP_NOP, f_cfappr, 0,
9938 "approximate a within accuracy b using\n"
9939 "\t\t\tcontinued fractions"},
9940 {"cfsim", 1, 2, 0, OP_NOP, f_cfsim, 0,
9941 "simplify number using continued fractions"},
9942 {"char", 1, 1, 0, OP_NOP, 0, f_char,
9943 "character corresponding to integer value"},
9944 {"cmdbuf", 0, 0, 0, OP_NOP, 0, f_cmdbuf,
9945 "command buffer"},
9946 {"cmp", 2, 2, 0, OP_CMP, 0, 0,
9947 "compare values returning -1, 0, or 1"},
9948 {"comb", 2, 2, 0, OP_NOP, 0, f_comb,
9949 "combinatorial number a!/b!(a-b)!"},
9950 {"config", 1, 2, 0, OP_SETCONFIG, 0, 0,
9951 "set or read configuration value"},
9952 {"conj", 1, 1, 0, OP_CONJUGATE, 0, 0,
9953 "complex conjugate of value"},
9954 {"copy", 2, 5, 0, OP_NOP, 0, f_copy,
9955 "copy value to/from a block: copy(s,d,len,si,di)"},
9956 {"cos", 1, 2, 0, OP_NOP, 0, f_cos,
9957 "cosine of value a within accuracy b"},
9958 {"cosh", 1, 2, 0, OP_NOP, 0, f_cosh,
9959 "hyperbolic cosine of a within accuracy b"},
9960 {"cot", 1, 2, 0, OP_NOP, 0, f_cot,
9961 "cotangent of a within accuracy b"},
9962 {"coth", 1, 2, 0, OP_NOP, 0, f_coth,
9963 "hyperbolic cotangent of a within accuracy b"},
9964 {"count", 2, 2, 0, OP_NOP, 0, f_count,
9965 "count listr/matrix elements satisfying some condition"},
9966 {"cp", 2, 2, 0, OP_NOP, 0, f_cp,
9967 "cross product of two vectors"},
9968 {"csc", 1, 2, 0, OP_NOP, 0, f_csc,
9969 "cosecant of a within accuracy b"},
9970 {"csch", 1, 2, 0, OP_NOP, 0, f_csch,
9971 "hyperbolic cosecant of a within accuracy b"},
9972 {"ctime", 0, 0, 0, OP_NOP, 0, f_ctime,
9973 "date and time as string"},
9974 {"custom", 0, IN, 0, OP_NOP, 0, f_custom,
9975 "custom builtin function interface"},
9976 {"d2dm", 3, 4, FA, OP_NOP, 0, f_d2dm,
9977 "convert a to b deg, c min, rounding type d\n"},
9978 {"d2dms", 4, 5, FA, OP_NOP, 0, f_d2dms,
9979 "convert a to b deg, c min, d sec, rounding type e\n"},
9980 {"d2g", 1, 2, 0, OP_NOP, 0, f_d2g,
9981 "convert degrees to gradians"},
9982 {"d2r", 1, 2, 0, OP_NOP, 0, f_d2r,
9983 "convert degrees to radians"},
9984 {"delete", 2, 2, FA, OP_NOP, 0, f_listdelete,
9985 "delete element from list a at position b"},
9986 {"den", 1, 1, 0, OP_DENOMINATOR, qden, 0,
9987 "denominator of fraction"},
9988 {"det", 1, 1, 0, OP_NOP, 0, f_det,
9989 "determinant of matrix"},
9990 {"digit", 2, 3, 0, OP_NOP, 0, f_digit,
9991 "digit at specified decimal place of number"},
9992 {"digits", 1, 2, 0, OP_NOP, 0, f_digits,
9993 "number of digits in base b representation of a"},
9994 {"display", 0, 1, 0, OP_NOP, 0, f_display,
9995 "number of decimal digits for displaying numbers"},
9996 {"dm2d", 2, 3, 0, OP_NOP, 0, f_dm2d,
9997 "convert a deg, b min to degrees, rounding type c\n"},
9998 {"dms2d", 3, 4, 0, OP_NOP, 0, f_dms2d,
9999 "convert a deg, b min, c sec to degrees, rounding type d\n"},
10000 {"dp", 2, 2, 0, OP_NOP, 0, f_dp,
10001 "dot product of two vectors"},
10002 {"epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0,
10003 "set or read allowed error for real calculations"},
10004 {"errcount", 0, 1, 0, OP_NOP, 0, f_errcount,
10005 "set or read error count"},
10006 {"errmax", 0, 1, 0, OP_NOP, 0, f_errmax,
10007 "set or read maximum for error count"},
10008 {"errno", 0, 1, 0, OP_NOP, 0, f_errno,
10009 "set or read calc_errno"},
10010 {"error", 0, 1, 0, OP_NOP, 0, f_error,
10011 "generate error value"},
10012 {"estr", 1, 1, 0, OP_NOP, 0, f_estr,
10013 "exact text string representation of value"},
10014 {"euler", 1, 1, 0, OP_NOP, 0, f_euler,
10015 "Euler number"},
10016 {"eval", 1, 1, 0, OP_NOP, 0, f_eval,
10017 "evaluate expression from string to value"},
10018 {"exp", 1, 2, 0, OP_NOP, 0, f_exp,
10019 "exponential of value a within accuracy b"},
10020 {"factor", 1, 3, 0, OP_NOP, f_factor, 0,
10021 "lowest prime factor < b of a, return c if error"},
10022 {"fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0,
10023 "count of times one number divides another"},
10024 {"fib", 1, 1, 0, OP_NOP, qfib, 0,
10025 "Fibonacci number F(n)"},
10026 {"forall", 2, 2, 0, OP_NOP, 0, f_forall,
10027 "do function for all elements of list or matrix"},
10028 {"frem", 2, 2, 0, OP_NOP, qfacrem, 0,
10029 "number with all occurrences of factor removed"},
10030 {"fact", 1, 1, 0, OP_NOP, 0, f_fact,
10031 "factorial"},
10032 {"fclose", 0, IN, 0, OP_NOP, 0, f_fclose,
10033 "close file"},
10034 {"feof", 1, 1, 0, OP_NOP, 0, f_feof,
10035 "whether EOF reached for file"},
10036 {"ferror", 1, 1, 0, OP_NOP, 0, f_ferror,
10037 "whether error occurred for file"},
10038 {"fflush", 0, IN, 0, OP_NOP, 0, f_fflush,
10039 "flush output to file(s)"},
10040 {"fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc,
10041 "read next char from file"},
10042 {"fgetfield", 1, 1, 0, OP_NOP, 0, f_fgetfield,
10043 "read next white-space delimited field from file"},
10044 {"fgetfile", 1, 1, 0, OP_NOP, 0, f_fgetfile,
10045 "read to end of file"},
10046 {"fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline,
10047 "read next line from file, newline removed"},
10048 {"fgets", 1, 1, 0, OP_NOP, 0, f_fgets,
10049 "read next line from file, newline is kept"},
10050 {"fgetstr", 1, 1, 0, OP_NOP, 0, f_fgetstr,
10051 "read next null-terminated string from file, null\n"
10052 "\t\t\tcharacter is kept"},
10053 {"files", 0, 1, 0, OP_NOP, 0, f_files,
10054 "return opened file or max number of opened files"},
10055 {"floor", 1, 1, 0, OP_NOP, 0, f_floor,
10056 "greatest integer less than or equal to number"},
10057 {"fopen", 2, 2, 0, OP_NOP, 0, f_fopen,
10058 "open file name a in mode b"},
10059 {"fpathopen", 2, 3, 0, OP_NOP, 0, f_fpathopen,
10060 "open file name a in mode b, search for a along\n"
10061 "\t\t\tCALCPATH or path c"},
10062 {"fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf,
10063 "print formatted output to opened file"},
10064 {"fputc", 2, 2, 0, OP_NOP, 0, f_fputc,
10065 "write a character to a file"},
10066 {"fputs", 2, IN, 0, OP_NOP, 0, f_fputs,
10067 "write one or more strings to a file"},
10068 {"fputstr", 2, IN, 0, OP_NOP, 0, f_fputstr,
10069 "write one or more null-terminated strings to a file"},
10070 {"free", 0, IN, FA, OP_NOP, 0, f_free,
10071 "free listed or all global variables"},
10072 {"freebernoulli", 0, 0, 0, OP_NOP, 0, f_freebern,
10073 "free stored Bernoulli numbers"},
10074 {"freeeuler", 0, 0, 0, OP_NOP, 0, f_freeeuler,
10075 "free stored Euler numbers"},
10076 {"freeglobals", 0, 0, 0, OP_NOP, 0, f_freeglobals,
10077 "free all global and visible static variables"},
10078 {"freeredc", 0, 0, 0, OP_NOP, 0, f_freeredc,
10079 "free redc data cache"},
10080 {"freestatics", 0, 0, 0, OP_NOP, 0, f_freestatics,
10081 "free all un-scoped static variables"},
10082 {"freopen", 2, 3, 0, OP_NOP, 0, f_freopen,
10083 "reopen a file stream to a named file"},
10084 {"fscan", 2, IN, FA, OP_NOP, 0, f_fscan,
10085 "scan a file for assignments to one or\n"
10086 "\t\t\tmore variables"},
10087 {"fscanf", 2, IN, FA, OP_NOP, 0, f_fscanf,
10088 "formatted scan of a file for assignment to one\n"
10089 "\t\t\tor more variables"},
10090 {"fseek", 2, 3, 0, OP_NOP, 0, f_fseek,
10091 "seek to position b (offset from c) in file a"},
10092 {"fsize", 1, 1, 0, OP_NOP, 0, f_fsize,
10093 "return the size of the file"},
10094 {"ftell", 1, 1, 0, OP_NOP, 0, f_ftell,
10095 "return the file position"},
10096 {"frac", 1, 1, 0, OP_FRAC, qfrac, 0,
10097 "fractional part of value"},
10098 {"g2d", 1, 2, 0, OP_NOP, 0, f_g2d,
10099 "convert gradians to degrees"},
10100 {"g2gm", 3, 4, FA, OP_NOP, 0, f_g2gm,
10101 "convert a to b grads, c min, rounding type d\n"},
10102 {"g2gms", 4, 5, FA, OP_NOP, 0, f_g2gms,
10103 "convert a to b grads, c min, d sec, rounding type e\n"},
10104 {"g2r", 1, 2, 0, OP_NOP, 0, f_g2r,
10105 "convert gradians to radians"},
10106 {"gcd", 1, IN, 0, OP_NOP, f_gcd, 0,
10107 "greatest common divisor"},
10108 {"gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0,
10109 "a divided repeatedly by gcd with b"},
10110 {"gd", 1, 2, 0, OP_NOP, 0, f_gd,
10111 "Gudermannian function"},
10112 {"getenv", 1, 1, 0, OP_NOP, 0, f_getenv,
10113 "value of environment variable (or NULL)"},
10114 {"gm2g", 2, 3, 0, OP_NOP, 0, f_gm2g,
10115 "convert a grads, b min to grads, rounding type c\n"},
10116 {"gms2g", 3, 4, 0, OP_NOP, 0, f_gms2g,
10117 "convert a grads, b min, c sec to grads, rounding type d\n"},
10118 {"h2hm", 3, 4, FA, OP_NOP, 0, f_h2hm,
10119 "convert a to b hours, c min, rounding type d\n"},
10120 {"h2hms", 4, 5, FA, OP_NOP, 0, f_h2hms,
10121 "convert a to b hours, c min, d sec, rounding type e\n"},
10122 {"hash", 1, IN, 0, OP_NOP, 0, f_hash,
10123 "return non-negative hash value for one or\n"
10124 "\t\t\tmore values"},
10125 {"head", 2, 2, 0, OP_NOP, 0, f_head,
10126 "return list of specified number at head of a list"},
10127 {"highbit", 1, 1, 0, OP_HIGHBIT, 0, 0,
10128 "high bit number in base 2 representation"},
10129 {"hm2h", 2, 3, 0, OP_NOP, 0, f_hm2h,
10130 "convert a hours, b min to hours, rounding type c\n"},
10131 {"hms2h", 3, 4, 0, OP_NOP, 0, f_hms2h,
10132 "convert a hours, b min, c sec to hours, rounding type d\n"},
10133 {"hmean", 0, IN, 0, OP_NOP, 0, f_hmean,
10134 "harmonic mean of values"},
10135 {"hnrmod", 4, 4, 0, OP_NOP, f_hnrmod, 0,
10136 "v mod h*2^n+r, h>0, n>0, r = -1, 0 or 1"},
10137 {"hypot", 2, 3, FE, OP_NOP, qhypot, 0,
10138 "hypotenuse of right triangle within accuracy c"},
10139 {"ilog", 2, 2, 0, OP_NOP, 0, f_ilog,
10140 "integral log of a to integral base b"},
10141 {"ilog10", 1, 1, 0, OP_NOP, 0, f_ilog10,
10142 "integral log of a number base 10"},
10143 {"ilog2", 1, 1, 0, OP_NOP, 0, f_ilog2,
10144 "integral log of a number base 2"},
10145 {"im", 1, 1, 0, OP_IM, 0, 0,
10146 "imaginary part of complex number"},
10147 {"indices", 2, 2, 0, OP_NOP, 0, f_indices,
10148 "indices of a specified assoc or mat value"},
10149 {"inputlevel", 0, 0, 0, OP_NOP, 0, f_inputlevel,
10150 "current input depth"},
10151 {"insert", 2, IN, FA, OP_NOP, 0, f_listinsert,
10152 "insert values c ... into list a at position b"},
10153 {"int", 1, 1, 0, OP_INT, qint, 0,
10154 "integer part of value"},
10155 {"inverse", 1, 1, 0, OP_INVERT, 0, 0,
10156 "multiplicative inverse of value"},
10157 {"iroot", 2, 2, 0, OP_NOP, qiroot, 0,
10158 "integer b'th root of a"},
10159 {"isassoc", 1, 1, 0, OP_ISASSOC, 0, 0,
10160 "whether a value is an association"},
10161 {"isatty", 1, 1, 0, OP_NOP, 0, f_isatty,
10162 "whether a file is a tty"},
10163 {"isblk", 1, 1, 0, OP_ISBLK, 0, 0,
10164 "whether a value is a block"},
10165 {"isconfig", 1, 1, 0, OP_ISCONFIG, 0, 0,
10166 "whether a value is a config state"},
10167 {"isdefined", 1, 1, 0, OP_ISDEFINED, 0, 0,
10168 "whether a string names a function"},
10169 {"iserror", 1, 1, 0, OP_NOP, 0, f_iserror,
10170 "where a value is an error"},
10171 {"iseven", 1, 1, 0, OP_ISEVEN, 0, 0,
10172 "whether a value is an even integer"},
10173 {"isfile", 1, 1, 0, OP_ISFILE, 0, 0,
10174 "whether a value is a file"},
10175 {"ishash", 1, 1, 0, OP_ISHASH, 0, 0,
10176 "whether a value is a hash state"},
10177 {"isident", 1, 1, 0, OP_NOP, 0, f_isident,
10178 "returns 1 if identity matrix"},
10179 {"isint", 1, 1, 0, OP_ISINT, 0, 0,
10180 "whether a value is an integer"},
10181 {"islist", 1, 1, 0, OP_ISLIST, 0, 0,
10182 "whether a value is a list"},
10183 {"ismat", 1, 1, 0, OP_ISMAT, 0, 0,
10184 "whether a value is a matrix"},
10185 {"ismult", 2, 2, 0, OP_NOP, f_ismult, 0,
10186 "whether a is a multiple of b"},
10187 {"isnull", 1, 1, 0, OP_ISNULL, 0, 0,
10188 "whether a value is the null value"},
10189 {"isnum", 1, 1, 0, OP_ISNUM, 0, 0,
10190 "whether a value is a number"},
10191 {"isobj", 1, 1, 0, OP_ISOBJ, 0, 0,
10192 "whether a value is an object"},
10193 {"isobjtype", 1, 1, 0, OP_ISOBJTYPE, 0,0,
10194 "whether a string names an object type"},
10195 {"isodd", 1, 1, 0, OP_ISODD, 0, 0,
10196 "whether a value is an odd integer"},
10197 {"isoctet", 1, 1, 0, OP_ISOCTET, 0, 0,
10198 "whether a value is an octet"},
10199 {"isprime", 1, 2, 0, OP_NOP, f_isprime, 0,
10200 "whether a is a small prime, return b if error"},
10201 {"isptr", 1, 1, 0, OP_ISPTR, 0, 0,
10202 "whether a value is a pointer"},
10203 {"isqrt", 1, 1, 0, OP_NOP, qisqrt, 0,
10204 "integer part of square root"},
10205 {"isrand", 1, 1, 0, OP_ISRAND, 0, 0,
10206 "whether a value is a subtractive 100 state"},
10207 {"israndom", 1, 1, 0, OP_ISRANDOM, 0, 0,
10208 "whether a value is a Blum state"},
10209 {"isreal", 1, 1, 0, OP_ISREAL, 0, 0,
10210 "whether a value is a real number"},
10211 {"isrel", 2, 2, 0, OP_NOP, f_isrel, 0,
10212 "whether two numbers are relatively prime"},
10213 {"isstr", 1, 1, 0, OP_ISSTR, 0, 0,
10214 "whether a value is a string"},
10215 {"issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0,
10216 "whether value is a simple type"},
10217 {"issq", 1, 1, 0, OP_NOP, f_issquare, 0,
10218 "whether or not number is a square"},
10219 {"istype", 2, 2, 0, OP_ISTYPE, 0, 0,
10220 "whether the type of a is same as the type of b"},
10221 {"jacobi", 2, 2, 0, OP_NOP, qjacobi, 0,
10222 "-1 => a is not quadratic residue mod b\n"
10223 "\t\t\t1 => b is composite, or a is quad residue of b"},
10224 {"join", 1, IN, 0, OP_NOP, 0, f_join,
10225 "join one or more lists into one list"},
10226 {"lcm", 1, IN, 0, OP_NOP, f_lcm, 0,
10227 "least common multiple"},
10228 {"lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0,
10229 "lcm of all integers up till number"},
10230 {"lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0,
10231 "lowest prime factor of a in first b primes"},
10232 {"links", 1, 1, 0, OP_LINKS, 0, 0,
10233 "links to number or string value"},
10234 {"list", 0, IN, 0, OP_NOP, 0, f_list,
10235 "create list of specified values"},
10236 {"ln", 1, 2, 0, OP_NOP, 0, f_ln,
10237 "natural logarithm of value a within accuracy b"},
10238 {"log", 1, 2, 0, OP_NOP, 0, f_log,
10239 "base 10 logarithm of value a within accuracy b"},
10240 {"lowbit", 1, 1, 0, OP_LOWBIT, 0, 0,
10241 "low bit number in base 2 representation"},
10242 {"ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0,
10243 "leg-to-leg of unit right triangle (sqrt(1 - a^2))"},
10244 {"makelist", 1, 1, 0, OP_NOP, 0, f_makelist,
10245 "create a list with a null elements"},
10246 {"matdim", 1, 1, 0, OP_NOP, 0, f_matdim,
10247 "number of dimensions of matrix"},
10248 {"matfill", 2, 3, FA, OP_NOP, 0, f_matfill,
10249 "fill matrix with value b (value c on diagonal)"},
10250 {"matmax", 2, 2, 0, OP_NOP, 0, f_matmax,
10251 "maximum index of matrix a dim b"},
10252 {"matmin", 2, 2, 0, OP_NOP, 0, f_matmin,
10253 "minimum index of matrix a dim b"},
10254 {"matsum", 1, 1, 0, OP_NOP, 0, f_matsum,
10255 "sum the numeric values in a matrix"},
10256 {"mattrace", 1, 1, 0, OP_NOP, 0, f_mattrace,
10257 "return the trace of a square matrix"},
10258 {"mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans,
10259 "transpose of matrix"},
10260 {"max", 0, IN, 0, OP_NOP, 0, f_max,
10261 "maximum value"},
10262 {"memsize", 1, 1, 0, OP_NOP, 0, f_memsize,
10263 "number of octets used by the value, including overhead"},
10264 {"meq", 3, 3, 0, OP_NOP, f_meq, 0,
10265 "whether a and b are equal modulo c"},
10266 {"min", 0, IN, 0, OP_NOP, 0, f_min,
10267 "minimum value"},
10268 {"minv", 2, 2, 0, OP_NOP, qminv, 0,
10269 "inverse of a modulo b"},
10270 {"mmin", 2, 2, 0, OP_NOP, 0, f_mmin,
10271 "a mod b value with smallest abs value"},
10272 {"mne", 3, 3, 0, OP_NOP, f_mne, 0,
10273 "whether a and b are not equal modulo c"},
10274 {"mod", 2, 3, 0, OP_NOP, 0, f_mod,
10275 "residue of a modulo b, rounding type c"},
10276 {"modify", 2, 2, FA, OP_NOP, 0, f_modify,
10277 "modify elements of a list or matrix"},
10278 {"name", 1, 1, 0, OP_NOP, 0, f_name,
10279 "name assigned to block or file"},
10280 {"near", 2, 3, 0, OP_NOP, f_near, 0,
10281 "sign of (abs(a-b) - c)"},
10282 {"newerror", 0, 1, 0, OP_NOP, 0, f_newerror,
10283 "create new error type with message a"},
10284 {"nextcand", 1, 5, 0, OP_NOP, f_nextcand, 0,
10285 "smallest value == d mod e > a, ptest(a,b,c) true"},
10286 {"nextprime", 1, 2, 0, OP_NOP, f_nprime, 0,
10287 "return next small prime, return b if err"},
10288 {"norm", 1, 1, 0, OP_NORM, 0, 0,
10289 "norm of a value (square of absolute value)"},
10290 {"null", 0, IN, 0, OP_NOP, 0, f_null,
10291 "null value"},
10292 {"num", 1, 1, 0, OP_NUMERATOR, qnum, 0,
10293 "numerator of fraction"},
10294 {"ord", 1, 1, 0, OP_NOP, 0, f_ord,
10295 "integer corresponding to character value"},
10296 {"isupper", 1, 1, 0, OP_NOP, 0, f_isupper,
10297 "whether character is upper case"},
10298 {"islower", 1, 1, 0, OP_NOP, 0, f_islower,
10299 "whether character is lower case"},
10300 {"isalnum", 1, 1, 0, OP_NOP, 0, f_isalnum,
10301 "whether character is alpha-numeric"},
10302 {"isalpha", 1, 1, 0, OP_NOP, 0, f_isalpha,
10303 "whether character is alphabetic"},
10304 {"iscntrl", 1, 1, 0, OP_NOP, 0, f_iscntrl,
10305 "whether character is a control character"},
10306 {"isdigit", 1, 1, 0, OP_NOP, 0, f_isdigit,
10307 "whether character is a digit"},
10308 {"isgraph", 1, 1, 0, OP_NOP, 0, f_isgraph,
10309 "whether character is a graphical character"},
10310 {"isprint", 1, 1, 0, OP_NOP, 0, f_isprint,
10311 "whether character is printable"},
10312 {"ispunct", 1, 1, 0, OP_NOP, 0, f_ispunct,
10313 "whether character is a punctuation"},
10314 {"isspace", 1, 1, 0, OP_NOP, 0, f_isspace,
10315 "whether character is a space character"},
10316 {"isxdigit", 1, 1, 0, OP_NOP, 0, f_isxdigit,
10317 "whether character is a hexadecimal digit"},
10318 {"param", 1, 1, 0, OP_ARGVALUE, 0, 0,
10319 "value of parameter n (or parameter count if n\n"
10320 "\t\t\tis zero)"},
10321 {"perm", 2, 2, 0, OP_NOP, qperm, 0,
10322 "permutation number a!/(a-b)!"},
10323 {"prevcand", 1, 5, 0, OP_NOP, f_prevcand, 0,
10324 "largest value == d mod e < a, ptest(a,b,c) true"},
10325 {"prevprime", 1, 2, 0, OP_NOP, f_pprime, 0,
10326 "return previous small prime, return b if err"},
10327 {"pfact", 1, 1, 0, OP_NOP, qpfact, 0,
10328 "product of primes up till number"},
10329 {"pi", 0, 1, FE, OP_NOP, qpi, 0,
10330 "value of pi accurate to within epsilon"},
10331 {"pix", 1, 2, 0, OP_NOP, f_pix, 0,
10332 "number of primes <= a < 2^32, return b if error"},
10333 {"places", 1, 2, 0, OP_NOP, 0, f_places,
10334 "places after \"decimal\" point (-1 if infinite)"},
10335 {"pmod", 3, 3, 0, OP_NOP, qpowermod,0,
10336 "mod of a power (a ^ b (mod c))"},
10337 {"polar", 2, 3, 0, OP_NOP, 0, f_polar,
10338 "complex value of polar coordinate (a * exp(b*1i))"},
10339 {"poly", 1, IN, 0, OP_NOP, 0, f_poly,
10340 "evaluates a polynomial given its coefficients\n"
10341 "\t\t\tor coefficient-list"},
10342 {"pop", 1, 1, FA, OP_NOP, 0, f_listpop,
10343 "pop value from front of list"},
10344 {"popcnt", 1, 2, 0, OP_NOP, f_popcnt, 0,
10345 "number of bits in a that match b (or 1)"},
10346 {"power", 2, 3, 0, OP_NOP, 0, f_power,
10347 "value a raised to the power b within accuracy c"},
10348 {"protect", 1, 3, FA, OP_NOP, 0, f_protect,
10349 "read or set protection level for variable"},
10350 {"ptest", 1, 3, 0, OP_NOP, f_primetest, 0,
10351 "probabilistic primality test"},
10352 {"printf", 1, IN, 0, OP_NOP, 0, f_printf,
10353 "print formatted output to stdout"},
10354 {"prompt", 1, 1, 0, OP_NOP, 0, f_prompt,
10355 "prompt for input line using value a"},
10356 {"push", 1, IN, FA, OP_NOP, 0, f_listpush,
10357 "push values onto front of list"},
10358 {"putenv", 1, 2, 0, OP_NOP, 0, f_putenv,
10359 "define an environment variable"},
10360 {"quo", 2, 3, 0, OP_NOP, 0, f_quo,
10361 "integer quotient of a by b, rounding type c"},
10362 {"quomod", 4, 5, FA, OP_NOP, 0, f_quomod,
10363 "set c and d to quotient and remainder of a\n"
10364 "\t\t\tdivided by b"},
10365 {"r2d", 1, 2, 0, OP_NOP, 0, f_r2d,
10366 "convert radians to degrees"},
10367 {"r2g", 1, 2, 0, OP_NOP, 0, f_r2g,
10368 "convert radians to gradians"},
10369 {"rand", 0, 2, 0, OP_NOP, f_rand, 0,
10370 "subtractive 100 random number [0,2^64), [0,a), or [a,b)"},
10371 {"randbit", 0, 1, 0, OP_NOP, f_randbit, 0,
10372 "subtractive 100 random number [0,2^a)"},
10373 {"random", 0, 2, 0, OP_NOP, f_random, 0,
10374 "Blum-Blum-Shub random number [0,2^64), [0,a), or [a,b)"},
10375 {"randombit", 0, 1, 0, OP_NOP, f_randombit, 0,
10376 "Blum-Blum-Sub random number [0,2^a)"},
10377 {"randperm", 1, 1, 0, OP_NOP, 0, f_randperm,
10378 "random permutation of a list or matrix"},
10379 {"rcin", 2, 2, 0, OP_NOP, qredcin, 0,
10380 "convert normal number a to REDC number mod b"},
10381 {"rcmul", 3, 3, 0, OP_NOP, qredcmul, 0,
10382 "multiply REDC numbers a and b mod c"},
10383 {"rcout", 2, 2, 0, OP_NOP, qredcout, 0,
10384 "convert REDC number a mod b to normal number"},
10385 {"rcpow", 3, 3, 0, OP_NOP, qredcpower, 0,
10386 "raise REDC number a to power b mod c"},
10387 {"rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0,
10388 "square REDC number a mod b"},
10389 {"re", 1, 1, 0, OP_RE, 0, 0,
10390 "real part of complex number"},
10391 {"remove", 1, 1, FA, OP_NOP, 0, f_listremove,
10392 "remove value from end of list"},
10393 {"reverse", 1, 1, 0, OP_NOP, 0, f_reverse,
10394 "reverse a copy of a matrix or list"},
10395 {"rewind", 0, IN, 0, OP_NOP, 0, f_rewind,
10396 "rewind file(s)"},
10397 {"rm", 1, IN, 0, OP_NOP, 0, f_rm,
10398 "remove file(s), -f turns off no-such-file errors"},
10399 {"root", 2, 3, 0, OP_NOP, 0, f_root,
10400 "value a taken to the b'th root within accuracy c"},
10401 {"round", 1, 3, 0, OP_NOP, 0, f_round,
10402 "round value a to b number of decimal places"},
10403 {"rsearch", 2, 4, 0, OP_NOP, 0, f_rsearch,
10404 "reverse search matrix or list for value b\n"
10405 "\t\t\tstarting at index c"},
10406 {"runtime", 0, 0, 0, OP_NOP, f_runtime, 0,
10407 "user and kernel mode CPU time in seconds"},
10408 {"saveval", 1, 1, 0, OP_SAVEVAL, 0, 0,
10409 "set flag for saving values"},
10410 {"scale", 2, 2, 0, OP_SCALE, 0, 0,
10411 "scale value up or down by a power of two"},
10412 {"scan", 1, IN, FA, OP_NOP, 0, f_scan,
10413 "scan standard input for assignment to one\n"
10414 "\t\t\tor more variables"},
10415 {"scanf", 2, IN, FA, OP_NOP, 0, f_scanf,
10416 "formatted scan of standard input for assignment\n"
10417 "\t\t\tto variables"},
10418 {"search", 2, 4, 0, OP_NOP, 0, f_search,
10419 "search matrix or list for value b starting\n"
10420 "\t\t\tat index c"},
10421 {"sec", 1, 2, 0, OP_NOP, 0, f_sec,
10422 "sec of a within accuracy b"},
10423 {"sech", 1, 2, 0, OP_NOP, 0, f_sech,
10424 "hyperbolic secant of a within accuracy b"},
10425 {"seed", 0, 0, 0, OP_NOP, f_seed, 0,
10426 "return a 64 bit seed for a pseudo-random generator"},
10427 {"segment", 2, 3, 0, OP_NOP, 0, f_segment,
10428 "specified segment of specified list"},
10429 {"select", 2, 2, 0, OP_NOP, 0, f_select,
10430 "form sublist of selected elements from list"},
10431 {"setbit", 2, 3, 0, OP_NOP, 0, f_setbit,
10432 "set specified bit in string"},
10433 {"sgn", 1, 1, 0, OP_SGN, qsign, 0,
10434 "sign of value (-1, 0, 1)"},
10435 {"sha1", 0, IN, 0, OP_NOP, 0, f_sha1,
10436 "Secure Hash Algorithm (SHS-1 FIPS Pub 180-1)"},
10437 {"sin", 1, 2, 0, OP_NOP, 0, f_sin,
10438 "sine of value a within accuracy b"},
10439 {"sinh", 1, 2, 0, OP_NOP, 0, f_sinh,
10440 "hyperbolic sine of a within accuracy b"},
10441 {"size", 1, 1, 0, OP_NOP, 0, f_size,
10442 "total number of elements in value"},
10443 {"sizeof", 1, 1, 0, OP_NOP, 0, f_sizeof,
10444 "number of octets used to hold the value"},
10445 {"sleep", 0, 1, 0, OP_NOP, 0, f_sleep,
10446 "suspend operation for a seconds"},
10447 {"sort", 1, 1, 0, OP_NOP, 0, f_sort,
10448 "sort a copy of a matrix or list"},
10449 {"sqrt", 1, 3, 0, OP_NOP, 0, f_sqrt,
10450 "square root of value a within accuracy b"},
10451 {"srand", 0, 1, 0, OP_NOP, 0, f_srand,
10452 "seed the rand() function"},
10453 {"srandom", 0, 4, 0, OP_NOP, 0, f_srandom,
10454 "seed the random() function"},
10455 {"ssq", 1, IN, 0, OP_NOP, 0, f_ssq,
10456 "sum of squares of values"},
10457 {"stoponerror", 0, 1, 0, OP_NOP, 0, f_stoponerror,
10458 "assign value to stoponerror flag"},
10459 {"str", 1, 1, 0, OP_NOP, 0, f_str,
10460 "simple value converted to string"},
10461 {"strtoupper", 1, 1, 0, OP_NOP, 0, f_strtoupper,
10462 "Make string upper case"},
10463 {"strtolower", 1, 1, 0, OP_NOP, 0, f_strtolower,
10464 "Make string lower case"},
10465 {"strcat", 1,IN, 0, OP_NOP, 0, f_strcat,
10466 "concatenate strings together"},
10467 {"strcmp", 2, 2, 0, OP_NOP, 0, f_strcmp,
10468 "compare two strings"},
10469 {"strcasecmp", 2, 2, 0, OP_NOP, 0, f_strcasecmp,
10470 "compare two strings case independent"},
10471 {"strcpy", 2, 2, 0, OP_NOP, 0, f_strcpy,
10472 "copy string to string"},
10473 {"strerror", 0, 1, 0, OP_NOP, 0, f_strerror,
10474 "string describing error type"},
10475 {"strlen", 1, 1, 0, OP_NOP, 0, f_strlen,
10476 "length of string"},
10477 {"strncmp", 3, 3, 0, OP_NOP, 0, f_strncmp,
10478 "compare strings a, b to c characters"},
10479 {"strncasecmp", 3, 3, 0, OP_NOP, 0, f_strncasecmp,
10480 "compare strings a, b to c characters case independent"},
10481 {"strncpy", 3, 3, 0, OP_NOP, 0, f_strncpy,
10482 "copy up to c characters from string to string"},
10483 {"strpos", 2, 2, 0, OP_NOP, 0, f_strpos,
10484 "index of first occurrence of b in a"},
10485 {"strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf,
10486 "return formatted output as a string"},
10487 {"strscan", 2, IN, FA, OP_NOP, 0, f_strscan,
10488 "scan a string for assignments to one or more variables"},
10489 {"strscanf", 2, IN, FA, OP_NOP, 0, f_strscanf,
10490 "formatted scan of string for assignments to variables"},
10491 {"substr", 3, 3, 0, OP_NOP, 0, f_substr,
10492 "substring of a from position b for c chars"},
10493 {"sum", 0, IN, 0, OP_NOP, 0, f_sum,
10494 "sum of list or object sums and/or other terms"},
10495 {"swap", 2, 2, 0, OP_SWAP, 0, 0,
10496 "swap values of variables a and b (can be dangerous)"},
10497 {"system", 1, 1, 0, OP_NOP, 0, f_system,
10498 "call Unix command"},
10499 {"systime", 0, 0, 0, OP_NOP, f_systime, 0,
10500 "kernel mode CPU time in seconds"},
10501 {"tail", 2, 2, 0, OP_NOP, 0, f_tail,
10502 "retain list of specified number at tail of list"},
10503 {"tan", 1, 2, 0, OP_NOP, 0, f_tan,
10504 "tangent of a within accuracy b"},
10505 {"tanh", 1, 2, 0, OP_NOP, 0, f_tanh,
10506 "hyperbolic tangent of a within accuracy b"},
10507 {"test", 1, 1, 0, OP_TEST, 0, 0,
10508 "test that value is nonzero"},
10509 {"time", 0, 0, 0, OP_NOP, f_time, 0,
10510 "number of seconds since 00:00:00 1 Jan 1970 UTC"},
10511 {"trunc", 1, 2, 0, OP_NOP, f_trunc, 0,
10512 "truncate a to b number of decimal places"},
10513 {"ungetc", 2, 2, 0, OP_NOP, 0, f_ungetc,
10514 "unget char read from file"},
10515 {"usertime", 0, 0, 0, OP_NOP, f_usertime, 0,
10516 "user mode CPU time in seconds"},
10517 {"version", 0, 0, 0, OP_NOP, 0, f_version,
10518 "calc version string"},
10519 {"xor", 1, IN, 0, OP_NOP, 0, f_xor,
10520 "logical xor"},
10521
10522 /* end of table */
10523 {NULL, 0, 0, 0, 0, 0, 0,
10524 NULL}
10525 };
10526
10527
10528 /*
10529 * Show the list of primitive built-in functions
10530 *
10531 * When FUNCLIST is defined, we are being compiled by rules from the help
10532 * sub-directory to form a program that will produce the main part of the
10533 * builtin help file.
10534 *
10535 * See the builtin rule in the help/Makefile for details.
10536 */
10537 #if defined(FUNCLIST)
10538 /*ARGSUSED*/
10539 int
main(int argc,char * argv[])10540 main(int argc, char *argv[])
10541 {
10542 CONST struct builtin *bp; /* current function */
10543
10544 printf("\nName\tArgs\tDescription\n\n");
10545 for (bp = builtins; bp->b_name; bp++) {
10546 printf("%-9s ", bp->b_name);
10547 if (bp->b_maxargs == IN)
10548 printf("%d+ ", bp->b_minargs);
10549 else if (bp->b_minargs == bp->b_maxargs)
10550 printf("%-6d", bp->b_minargs);
10551 else
10552 printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
10553 printf("%s\n", bp->b_desc);
10554 }
10555 printf("\n");
10556 return 0; /* exit(0); */
10557 }
10558 #else /* FUNCLIST */
10559 void
showbuiltins(void)10560 showbuiltins(void)
10561 {
10562 CONST struct builtin *bp; /* current function */
10563 int i;
10564
10565 printf("\nName\tArgs\tDescription\n\n");
10566 for (bp = builtins, i = 0; bp->b_name; bp++, i++) {
10567 printf("%-14s ", bp->b_name);
10568 if (bp->b_maxargs == IN)
10569 printf("%d+ ", bp->b_minargs);
10570 else if (bp->b_minargs == bp->b_maxargs)
10571 printf("%-6d", bp->b_minargs);
10572 else
10573 printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
10574 printf("%s\n", bp->b_desc);
10575 if (i == 32) {
10576 i = 0;
10577 if (getchar() == 27)
10578 break;
10579 }
10580 }
10581 printf("\n");
10582 }
10583 #endif /* FUNCLIST */
10584
10585
10586 #if !defined(FUNCLIST)
10587
10588 /*
10589 * Call a built-in function.
10590 * Arguments to the function are on the stack, but are not removed here.
10591 * Functions are either purely numeric, or else can take any value type.
10592 *
10593 * given:
10594 * index index on where to scan in builtin table
10595 * argcount number of args
10596 * stck arguments on the stack
10597 */
10598 VALUE
builtinfunc(long index,int argcount,VALUE * stck)10599 builtinfunc(long index, int argcount, VALUE *stck)
10600 {
10601 VALUE *sp; /* pointer to stack entries */
10602 VALUE **vpp; /* pointer to current value address */
10603 CONST struct builtin *bp; /* builtin function to be called */
10604 NUMBER *numargs[IN]; /* numeric arguments for function */
10605 VALUE *valargs[IN]; /* addresses of actual arguments */
10606 VALUE result; /* general result of function */
10607 long i;
10608
10609 if ((unsigned long)index >=
10610 (sizeof(builtins) / sizeof(builtins[0])) - 1) {
10611 math_error("Bad built-in function index");
10612 /*NOTREACHED*/
10613 }
10614 bp = &builtins[index];
10615 if (argcount < bp->b_minargs) {
10616 math_error("Too few arguments for builtin function \"%s\"",
10617 bp->b_name);
10618 /*NOTREACHED*/
10619 }
10620 if ((argcount > bp->b_maxargs) || (argcount > IN)) {
10621 math_error("Too many arguments for builtin function \"%s\"",
10622 bp->b_name);
10623 /*NOTREACHED*/
10624 }
10625 /*
10626 * If an address was passed, then point at the real variable,
10627 * otherwise point at the stack value itself (unless the function
10628 * is very special).
10629 */
10630 sp = stck - argcount + 1;
10631 vpp = valargs;
10632 for (i = argcount; i > 0; i--) {
10633 if ((sp->v_type != V_ADDR) || (bp->b_flags & FA))
10634 *vpp = sp;
10635 else
10636 *vpp = sp->v_addr;
10637 sp++;
10638 vpp++;
10639 }
10640 /*
10641 * Handle general values if the function accepts them.
10642 */
10643 if (bp->b_valfunc) {
10644 vpp = valargs;
10645 if ((bp->b_minargs == 1) && (bp->b_maxargs == 1))
10646 result = (*bp->b_valfunc)(vpp[0]);
10647 else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2))
10648 result = (*bp->b_valfunc)(vpp[0], vpp[1]);
10649 else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3))
10650 result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]);
10651 else if ((bp->b_minargs == 4) && (bp->b_maxargs == 4))
10652 result = (*bp->b_valfunc)(vpp[0],vpp[1],vpp[2],vpp[3]);
10653 else
10654 result = (*bp->b_valfunc)(argcount, vpp);
10655 return result;
10656 }
10657 /*
10658 * Function must be purely numeric, so handle that.
10659 */
10660 vpp = valargs;
10661 for (i = 0; i < argcount; i++) {
10662 if ((*vpp)->v_type != V_NUM) {
10663 math_error("Non-real argument for builtin function %s",
10664 bp->b_name);
10665 /*NOTREACHED*/
10666 }
10667 numargs[i] = (*vpp)->v_num;
10668 vpp++;
10669 }
10670 result.v_type = V_NUM;
10671 result.v_subtype = V_NOSUBTYPE;
10672 if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) {
10673 result.v_num = (*bp->b_numfunc)(argcount, numargs);
10674 return result;
10675 }
10676 if ((bp->b_flags & FE) && (argcount < bp->b_maxargs))
10677 numargs[argcount++] = conf->epsilon;
10678
10679 switch (argcount) {
10680 case 0:
10681 result.v_num = (*bp->b_numfunc)();
10682 break;
10683 case 1:
10684 result.v_num = (*bp->b_numfunc)(numargs[0]);
10685 break;
10686 case 2:
10687 result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]);
10688 break;
10689 case 3:
10690 result.v_num = (*bp->b_numfunc)(numargs[0],
10691 numargs[1], numargs[2]);
10692 break;
10693 case 4:
10694 result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1],
10695 numargs[2], numargs[3]);
10696 break;
10697 default:
10698 math_error("Bad builtin function call");
10699 /*NOTREACHED*/
10700 }
10701 return result;
10702 }
10703
10704
10705 /*
10706 * Return the index of a built-in function given its name.
10707 * Returns minus one if the name is not known.
10708 */
10709 int
getbuiltinfunc(char * name)10710 getbuiltinfunc(char *name)
10711 {
10712 CONST struct builtin *bp;
10713
10714 for (bp = builtins; bp->b_name; bp++) {
10715 if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0))
10716 return (bp - builtins);
10717 }
10718 return -1;
10719 }
10720
10721
10722 /*
10723 * Given the index of a built-in function, return its name.
10724 */
10725 char *
builtinname(long index)10726 builtinname(long index)
10727 {
10728 if ((unsigned long)index >=
10729 (sizeof(builtins) / sizeof(builtins[0])) - 1)
10730 return "";
10731 return builtins[index].b_name;
10732 }
10733
10734
10735 /*
10736 * Given the index of a built-in function, and the number of arguments seen,
10737 * determine if the number of arguments are legal. This routine is called
10738 * during parsing time.
10739 */
10740 void
builtincheck(long index,int count)10741 builtincheck(long index, int count)
10742 {
10743 CONST struct builtin *bp;
10744
10745 if ((unsigned long)index >=
10746 (sizeof(builtins) / sizeof(builtins[0])) - 1) {
10747 math_error("Unknown built in index");
10748 /*NOTREACHED*/
10749 }
10750 bp = &builtins[index];
10751 if (count < bp->b_minargs)
10752 scanerror(T_NULL,
10753 "Too few arguments for builtin function \"%s\"",
10754 bp->b_name);
10755 if (count > bp->b_maxargs)
10756 scanerror(T_NULL,
10757 "Too many arguments for builtin function \"%s\"",
10758 bp->b_name);
10759 }
10760
10761
10762 /*
10763 * Return the opcode for a built-in function that can be used to avoid
10764 * the function call at all.
10765 */
10766 int
builtinopcode(long index)10767 builtinopcode(long index)
10768 {
10769 if ((unsigned long)index >=
10770 (sizeof(builtins) / sizeof(builtins[0])) - 1)
10771 return OP_NOP;
10772 return builtins[index].b_opcode;
10773 }
10774
10775 /*
10776 * Show the error-values created by newerror(str).
10777 */
10778 void
showerrors(void)10779 showerrors(void)
10780 {
10781 int i;
10782
10783 if (nexterrnum == E_USERDEF)
10784 printf("No new error-values created\n");
10785 for (i = E_USERDEF; i < nexterrnum; i++)
10786 printf("%d: %s\n", i,
10787 namestr(&newerrorstr, i - E_USERDEF));
10788 }
10789
10790
10791 /*
10792 * malloced_putenv - Keep track of malloced environment variable storage
10793 *
10794 * given:
10795 * str a malloced string which will be given to putenv
10796 *
10797 * returns:
10798 * putenv() return value
10799 *
10800 * NOTE: The caller MUST pass a string that the caller has previously malloced.
10801 */
10802 S_FUNC int
malloced_putenv(char * str)10803 malloced_putenv(char *str)
10804 {
10805 char *value; /* location of the value part of the str argument */
10806 char *old_val; /* previously stored (or inherited) env value */
10807 int found_cnt; /* number of active env_pool entries found */
10808 struct env_pool *new; /* new e_pool */
10809 int i;
10810
10811 /*
10812 * firewall
10813 */
10814 if (str == NULL) {
10815 math_error("malloced_putenv given a NULL pointer!!");
10816 /*NOTREACHED*/
10817 }
10818 if (str[0] == '=') {
10819 math_error("malloced_putenv = is first character in string!!");
10820 /*NOTREACHED*/
10821 }
10822
10823 /*
10824 * determine the place where getenv would return
10825 */
10826 value = strchr(str, '=');
10827 if (value == NULL) {
10828 math_error("malloced_putenv = not found in string!!");
10829 /*NOTREACHED*/
10830 }
10831 ++value;
10832
10833 /*
10834 * lookup for an existing environment value
10835 */
10836 *(value-1) = '\0';
10837 old_val = getenv(str);
10838 *(value-1) = '=';
10839
10840 /*
10841 * If we have the value in our environment, look for a
10842 * previously malloced string and free it
10843 */
10844 if (old_val != NULL && env_pool_cnt > 0) {
10845 for (i=0, found_cnt=0;
10846 i < env_pool_max && found_cnt < env_pool_cnt;
10847 ++i) {
10848
10849 /* skip an unused entry */
10850 if (e_pool[i].getenv == NULL) {
10851 continue;
10852 }
10853 ++found_cnt;
10854
10855 /* look for the 1st match */
10856 if (e_pool[i].getenv == value) {
10857
10858 /* found match, free the storage */
10859 if (e_pool[i].putenv != NULL) {
10860 free(e_pool[i].putenv);
10861 }
10862 e_pool[i].getenv = NULL;
10863 --env_pool_cnt;
10864 break;
10865 }
10866 }
10867 }
10868
10869 /*
10870 * ensure that we have room in the e_pool
10871 */
10872 if (env_pool_max == 0) {
10873
10874 /* allocate an initial pool (with one extra guard value) */
10875 new = (struct env_pool *)malloc((ENV_POOL_CHUNK+1) *
10876 sizeof(struct env_pool));
10877 if (new == NULL) {
10878 math_error("malloced_putenv malloc failed");
10879 /*NOTREACHED*/
10880 }
10881 e_pool = new;
10882 env_pool_max = ENV_POOL_CHUNK;
10883 for (i=0; i <= ENV_POOL_CHUNK; ++i) {
10884 e_pool[i].getenv = NULL;
10885 }
10886
10887 } else if (env_pool_cnt >= env_pool_max) {
10888
10889 /* expand the current pool (with one extra guard value) */
10890 new = (struct env_pool *)realloc(e_pool,
10891 (env_pool_max+ENV_POOL_CHUNK+1) *
10892 sizeof(struct env_pool));
10893 if (new == NULL) {
10894 math_error("malloced_putenv realloc failed");
10895 /*NOTREACHED*/
10896 }
10897 e_pool = new;
10898 for (i=env_pool_max; i <= env_pool_max + ENV_POOL_CHUNK; ++i) {
10899 e_pool[i].getenv = NULL;
10900 }
10901 env_pool_max += ENV_POOL_CHUNK;
10902 }
10903
10904 /*
10905 * store our data into the first e_pool entry
10906 */
10907 for (i=0; i < env_pool_max; ++i) {
10908
10909 /* skip used entries */
10910 if (e_pool[i].getenv != NULL) {
10911 continue;
10912 }
10913
10914 /* store in this free entry and stop looping */
10915 e_pool[i].getenv = value;
10916 e_pool[i].putenv = str;
10917 ++env_pool_cnt;
10918 break;
10919 }
10920 if (i >= env_pool_max) {
10921 math_error("malloced_putenv missed unused entry!!");
10922 /*NOTREACHED*/
10923 }
10924
10925 /*
10926 * finally, do the putenv action
10927 */
10928 return putenv(str);
10929 }
10930
10931
10932 #endif /* FUNCLIST */
10933