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