/* * func - built-in functions implemented here * * Copyright (C) 1999-2007 David I. Bell, Landon Curt Noll and Ernest Bowen * * Primary author: David I. Bell * * Calc is open software; you can redistribute it and/or modify it under * the terms of the version 2.1 of the GNU Lesser General Public License * as published by the Free Software Foundation. * * Calc is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General * Public License for more details. * * A copy of version 2.1 of the GNU Lesser General Public License is * distributed with calc under the filename COPYING-LGPL. You should have * received a copy with calc; if not, write to Free Software Foundation, Inc. * 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. * * @(#) $Revision: 29.33 $ * @(#) $Id: func.c,v 29.33 2007/02/11 10:19:14 chongo Exp $ * @(#) $Source: /usr/local/src/cmd/calc/RCS/func.c,v $ * * Under source code control: 1990/02/15 01:48:15 * File existed as early as: before 1990 * * Share and enjoy! :-) http://www.isthe.com/chongo/tech/comp/calc/ */ #include #include #include #include #if defined(_WIN32) # include # define _access access #endif #if defined(FUNCLIST) #define CONST /* disabled for FUNCLIST in case NATIVE_CC doesn't have it */ #undef HAVE_CONST #include "decl.h" #else /* FUNCLIST */ #include "decl.h" #include "have_unistd.h" #if defined(HAVE_UNISTD_H) #include #endif #include "have_stdlib.h" #if defined(HAVE_STDLIB_H) #include #endif #include "have_string.h" #if defined(HAVE_STRING_H) #include #endif #include "have_times.h" #if defined(HAVE_TIME_H) #include #endif #if defined(HAVE_TIMES_H) #include #endif #if defined(HAVE_SYS_TIME_H) #include #endif #if defined(HAVE_SYS_TIMES_H) #include #endif #include "have_strdup.h" #if !defined(HAVE_STRDUP) # define strdup(x) calc_strdup((CONST char *)(x)) #endif #include "have_rusage.h" #if defined(HAVE_GETRUSAGE) # include #endif #include "have_const.h" #include "have_unused.h" #include "calc.h" #include "calcerr.h" #include "opcodes.h" #include "token.h" #include "func.h" #include "string.h" #include "symbol.h" #include "prime.h" #include "file.h" #include "zrand.h" #include "zrandom.h" #include "custom.h" #if defined(CUSTOM) # define E_CUSTOM_ERROR E_NO_C_ARG #else # define E_CUSTOM_ERROR E_NO_CUSTOM #endif /* * forward declarations */ S_FUNC NUMBER *base_value(long mode, int defval); S_FUNC int strscan(char *s, int count, VALUE **vals); S_FUNC int filescan(FILEID id, int count, VALUE **vals); S_FUNC VALUE f_eval(VALUE *vp); S_FUNC VALUE f_fsize(VALUE *vp); S_FUNC int malloced_putenv(char *str); /* * external declarations */ EXTERN char cmdbuf[]; /* command line expression */ EXTERN CONST char *error_table[E__COUNT+2]; /* calc coded error messages */ E_FUNC void matrandperm(MATRIX *M); E_FUNC void listrandperm(LIST *lp); E_FUNC int idungetc(FILEID id, int ch); E_FUNC LIST* associndices(ASSOC *ap, long index); E_FUNC LIST* matindices(MATRIX *mp, long index); /* * malloced environment storage */ #define ENV_POOL_CHUNK 10 /* env_pool elements to allocate at a time */ struct env_pool { char *getenv; /* what getenv() would return, NULL => unused */ char *putenv; /* pointer given to putenv() */ }; STATIC int env_pool_cnt = 0; /* number of env_pool elements in use */ STATIC int env_pool_max = 0; /* number of env_pool elements allocated */ STATIC struct env_pool *e_pool = NULL; /* env_pool elements */ /* * user-defined error strings */ STATIC short nexterrnum = E_USERDEF; STATIC STRINGHEAD newerrorstr; #endif /* !FUNCLIST */ /* * arg count definitions */ #define IN 1024 /* maximum number of arguments */ #define FE 0x01 /* flag to indicate default epsilon argument */ #define FA 0x02 /* preserve addresses of variables */ /* * builtins - List of primitive built-in functions */ struct builtin { char *b_name; /* name of built-in function */ short b_minargs; /* minimum number of arguments */ short b_maxargs; /* maximum number of arguments */ short b_flags; /* special handling flags */ short b_opcode; /* opcode which makes the call quick */ NUMBER *(*b_numfunc)(); /* routine to calculate numeric function */ VALUE (*b_valfunc)(); /* routine to calculate general values */ char *b_desc; /* description of function */ }; #if !defined(FUNCLIST) S_FUNC VALUE f_eval(VALUE *vp) { FUNC *oldfunc; FUNC *newfunc; VALUE result; char *str; size_t num; long temp_stoponerror; /* temp value of stoponerror */ if (vp->v_type != V_STR) return error_value(E_EVAL2); str = vp->v_str->s_str; num = vp->v_str->s_len; switch (openstring(str, num)) { case -2: return error_value(E_EVAL3); case -1: return error_value(E_EVAL4); } oldfunc = curfunc; enterfilescope(); temp_stoponerror = stoponerror; stoponerror = -1; if (evaluate(TRUE)) { stoponerror = temp_stoponerror; closeinput(); exitfilescope(); freevalue(stack--); newfunc = curfunc; curfunc = oldfunc; result = newfunc->f_savedvalue; newfunc->f_savedvalue.v_type = V_NULL; newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE; freenumbers(newfunc); if (newfunc != oldfunc) free(newfunc); return result; } stoponerror = temp_stoponerror; closeinput(); exitfilescope(); newfunc = curfunc; curfunc = oldfunc; freevalue(&newfunc->f_savedvalue); newfunc->f_savedvalue.v_type = V_NULL; newfunc->f_savedvalue.v_subtype = V_NOSUBTYPE; freenumbers(newfunc); if (newfunc != oldfunc) free(newfunc); return error_value(E_EVAL); } S_FUNC VALUE f_prompt(VALUE *vp) { VALUE result; char *cp; char *newcp; size_t len; /* initialize VALUE */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; openterminal(); printvalue(vp, PRINT_SHORT); math_flush(); cp = nextline(); closeinput(); if (cp == NULL) { result.v_type = V_NULL; return result; } if (*cp == '\0') { result.v_str = slink(&_nullstring_); return result; } len = strlen(cp); newcp = (char *) malloc(len + 1); if (newcp == NULL) { math_error("Cannot allocate string"); /*NOTREACHED*/ } strncpy(newcp, cp, len+1); result.v_str = makestring(newcp); return result; } S_FUNC VALUE f_display(int count, VALUE **vals) { LEN oldvalue; VALUE res; /* initialize VALUE */ res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; oldvalue = conf->outdigits; if (count > 0) { if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) || qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num)) fprintf(stderr, "Out-of-range arg for display ignored\n"); else conf->outdigits = (LEN) qtoi(vals[0]->v_num); } res.v_num = itoq((long) oldvalue); return res; } /*ARGSUSED*/ S_FUNC VALUE f_null(int UNUSED count, VALUE UNUSED **vals) { VALUE res; /* initialize VALUE */ res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_str(VALUE *vp) { VALUE result; char *cp; /* initialize VALUE */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; switch (vp->v_type) { case V_STR: result.v_str = makenewstring(vp->v_str->s_str); break; case V_NULL: result.v_str = slink(&_nullstring_); break; case V_OCTET: result.v_str = charstring(*vp->v_octet); break; case V_NUM: math_divertio(); qprintnum(vp->v_num, MODE_DEFAULT); cp = math_getdivertedio(); result.v_str = makestring(cp); break; case V_COM: math_divertio(); comprint(vp->v_com); cp = math_getdivertedio(); result.v_str = makestring(cp); break; default: return error_value(E_STR); } return result; } S_FUNC VALUE f_estr(VALUE *vp) { VALUE result; char *cp; /* initialize result */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; math_divertio(); printestr(vp); cp = math_getdivertedio(); result.v_str = makestring(cp); return result; } S_FUNC VALUE f_name(VALUE *vp) { VALUE result; char *cp; char *name; /* initialize VALUE */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; switch (vp->v_type) { case V_NBLOCK: result.v_type = V_STR; result.v_str = makenewstring(vp->v_nblock->name); return result; case V_FILE: name = findfname(vp->v_file); if (name == NULL) { result.v_type = V_NULL; return result; } math_divertio(); math_str(name); cp = math_getdivertedio(); break; default: result.v_type = V_NULL; return result; } result.v_str = makestring(cp); return result; } S_FUNC VALUE f_poly(int count, VALUE **vals) { VALUE *x; VALUE result, tmp; LIST *clist, *lp; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type == V_LIST) { clist = vals[0]->v_list; lp = listalloc(); while (--count > 0) { if ((*++vals)->v_type == V_LIST) insertitems(lp, (*vals)->v_list); else insertlistlast(lp, *vals); } if (!evalpoly(clist, lp->l_first, &result)) { result.v_type = V_NUM; result.v_num = qlink(&_qzero_); } listfree(lp); return result; } x = vals[--count]; copyvalue(*vals++, &result); while (--count > 0) { mulvalue(&result, x, &tmp); freevalue(&result); addvalue(*vals++, &tmp, &result); freevalue(&tmp); } return result; } S_FUNC NUMBER * f_mne(NUMBER *val1, NUMBER *val2, NUMBER *val3) { NUMBER *tmp, *res; tmp = qsub(val1, val2); res = itoq((long) !qdivides(tmp, val3)); qfree(tmp); return res; } S_FUNC NUMBER * f_isrel(NUMBER *val1, NUMBER *val2) { if (qisfrac(val1) || qisfrac(val2)) { math_error("Non-integer for isrel"); /*NOTREACHED*/ } return itoq((long) zrelprime(val1->num, val2->num)); } S_FUNC NUMBER * f_issquare(NUMBER *vp) { return itoq((long) qissquare(vp)); } S_FUNC NUMBER * f_isprime(int count, NUMBER **vals) { NUMBER *err; /* error return, NULL => use math_error */ /* determine the way we report problems */ if (count == 2) { if (qisfrac(vals[1])) { math_error("2nd isprime arg must be an integer"); /*NOTREACHED*/ } err = vals[1]; } else { err = NULL; } /* firewall - must be an integer */ if (qisfrac(vals[0])) { if (err) { return qlink(err); } math_error("non-integral arg for builtin function isprime"); /*NOTREACHED*/ } /* test the integer */ switch (zisprime(vals[0]->num)) { case 0: return qlink(&_qzero_); case 1: return qlink(&_qone_); } /* error return */ if (!err) { math_error("isprime argument is an odd value > 2^32"); /*NOTREACHED*/ } return qlink(err); } S_FUNC NUMBER * f_nprime(int count, NUMBER **vals) { NUMBER *err; /* error return, NULL => use math_error */ FULL nxt_prime; /* next prime or 0 */ /* determine the way we report problems */ if (count == 2) { if (qisfrac(vals[1])) { math_error("2nd nextprime arg must be an integer"); /*NOTREACHED*/ } err = vals[1]; } else { err = NULL; } /* firewall - must be an integer */ if (qisfrac(vals[0])) { if (err) { return qlink(err); } math_error("non-integral arg 1 for builtin function nextprime"); /*NOTREACHED*/ } /* test the integer */ nxt_prime = znprime(vals[0]->num); if (nxt_prime > 1) { return utoq(nxt_prime); } else if (nxt_prime == 0) { /* return 2^32+15 */ return qlink(&_nxtprime_); } /* error return */ if (!err) { math_error("nextprime arg 1 is >= 2^32"); /*NOTREACHED*/ } return qlink(err); } S_FUNC NUMBER * f_pprime(int count, NUMBER **vals) { NUMBER *err; /* error return, NULL => use math_error */ FULL prev_prime; /* previous prime or 0 */ /* determine the way we report problems */ if (count == 2) { if (qisfrac(vals[1])) { math_error("2nd prevprime arg must be an integer"); /*NOTREACHED*/ } err = vals[1]; } else { err = NULL; } /* firewall - must be an integer */ if (qisfrac(vals[0])) { if (err) { return qlink(err); } math_error("non-integral arg 1 for builtin function prevprime"); /*NOTREACHED*/ } /* test the integer */ prev_prime = zpprime(vals[0]->num); if (prev_prime > 1) { return utoq(prev_prime); } if (prev_prime == 0) { return qlink(&_qzero_); } /* error return */ if (!err) { if (prev_prime == 0) { math_error("prevprime arg 1 is <= 2"); /*NOTREACHED*/ } else { math_error("prevprime arg 1 is >= 2^32"); /*NOTREACHED*/ } } return qlink(err); } S_FUNC NUMBER * f_factor(int count, NUMBER **vals) { NUMBER *err; /* error return, NULL => use math_error */ ZVALUE limit; /* highest prime factor in search */ ZVALUE n; /* number to factor */ NUMBER *factor; /* the prime factor found */ int res; /* -1 => error, 0 => not found, 1 => factor found */ /* * parse args */ if (count == 3) { if (qisfrac(vals[2])) { math_error("3rd factor arg must be an integer"); /*NOTREACHED*/ } err = vals[2]; } else { err = NULL; } if (count >= 2) { if (qisfrac(vals[1])) { if (err) { return qlink(err); } math_error("non-integral arg 2 for builtin factor"); /*NOTREACHED*/ } limit = vals[1]->num; } else { /* default limit is 2^32-1 */ utoz((FULL)0xffffffff, &limit); } if (qisfrac(vals[0])) { if (count < 2) zfree(limit); if (err) { return qlink(err); } math_error("non-integral arg 1 for builtin pfactor"); /*NOTREACHED*/ } n = vals[0]->num; /* * find the smallest prime factor in the range */ factor = qalloc(); res = zfactor(n, limit, &(factor->num)); if (res < 0) { /* error processing */ if (err) { return qlink(err); } math_error("limit >= 2^32 for builtin factor"); /*NOTREACHED*/ } else if (res == 0) { if (count < 2) zfree(limit); /* no factor found - qalloc set factor to 1, return 1 */ return factor; } /* * return the factor found */ if (count < 2) zfree(limit); return factor; } S_FUNC NUMBER * f_pix(int count, NUMBER **vals) { NUMBER *err; /* error return, NULL => use math_error */ long value; /* primes <= x, or 0 ==> error */ /* determine the way we report problems */ if (count == 2) { if (qisfrac(vals[1])) { math_error("2nd pix arg must be an integer"); /*NOTREACHED*/ } err = vals[1]; } else { err = NULL; } /* firewall - must be an integer */ if (qisfrac(vals[0])) { if (err) { return qlink(err); } math_error("non-integral arg 1 for builtin function pix"); /*NOTREACHED*/ } /* determine the number of primes <= x */ value = zpix(vals[0]->num); if (value >= 0) { return utoq(value); } /* error return */ if (!err) { math_error("pix arg 1 is >= 2^32"); /*NOTREACHED*/ } return qlink(err); } S_FUNC NUMBER * f_prevcand(int count, NUMBER **vals) { ZVALUE zmodulus; ZVALUE zresidue; ZVALUE zskip; ZVALUE *zcount = NULL; /* ptest trial count */ ZVALUE tmp; NUMBER *ans; /* candidate for primality */ zmodulus = _one_; zresidue = _zero_; zskip = _one_; /* * check on the number of args passed and that args passed are ints */ switch (count) { case 5: if (!qisint(vals[4])) { math_error( "prevcand 5th arg must both be integer"); /*NOTREACHED*/ } zmodulus = vals[4]->num; /*FALLTHRU*/ case 4: if (!qisint(vals[3])) { math_error( "prevcand 4th arg must both be integer"); /*NOTREACHED*/ } zresidue = vals[3]->num; /*FALLTHRU*/ case 3: if (!qisint(vals[2])) { math_error( "prevcand skip arg (3rd) must be an integer or omitted"); /*NOTREACHED*/ } zskip = vals[2]->num; /*FALLTHRU*/ case 2: if (!qisint(vals[1])) { math_error( "prevcand count arg (2nd) must be an integer or omitted"); /*NOTREACHED*/ } zcount = &vals[1]->num; /*FALLTHRU*/ case 1: if (!qisint(vals[0])) { math_error( "prevcand search arg (1st) must be an integer"); /*NOTREACHED*/ } break; default: math_error("invalid number of args passed to prevcand"); /*NOTREACHED*/ } if (zcount == NULL) { count = 1; /* default is 1 ptest */ } else { if (zge24b(*zcount)) { math_error("prevcand count arg (2nd) must be < 2^24"); /*NOTREACHED*/ } count = ztoi(*zcount); } /* * find the candidate */ if (zprevcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) { ans = qalloc(); ans->num = tmp; return ans; } return qlink(&_qzero_); } S_FUNC NUMBER * f_nextcand(int count, NUMBER **vals) { ZVALUE zmodulus; ZVALUE zresidue; ZVALUE zskip; ZVALUE *zcount = NULL; /* ptest trial count */ ZVALUE tmp; NUMBER *ans; /* candidate for primality */ zmodulus = _one_; zresidue = _zero_; zskip = _one_; /* * check on the number of args passed and that args passed are ints */ switch (count) { case 5: if (!qisint(vals[4])) { math_error( "nextcand 5th args must be integer"); /*NOTREACHED*/ } zmodulus = vals[4]->num; /*FALLTHRU*/ case 4: if (!qisint(vals[3])) { math_error( "nextcand 5th args must be integer"); /*NOTREACHED*/ } zresidue = vals[3]->num; /*FALLTHRU*/ case 3: if (!qisint(vals[2])) { math_error( "nextcand skip arg (3rd) must be an integer or omitted"); /*NOTREACHED*/ } zskip = vals[2]->num; /*FALLTHRU*/ case 2: if (!qisint(vals[1])) { math_error( "nextcand count arg (2nd) must be an integer or omitted"); /*NOTREACHED*/ } zcount = &vals[1]->num; /*FALLTHRU*/ case 1: if (!qisint(vals[0])) { math_error( "nextcand search arg (1st) must be an integer"); /*NOTREACHED*/ } break; default: math_error("invalid number of args passed to nextcand"); /*NOTREACHED*/ } /* * check ranges on integers passed */ if (zcount == NULL) { count = 1; /* default is 1 ptest */ } else { if (zge24b(*zcount)) { math_error("prevcand count arg (2nd) must be < 2^24"); /*NOTREACHED*/ } count = ztoi(*zcount); } /* * find the candidate */ if (znextcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) { ans = qalloc(); ans->num = tmp; return ans; } return qlink(&_qzero_); } S_FUNC NUMBER * f_seed(void) { return pseudo_seed(); } S_FUNC NUMBER * f_rand(int count, NUMBER **vals) { NUMBER *ans; /* parse args */ switch (count) { case 0: /* rand() == rand(2^64) */ /* generate an a55 random number */ ans = qalloc(); zrand(SBITS, &ans->num); break; case 1: /* rand(limit) */ if (!qisint(vals[0])) { math_error("rand limit must be an integer"); /*NOTREACHED*/ } if (zislezero(vals[0]->num)) { math_error("rand limit must > 0"); /*NOTREACHED*/ } ans = qalloc(); zrandrange(_zero_, vals[0]->num, &ans->num); break; case 2: /* rand(low, limit) */ /* firewall */ if (!qisint(vals[0]) || !qisint(vals[1])) { math_error("rand range must be integers"); /*NOTREACHED*/ } ans = qalloc(); zrandrange(vals[0]->num, vals[1]->num, &ans->num); break; default: math_error("invalid number of args passed to rand"); /*NOTREACHED*/ return NULL; } /* return the a55 random number */ return ans; } S_FUNC NUMBER * f_randbit(int count, NUMBER **vals) { NUMBER *ans; ZVALUE ztmp; long cnt; /* bits needed or skipped */ /* parse args */ if (count == 0) { zrand(1, &ztmp); ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_); zfree(ztmp); return ans; } /* * firewall */ if (!qisint(vals[0])) { math_error("rand bit count must be an integer"); /*NOTREACHED*/ } if (zge31b(vals[0]->num)) { math_error("huge rand bit count"); /*NOTREACHED*/ } /* * generate an a55 random number or skip random bits */ ans = qalloc(); cnt = ztolong(vals[0]->num); if (zisneg(vals[0]->num)) { /* skip bits */ zrandskip(cnt); itoz(cnt, &ans->num); } else { /* generate bits */ zrand(cnt, &ans->num); } /* * return the a55 random number */ return ans; } S_FUNC VALUE f_srand(int count, VALUE **vals) { VALUE result; /* initialize VALUE */ result.v_type = V_RAND; result.v_subtype = V_NOSUBTYPE; /* parse args */ switch (count) { case 0: /* get the current a55 state */ result.v_rand = zsrand(NULL, NULL); break; case 1: switch (vals[0]->v_type) { case V_NUM: /* srand(seed) */ /* seed a55 and return previous state */ if (!qisint(vals[0]->v_num)) { math_error( "srand number seed must be an integer"); /*NOTREACHED*/ } result.v_rand = zsrand(&vals[0]->v_num->num, NULL); break; case V_RAND: /* srand(state) */ /* set a55 state and return previous state */ result.v_rand = zsetrand(vals[0]->v_rand); break; case V_MAT: /* load additive 55 table and return previous state */ result.v_rand = zsrand(NULL, vals[0]->v_mat); break; default: math_error("illegal type of arg passed to srand()"); /*NOTREACHED*/ break; } break; default: math_error("bad arg count to srand()"); /*NOTREACHED*/ break; } /* return the current state */ return result; } S_FUNC NUMBER * f_random(int count, NUMBER **vals) { NUMBER *ans; /* parse args */ switch (count) { case 0: /* random() == random(2^64) */ /* generate a Blum-Blum-Shub random number */ ans = qalloc(); zrandom(SBITS, &ans->num); break; case 1: /* random(limit) */ if (!qisint(vals[0])) { math_error("random limit must be an integer"); /*NOTREACHED*/ } if (zislezero(vals[0]->num)) { math_error("random limit must > 0"); /*NOTREACHED*/ } ans = qalloc(); zrandomrange(_zero_, vals[0]->num, &ans->num); break; case 2: /* random(low, limit) */ /* firewall */ if (!qisint(vals[0]) || !qisint(vals[1])) { math_error("random range must be integers"); /*NOTREACHED*/ } ans = qalloc(); zrandomrange(vals[0]->num, vals[1]->num, &ans->num); break; default: math_error("invalid number of args passed to random"); /*NOTREACHED*/ return NULL; } /* return the Blum-Blum-Shub random number */ return ans; } S_FUNC NUMBER * f_randombit(int count, NUMBER **vals) { NUMBER *ans; ZVALUE ztmp; long cnt; /* bits needed or skipped */ /* parse args */ if (count == 0) { zrandom(1, &ztmp); ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_); zfree(ztmp); return ans; } /* * firewall */ if (!qisint(vals[0])) { math_error("random bit count must be an integer"); /*NOTREACHED*/ } if (zge31b(vals[0]->num)) { math_error("huge random bit count"); /*NOTREACHED*/ } /* * generate a Blum-Blum-Shub random number or skip random bits */ ans = qalloc(); cnt = ztolong(vals[0]->num); if (zisneg(vals[0]->num)) { /* skip bits */ zrandomskip(cnt); itoz(cnt, &ans->num); } else { /* generate bits */ zrandom(cnt, &ans->num); } /* * return the Blum-Blum-Shub random number */ return ans; } S_FUNC VALUE f_srandom(int count, VALUE **vals) { VALUE result; /* initialize VALUE */ result.v_type = V_RANDOM; result.v_subtype = V_NOSUBTYPE; /* parse args */ switch (count) { case 0: /* srandom() */ /* get the current random state */ result.v_random = zsetrandom(NULL); break; case 1: /* srandom(seed) or srandom(state) */ switch (vals[0]->v_type) { case V_NUM: /* srand(seed) */ /* seed Blum and return previous state */ if (!qisint(vals[0]->v_num)) { math_error( "srandom number seed must be an integer"); /*NOTREACHED*/ } result.v_random = zsrandom1(vals[0]->v_num->num, TRUE); break; case V_RANDOM: /* srandom(state) */ /* set a55 state and return previous state */ result.v_random = zsetrandom(vals[0]->v_random); break; default: math_error("illegal type of arg passed to srandom()"); /*NOTREACHED*/ break; } break; case 2: /* srandom(seed, newn) */ if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) { math_error("srandom seed must be an integer"); /*NOTREACHED*/ } if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) { math_error("srandom Blum modulus must be an integer"); /*NOTREACHED*/ } result.v_random = zsrandom2(vals[0]->v_num->num, vals[1]->v_num->num); break; case 4: /* srandom(seed, ip, iq, trials) */ if (vals[0]->v_type != V_NUM || !qisint(vals[0]->v_num)) { math_error("srandom seed must be an integer"); /*NOTREACHED*/ } if (vals[1]->v_type != V_NUM || !qisint(vals[1]->v_num)) { math_error("srandom 2nd arg must be an integer"); /*NOTREACHED*/ } if (vals[2]->v_type != V_NUM || !qisint(vals[2]->v_num)) { math_error("srandom 3rd arg must be an integer"); /*NOTREACHED*/ } if (vals[3]->v_type != V_NUM || !qisint(vals[3]->v_num)) { math_error("srandom 4th arg must be an integer"); /*NOTREACHED*/ } if (zge24b(vals[3]->v_num->num)) { math_error("srandom trials count is excessive"); /*NOTREACHED*/ } result.v_random = zsrandom4(vals[0]->v_num->num, vals[1]->v_num->num, vals[2]->v_num->num, ztoi(vals[3]->v_num->num)); break; default: math_error("bad arg count to srandom()"); /*NOTREACHED*/ break; } /* return the current state */ return result; } S_FUNC NUMBER * f_primetest(int count, NUMBER **vals) { /* parse args */ switch (count) { case 1: return itoq((long) qprimetest(vals[0], qlink(&_qone_), qlink(&_qone_))); case 2: return itoq((long) qprimetest(vals[0], vals[1], qlink(&_qone_))); default: return itoq((long) qprimetest(vals[0], vals[1], vals[2])); } } S_FUNC VALUE f_setbit(int count, VALUE **vals) { BOOL r; long index; VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; r = (count == 3) ? testvalue(vals[2]) : 1; if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) return error_value(E_SETBIT1); if (zge31b(vals[1]->v_num->num)) return error_value(E_SETBIT2); if (vals[0]->v_type != V_STR) return error_value(E_SETBIT3); index = qtoi(vals[1]->v_num); if (stringsetbit(vals[0]->v_str, index, r)) return error_value(E_SETBIT2); return result; } S_FUNC VALUE f_digit(int count, VALUE **vals) { VALUE res; ZVALUE base; if (vals[0]->v_type != V_NUM) return error_value(E_DGT1); if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) return error_value(E_DGT2); if (count == 3) { if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num)) return error_value(E_DGT3); base = vals[2]->v_num->num; } else { base = _ten_; } res.v_type = V_NUM; res.v_num = qdigit(vals[0]->v_num, vals[1]->v_num->num, base); if (res.v_num == NULL) return error_value(E_DGT3); return res; } S_FUNC VALUE f_digits(int count, VALUE **vals) { ZVALUE base; VALUE res; if (vals[0]->v_type != V_NUM) return error_value(E_DGTS1); if (count > 1) { if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num) || qiszero(vals[1]->v_num) || qisunit(vals[1]->v_num)) return error_value(E_DGTS2); base = vals[1]->v_num->num; } else { base = _ten_; } res.v_type = V_NUM; res.v_num = itoq(qdigits(vals[0]->v_num, base)); return res; } S_FUNC VALUE f_places(int count, VALUE **vals) { long places; VALUE res; if (vals[0]->v_type != V_NUM) return error_value(E_PLCS1); if (count > 1) { if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) return error_value(E_PLCS2); places = qplaces(vals[0]->v_num, vals[1]->v_num->num); if (places == -2) return error_value(E_PLCS2); } else places = qdecplaces(vals[0]->v_num); res.v_type = V_NUM; res.v_num = itoq(places); return res; } S_FUNC NUMBER * f_popcnt(int count, NUMBER **vals) { int bitval = 1; /* * parse args */ if (count == 2 && qiszero(vals[1])) { bitval = 0; } /* * count bit values */ if (qisint(vals[0])) { return itoq(zpopcnt(vals[0]->num, bitval)); } else { return itoq(zpopcnt(vals[0]->num, bitval) + zpopcnt(vals[0]->den, bitval)); } } S_FUNC VALUE f_xor(int count, VALUE **vals) { NUMBER *q, *qtmp; STRING *s, *stmp; VALUE result; int i; int type; type = vals[0]->v_type; result.v_type = type; result.v_subtype = vals[0]->v_subtype; for (i = 1; i < count; i++) { if (vals[i]->v_type != type) return error_value(E_XOR1); } switch (type) { case V_NUM: q = qlink(vals[0]->v_num); for (i = 1; i < count; i++) { qtmp = qxor(q, vals[i]->v_num); qfree(q); q = qtmp; } result.v_num = q; break; case V_STR: s = slink(vals[0]->v_str); for (i = 1; i < count; i++) { stmp = stringxor(s, vals[i]->v_str); sfree(s); s = stmp; } result.v_str = s; break; default: return error_value(E_XOR2); } return result; } VALUE minlistitems(LIST *lp) { LISTELEM *ep; VALUE *vp; VALUE term; VALUE rel; VALUE min; /* initialize VALUEs */ min.v_type = V_NULL; min.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; for (ep = lp->l_first; ep; ep = ep->e_next) { vp = &ep->e_value; switch(vp->v_type) { case V_LIST: term = minlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_MIN, vp, NULL_VALUE, NULL_VALUE); break; default: copyvalue(vp, &term); } if (min.v_type == V_NULL) { min = term; continue; } if (term.v_type == V_NULL) continue; relvalue(&term, &min, &rel); if (rel.v_type != V_NUM) { freevalue(&term); freevalue(&min); freevalue(&rel); return error_value(E_LISTMIN); } if (qisneg(rel.v_num)) { freevalue(&min); min = term; } else freevalue(&term); freevalue(&rel); } return min; } VALUE maxlistitems(LIST *lp) { LISTELEM *ep; VALUE *vp; VALUE term; VALUE rel; VALUE max; /* initialize VALUEs */ max.v_type = V_NULL; max.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; for (ep = lp->l_first; ep; ep = ep->e_next) { vp = &ep->e_value; switch(vp->v_type) { case V_LIST: term = maxlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_MAX, vp, NULL_VALUE, NULL_VALUE); break; default: copyvalue(vp, &term); } if (max.v_type == V_NULL) { max = term; continue; } if (term.v_type == V_NULL) continue; relvalue(&max, &term, &rel); if (rel.v_type != V_NUM) { freevalue(&max); freevalue(&term); freevalue(&rel); return error_value(E_LISTMAX); } if (qisneg(rel.v_num)) { freevalue(&max); max = term; } else freevalue(&term); freevalue(&rel); } return max; } S_FUNC VALUE f_min(int count, VALUE **vals) { VALUE min; VALUE term; VALUE *vp; VALUE rel; /* initialize VALUEs */ min.v_type = V_NULL; min.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; while (count-- > 0) { vp = *vals++; switch(vp->v_type) { case V_LIST: term = minlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_MIN, vp, NULL_VALUE, NULL_VALUE); break; default: copyvalue(vp, &term); } if (min.v_type == V_NULL) { min = term; continue; } if (term.v_type == V_NULL) continue; if (term.v_type < 0) { freevalue(&min); return term; } relvalue(&term, &min, &rel); if (rel.v_type != V_NUM) { freevalue(&min); freevalue(&term); freevalue(&rel); return error_value(E_MIN); } if (qisneg(rel.v_num)) { freevalue(&min); min = term; } else { freevalue(&term); } freevalue(&rel); } return min; } S_FUNC VALUE f_max(int count, VALUE **vals) { VALUE max; VALUE term; VALUE *vp; VALUE rel; /* initialize VALUEs */ max.v_type = V_NULL; max.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; while (count-- > 0) { vp = *vals++; switch(vp->v_type) { case V_LIST: term = maxlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_MAX, vp, NULL_VALUE, NULL_VALUE); break; default: copyvalue(vp, &term); } if (max.v_type == V_NULL) { max = term; continue; } if (term.v_type == V_NULL) continue; if (term.v_type < 0) { freevalue(&max); return term; } relvalue(&max, &term, &rel); if (rel.v_type != V_NUM) { freevalue(&max); freevalue(&term); freevalue(&rel); return error_value(E_MAX); } if (qisneg(rel.v_num)) { freevalue(&max); max = term; } else { freevalue(&term); } freevalue(&rel); } return max; } S_FUNC NUMBER * f_gcd(int count, NUMBER **vals) { NUMBER *val, *tmp; val = qqabs(*vals); while (--count > 0) { tmp = qgcd(val, *++vals); qfree(val); val = tmp; } return val; } S_FUNC NUMBER * f_lcm(int count, NUMBER **vals) { NUMBER *val, *tmp; val = qqabs(*vals); while (--count > 0) { tmp = qlcm(val, *++vals); qfree(val); val = tmp; if (qiszero(val)) break; } return val; } S_FUNC VALUE f_hash(int count, VALUE **vals) { QCKHASH hash; VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; hash = FNV1_32_BASIS; while (count-- > 0) hash = hashvalue(*vals++, hash); result.v_num = utoq((FULL) hash); return result; } VALUE sumlistitems(LIST *lp) { LISTELEM *ep; VALUE *vp; VALUE term; VALUE tmp; VALUE sum; /* initialize VALUEs */ term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; tmp.v_type = V_NULL; tmp.v_subtype = V_NOSUBTYPE; sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; for (ep = lp->l_first; ep; ep = ep->e_next) { vp = &ep->e_value; switch(vp->v_type) { case V_LIST: term = sumlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_SUM, vp, NULL_VALUE, NULL_VALUE); break; default: addvalue(&sum, vp, &tmp); freevalue(&sum); if (tmp.v_type < 0) return tmp; sum = tmp; continue; } addvalue(&sum, &term, &tmp); freevalue(&sum); freevalue(&term); sum = tmp; if (sum.v_type < 0) break; } return sum; } S_FUNC VALUE f_sum(int count, VALUE **vals) { VALUE tmp; VALUE sum; VALUE term; VALUE *vp; /* initialize VALUEs */ tmp.v_type = V_NULL; tmp.v_subtype = V_NOSUBTYPE; sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; while (count-- > 0) { vp = *vals++; switch(vp->v_type) { case V_LIST: term = sumlistitems(vp->v_list); break; case V_OBJ: term = objcall(OBJ_SUM, vp, NULL_VALUE, NULL_VALUE); break; default: addvalue(&sum, vp, &tmp); freevalue(&sum); if (tmp.v_type < 0) return tmp; sum = tmp; continue; } addvalue(&sum, &term, &tmp); freevalue(&term); freevalue(&sum); sum = tmp; if (sum.v_type < 0) break; } return sum; } S_FUNC VALUE f_avg(int count, VALUE **vals) { VALUE tmp; VALUE sum; VALUE div; long n; /* initialize VALUEs */ tmp.v_type = V_NULL; tmp.v_subtype = V_NOSUBTYPE; sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; div.v_type = V_NULL; div.v_subtype = V_NOSUBTYPE; n = 0; while (count-- > 0) { if ((*vals)->v_type == V_LIST) { addlistitems((*vals)->v_list, &sum); n += countlistitems((*vals++)->v_list); } else { addvalue(&sum, *vals++, &tmp); freevalue(&sum); sum = tmp; n++; } if (sum.v_type < 0) return sum; } if (n < 2) return sum; div.v_num = itoq(n); div.v_type = V_NUM; div.v_subtype = V_NOSUBTYPE; divvalue(&sum, &div, &tmp); freevalue(&sum); qfree(div.v_num); return tmp; } S_FUNC VALUE f_fact(VALUE *vp) { VALUE res; /* initialize VALUE */ res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; if (vp->v_type == V_OBJ) { return objcall(OBJ_FACT, vp, NULL_VALUE, NULL_VALUE); } if (vp->v_type != V_NUM) { math_error("Non-real argument for fact()"); /*NOTREACHED*/ } res.v_num = qfact(vp->v_num); return res; } S_FUNC VALUE f_hmean(int count, VALUE **vals) { VALUE sum, tmp1, tmp2; long n = 0; /* initialize VALUEs */ sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; tmp1.v_type = V_NULL; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_type = V_NULL; tmp2.v_subtype = V_NOSUBTYPE; while (count-- > 0) { if ((*vals)->v_type == V_LIST) { addlistinv((*vals)->v_list, &sum); n += countlistitems((*vals++)->v_list); } else { invertvalue(*vals++, &tmp1); addvalue(&sum, &tmp1, &tmp2); freevalue(&tmp1); freevalue(&sum); sum = tmp2; n++; } } if (n == 0) return sum; tmp1.v_type = V_NUM; tmp1.v_subtype = V_NOSUBTYPE; tmp1.v_num = itoq(n); divvalue(&tmp1, &sum, &tmp2); qfree(tmp1.v_num); freevalue(&sum); return tmp2; } S_FUNC NUMBER * f_hnrmod(NUMBER *val1, NUMBER *val2, NUMBER *val3, NUMBER *val4) { ZVALUE answer; /* v mod h*2^n+r */ NUMBER *res; /* v mod h*2^n+r */ /* * firewall */ if (qisfrac(val1)) { math_error("1st arg of hnrmod (v) must be an integer"); /*NOTREACHED*/ } if (qisfrac(val2) || qisneg(val2) || qiszero(val2)) { math_error("2nd arg of hnrmod (h) must be an integer > 0"); /*NOTREACHED*/ } if (qisfrac(val3) || qisneg(val3) || qiszero(val3)) { math_error("3rd arg of hnrmod (n) must be an integer > 0"); /*NOTREACHED*/ } if (qisfrac(val4) || !zisabsleone(val4->num)) { math_error("4th arg of hnrmod (r) must be -1, 0 or 1"); /*NOTREACHED*/ } /* * perform the val1 mod (val2 * 2^val3 + val4) operation */ zhnrmod(val1->num, val2->num, val3->num, val4->num, &answer); /* * return the answer */ res = qalloc(); res->num = answer; return res; } VALUE ssqlistitems(LIST *lp) { LISTELEM *ep; VALUE *vp; VALUE term; VALUE tmp; VALUE sum; /* initialize VALUEs */ term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; tmp.v_type = V_NULL; tmp.v_subtype = V_NOSUBTYPE; sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; for (ep = lp->l_first; ep; ep = ep->e_next) { vp = &ep->e_value; if (vp->v_type == V_LIST) { term = ssqlistitems(vp->v_list); } else { squarevalue(vp, &term); } addvalue(&sum, &term, &tmp); freevalue(&sum); freevalue(&term); sum = tmp; if (sum.v_type < 0) break; } return sum; } S_FUNC VALUE f_ssq(int count, VALUE **vals) { VALUE tmp; VALUE sum; VALUE term; VALUE *vp; /* initialize VALUEs */ tmp.v_type = V_NULL; tmp.v_subtype = V_NOSUBTYPE; sum.v_type = V_NULL; sum.v_subtype = V_NOSUBTYPE; term.v_type = V_NULL; term.v_subtype = V_NOSUBTYPE; while (count-- > 0) { vp = *vals++; if (vp->v_type == V_LIST) { term = ssqlistitems(vp->v_list); } else { squarevalue(vp, &term); } addvalue(&sum, &term, &tmp); freevalue(&term); freevalue(&sum); sum = tmp; if (sum.v_type < 0) break; } return sum; } S_FUNC NUMBER * f_ismult(NUMBER *val1, NUMBER *val2) { return itoq((long) qdivides(val1, val2)); } S_FUNC NUMBER * f_meq(NUMBER *val1, NUMBER *val2, NUMBER *val3) { NUMBER *tmp, *res; tmp = qsub(val1, val2); res = itoq((long) qdivides(tmp, val3)); qfree(tmp); return res; } S_FUNC VALUE f_exp(int count, VALUE **vals) { VALUE result; NUMBER *eps; NUMBER *q; COMPLEX *c; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_EXP1); eps = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: q = qexp(vals[0]->v_num, eps); if (q == NULL) return error_value(E_EXP3); result.v_num = q; result.v_type = V_NUM; break; case V_COM: c = c_exp(vals[0]->v_com, eps); if (c == NULL) return error_value(E_EXP3); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } break; default: return error_value(E_EXP2); } return result; } S_FUNC VALUE f_ln(int count, VALUE **vals) { VALUE result; COMPLEX ctmp, *c; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM) return error_value(E_LN1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) { result.v_num = qln(vals[0]->v_num, err); result.v_type = V_NUM; return result; } ctmp.real = vals[0]->v_num; ctmp.imag = qlink(&_qzero_); ctmp.links = 1; c = c_ln(&ctmp, err); break; case V_COM: c = c_ln(vals[0]->v_com, err); break; default: return error_value(E_LN2); } result.v_type = V_COM; result.v_com = c; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } return result; } S_FUNC VALUE f_log(int count, VALUE **vals) { VALUE result; COMPLEX ctmp, *c; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM) return error_value(E_LOG1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) { result.v_num = qlog(vals[0]->v_num, err); result.v_type = V_NUM; return result; } ctmp.real = vals[0]->v_num; ctmp.imag = qlink(&_qzero_); ctmp.links = 1; c = c_log(&ctmp, err); break; case V_COM: c = c_log(vals[0]->v_com, err); break; default: return error_value(E_LOG2); } result.v_type = V_COM; result.v_com = c; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } return result; } S_FUNC VALUE f_cos(int count, VALUE **vals) { VALUE result; COMPLEX *c; NUMBER *eps; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_COS1); eps = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qcos(vals[0]->v_num, eps); result.v_type = V_NUM; break; case V_COM: c = c_cos(vals[0]->v_com, eps); if (c == NULL) return error_value(E_COS3); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } break; default: return error_value(E_COS2); } return result; } S_FUNC VALUE f_sin(int count, VALUE **vals) { VALUE result; COMPLEX *c; NUMBER *eps; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_SIN1); eps = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qsin(vals[0]->v_num, eps); result.v_type = V_NUM; break; case V_COM: c = c_sin(vals[0]->v_com, eps); if (c == NULL) return error_value(E_SIN3); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } break; default: return error_value(E_SIN2); } return result; } S_FUNC VALUE f_tan(int count, VALUE **vals) { VALUE result; VALUE tmp1, tmp2; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_TAN1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qtan(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp1.v_type = V_COM; tmp1.v_com = c_sin(vals[0]->v_com, err); tmp2.v_type = V_COM; tmp2.v_com = c_cos(vals[0]->v_com, err); divvalue(&tmp1, &tmp2, &result); comfree(tmp1.v_com); comfree(tmp2.v_com); break; default: return error_value(E_TAN2); } return result; } S_FUNC VALUE f_sec(int count, VALUE **vals) { VALUE result; VALUE tmp; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_SEC1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qsec(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp.v_type = V_COM; tmp.v_com = c_cos(vals[0]->v_com, err); invertvalue(&tmp, &result); comfree(tmp.v_com); break; default: return error_value(E_SEC2); } return result; } S_FUNC VALUE f_cot(int count, VALUE **vals) { VALUE result; VALUE tmp1, tmp2; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_COT1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_1OVER0); result.v_num = qcot(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp1.v_type = V_COM; tmp1.v_com = c_cos(vals[0]->v_com, err); tmp2.v_type = V_COM; tmp2.v_com = c_sin(vals[0]->v_com, err); divvalue(&tmp1, &tmp2, &result); comfree(tmp1.v_com); comfree(tmp2.v_com); break; default: return error_value(E_COT2); } return result; } S_FUNC VALUE f_csc(int count, VALUE **vals) { VALUE result; VALUE tmp; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_CSC1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_1OVER0); result.v_num = qcsc(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp.v_type = V_COM; tmp.v_com = c_sin(vals[0]->v_com, err); invertvalue(&tmp, &result); comfree(tmp.v_com); break; default: return error_value(E_CSC2); } return result; } S_FUNC VALUE f_sinh(int count, VALUE **vals) { VALUE result; NUMBER *eps; NUMBER *q; COMPLEX *c; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_SINH1); eps = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: q = qsinh(vals[0]->v_num, eps); if (q == NULL) return error_value(E_SINH3); result.v_num = q; result.v_type = V_NUM; break; case V_COM: c = c_sinh(vals[0]->v_com, eps); if (c == NULL) return error_value(E_SINH3); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); comfree(c); result.v_type = V_NUM; } break; default: return error_value(E_SINH2); } return result; } S_FUNC VALUE f_cosh(int count, VALUE **vals) { VALUE result; NUMBER *eps; NUMBER *q; COMPLEX *c; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_COSH1); eps = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: q = qcosh(vals[0]->v_num, eps); if (q == NULL) return error_value(E_COSH3); result.v_num = q; result.v_type = V_NUM; break; case V_COM: c = c_cosh(vals[0]->v_com, eps); if (c == NULL) return error_value(E_COSH3); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); comfree(c); result.v_type = V_NUM; } break; default: return error_value(E_COSH2); } return result; } S_FUNC VALUE f_tanh(int count, VALUE **vals) { VALUE result; VALUE tmp1, tmp2; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_TANH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qtanh(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp1.v_type = V_COM; tmp1.v_com = c_sinh(vals[0]->v_com, err); tmp2.v_type = V_COM; tmp2.v_com = c_cosh(vals[0]->v_com, err); divvalue(&tmp1, &tmp2, &result); comfree(tmp1.v_com); comfree(tmp2.v_com); break; default: return error_value(E_TANH2); } return result; } S_FUNC VALUE f_coth(int count, VALUE **vals) { VALUE result; VALUE tmp1, tmp2; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_COTH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_1OVER0); result.v_num = qcoth(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp1.v_type = V_COM; tmp1.v_com = c_cosh(vals[0]->v_com, err); tmp2.v_type = V_COM; tmp2.v_com = c_sinh(vals[0]->v_com, err); divvalue(&tmp1, &tmp2, &result); comfree(tmp1.v_com); comfree(tmp2.v_com); break; default: return error_value(E_COTH2); } return result; } S_FUNC VALUE f_sech(int count, VALUE **vals) { VALUE result; VALUE tmp; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_SECH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qsech(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp.v_type = V_COM; tmp.v_com = c_cosh(vals[0]->v_com, err); invertvalue(&tmp, &result); comfree(tmp.v_com); break; default: return error_value(E_SECH2); } return result; } S_FUNC VALUE f_csch(int count, VALUE **vals) { VALUE result; VALUE tmp; NUMBER *err; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_CSCH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_1OVER0); result.v_num = qcsch(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp.v_type = V_COM; tmp.v_com = c_sinh(vals[0]->v_com, err); invertvalue(&tmp, &result); comfree(tmp.v_com); break; default: return error_value(E_CSCH2); } return result; } S_FUNC VALUE f_atan(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ATAN1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qatan(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp = c_atan(vals[0]->v_com, err); if (tmp == NULL) return error_value(E_LOGINF); result.v_type = V_COM; result.v_com = tmp; if (cisreal(tmp)) { result.v_num = qlink(tmp->real); result.v_type = V_NUM; comfree(tmp); } break; default: return error_value(E_ATAN2); } return result; } S_FUNC VALUE f_acot(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACOT1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qacot(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp = c_acot(vals[0]->v_com, err); if (tmp == NULL) return error_value(E_LOGINF); result.v_type = V_COM; result.v_com = tmp; if (cisreal(tmp)) { result.v_num = qlink(tmp->real); result.v_type = V_NUM; comfree(tmp); } break; default: return error_value(E_ACOT2); } return result; } S_FUNC VALUE f_asin(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ASIN1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qasin(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_type = V_COM; result.v_com = c_asin(tmp, err); comfree(tmp); } break; case V_COM: result.v_com = c_asin(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ASIN2); } if (result.v_type == V_COM && cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } return result; } S_FUNC VALUE f_acos(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACOS1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qacos(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_type = V_COM; result.v_com = c_acos(tmp, err); comfree(tmp); } break; case V_COM: result.v_com = c_acos(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ACOS2); } if (result.v_type == V_COM && cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } return result; } S_FUNC VALUE f_asec(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ASEC1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_LOGINF); result.v_num = qasec(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_asec(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_asec(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ASEC2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_acsc(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACSC1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_LOGINF); result.v_num = qacsc(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_acsc(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_acsc(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ACSC2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_asinh(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ASINH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qasinh(vals[0]->v_num, err); result.v_type = V_NUM; break; case V_COM: tmp = c_asinh(vals[0]->v_com, err); result.v_type = V_COM; result.v_com = tmp; if (cisreal(tmp)) { result.v_num = qlink(tmp->real); result.v_type = V_NUM; comfree(tmp); } break; default: return error_value(E_ASINH2); } return result; } S_FUNC VALUE f_acosh(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACOSH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qacosh(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_acosh(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_acosh(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ACOSH2); } if (result.v_type == V_COM && cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } return result; } S_FUNC VALUE f_atanh(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ATANH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qatanh(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_atanh(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_atanh(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ATANH2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_acoth(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACOTH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: result.v_num = qacoth(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_acoth(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_acoth(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ACOTH2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_asech(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_SECH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_LOGINF); result.v_num = qasech(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_asech(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_asech(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ASECH2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_acsch(int count, VALUE **vals) { VALUE result; COMPLEX *tmp; NUMBER *err; NUMBER *q; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ACSCH1); err = vals[1]->v_num; } switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) return error_value(E_LOGINF); result.v_num = qacsch(vals[0]->v_num, err); result.v_type = V_NUM; if (result.v_num == NULL) { tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_acsch(tmp, err); result.v_type = V_COM; comfree(tmp); } break; case V_COM: result.v_com = c_acsch(vals[0]->v_com, err); result.v_type = V_COM; break; default: return error_value(E_ACSCH2); } if (result.v_type == V_COM) { if (result.v_com == NULL) return error_value(E_LOGINF); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_type = V_NUM; result.v_num = q; } } return result; } S_FUNC VALUE f_gd(int count, VALUE **vals) { VALUE result; NUMBER *eps; NUMBER *q; COMPLEX *tmp; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_GD1); eps = vals[1]->v_num; } result.v_type = V_COM; switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) { result.v_type = V_NUM; result.v_num = qlink(&_qzero_); return result; } tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_gd(tmp, eps); comfree(tmp); break; case V_COM: result.v_com = c_gd(vals[0]->v_com, eps); break; default: return error_value(E_GD2); } if (result.v_com == NULL) return error_value(E_GD3); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_num = q; result.v_type = V_NUM; } return result; } S_FUNC VALUE f_agd(int count, VALUE **vals) { VALUE result; NUMBER *eps; NUMBER *q; COMPLEX *tmp; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; eps = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_AGD1); eps = vals[1]->v_num; } result.v_type = V_COM; switch (vals[0]->v_type) { case V_NUM: if (qiszero(vals[0]->v_num)) { result.v_type = V_NUM; result.v_num = qlink(&_qzero_); return result; } tmp = comalloc(); qfree(tmp->real); tmp->real = qlink(vals[0]->v_num); result.v_com = c_agd(tmp, eps); comfree(tmp); break; case V_COM: result.v_com = c_agd(vals[0]->v_com, eps); break; default: return error_value(E_AGD2); } if (result.v_com == NULL) return error_value(E_AGD3); if (cisreal(result.v_com)) { q = qlink(result.v_com->real); comfree(result.v_com); result.v_num = q; result.v_type = V_NUM; } return result; } S_FUNC VALUE f_comb(VALUE *v1, VALUE *v2) { long n; VALUE result; VALUE tmp1, tmp2, div; if (v2->v_type != V_NUM || qisfrac(v2->v_num)) return error_value(E_COMB1); result.v_subtype = V_NOSUBTYPE; result.v_type = V_NUM; if (qisneg(v2->v_num)) { result.v_num = qlink(&_qzero_); return result; } if (qiszero(v2->v_num)) { result.v_num = qlink(&_qone_); return result; } if (qisone(v2->v_num)) { copyvalue(v1, &result); return result; } if (v1->v_type == V_NUM) { result.v_num = qcomb(v1->v_num, v2->v_num); if (result.v_num == NULL) return error_value(E_COMB2); return result; } if (zge24b(v2->v_num->num)) return error_value(E_COMB2); n = qtoi(v2->v_num); copyvalue(v1, &result); decvalue(v1, &tmp1); div.v_type = V_NUM; div.v_num = qlink(&_qtwo_); n--; for (;;) { mulvalue(&result, &tmp1, &tmp2); freevalue(&result); divvalue(&tmp2, &div, &result); freevalue(&tmp2); if (--n == 0 || !testvalue(&result) || result.v_type < 0) { freevalue(&tmp1); freevalue(&div); return result; } decvalue(&tmp1, &tmp2); freevalue(&tmp1); tmp1 = tmp2; incvalue(&div, &tmp2); freevalue(&div); div = tmp2; } } S_FUNC VALUE f_bern(VALUE *vp) { VALUE res; if (vp->v_type != V_NUM || qisfrac(vp->v_num)) return error_value(E_BERN); res.v_subtype = V_NOSUBTYPE; res.v_type = V_NUM; res.v_num = qbern(vp->v_num->num); if (res.v_num == NULL) return error_value(E_BERN); return res; } S_FUNC VALUE f_freebern(void) { VALUE res; qfreebern(); res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_euler(VALUE *vp) { VALUE res; if (vp->v_type!=V_NUM || qisfrac(vp->v_num)) return error_value(E_EULER); res.v_subtype = V_NOSUBTYPE; res.v_type = V_NUM; res.v_num = qeuler(vp->v_num->num); if (res.v_num == NULL) return error_value(E_EULER); return res; } S_FUNC VALUE f_freeeuler(void) { VALUE res; qfreeeuler(); res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_catalan(VALUE *vp) { VALUE res; if (vp->v_type!=V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num)) return error_value(E_CTLN); res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; res.v_num = qcatalan(vp->v_num); if (res.v_num == NULL) return error_value(E_CTLN); return res; } S_FUNC VALUE f_arg(int count, VALUE **vals) { VALUE result; COMPLEX *c; NUMBER *err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; err = conf->epsilon; if (count == 2) { if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) return error_value(E_ARG1); err = vals[1]->v_num; } result.v_type = V_NUM; switch (vals[0]->v_type) { case V_NUM: if (qisneg(vals[0]->v_num)) result.v_num = qpi(err); else result.v_num = qlink(&_qzero_); break; case V_COM: c = vals[0]->v_com; if (ciszero(c)) result.v_num = qlink(&_qzero_); else result.v_num = qatan2(c->imag, c->real, err); break; default: return error_value(E_ARG2); } return result; } S_FUNC NUMBER * f_legtoleg(NUMBER *val1, NUMBER *val2) { return qlegtoleg(val1, val2, FALSE); } S_FUNC NUMBER * f_trunc(int count, NUMBER **vals) { NUMBER *val; val = qlink(&_qzero_); if (count == 2) val = vals[1]; return qtrunc(*vals, val); } S_FUNC VALUE f_bround(int count, VALUE **vals) { VALUE tmp1, tmp2, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; if (count > 2) tmp2 = *vals[2]; else tmp2.v_type = V_NULL; if (count > 1) tmp1 = *vals[1]; else tmp1.v_type = V_NULL; broundvalue(vals[0], &tmp1, &tmp2, &res); return res; } S_FUNC VALUE f_appr(int count, VALUE **vals) { VALUE tmp1, tmp2, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; if (count > 2) copyvalue(vals[2], &tmp2); else tmp2.v_type = V_NULL; if (count > 1) copyvalue(vals[1], &tmp1); else tmp1.v_type = V_NULL; apprvalue(vals[0], &tmp1, &tmp2, &res); freevalue(&tmp1); freevalue(&tmp2); return res; } S_FUNC VALUE f_round(int count, VALUE **vals) { VALUE tmp1, tmp2, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; if (count > 2) tmp2 = *vals[2]; else tmp2.v_type = V_NULL; if (count > 1) tmp1 = *vals[1]; else tmp1.v_type = V_NULL; roundvalue(vals[0], &tmp1, &tmp2, &res); return res; } S_FUNC NUMBER * f_btrunc(int count, NUMBER **vals) { NUMBER *val; val = qlink(&_qzero_); if (count == 2) val = vals[1]; return qbtrunc(*vals, val); } S_FUNC VALUE f_quo(int count, VALUE **vals) { VALUE tmp, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; if (count > 2) tmp = *vals[2]; else tmp.v_type = V_NULL; quovalue(vals[0], vals[1], &tmp, &res); return res; } S_FUNC VALUE f_mod(int count, VALUE **vals) { VALUE tmp, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; if (count > 2) tmp = *vals[2]; else tmp.v_type = V_NULL; modvalue(vals[0], vals[1], &tmp, &res); return res; } S_FUNC VALUE f_quomod(int count, VALUE **vals) { VALUE *v1, *v2, *v3, *v4, *v5; VALUE result; long rnd; BOOL res; short s3, s4; /* to preserve subtypes of v3, v4 */ v1 = vals[0]; v2 = vals[1]; v3 = vals[2]; v4 = vals[3]; if (v3->v_type != V_ADDR || v4->v_type != V_ADDR || v3->v_addr == v4->v_addr) return error_value(E_QUOMOD1); if (count == 5) { v5 = vals[4]; if (v5->v_type == V_ADDR) v5 = v5->v_addr; if (v5->v_type != V_NUM || qisfrac(v5->v_num) || qisneg(v5->v_num) || zge31b(v5->v_num->num)) return error_value(E_QUOMOD2); rnd = qtoi(v5->v_num); } else rnd = conf->quomod; if (v1->v_type == V_ADDR) v1 = v1->v_addr; if (v2->v_type == V_ADDR) v2 = v2->v_addr; v3 = v3->v_addr; v4 = v4->v_addr; if (v1->v_type != V_NUM || v2->v_type != V_NUM || (v3->v_type != V_NUM && v3->v_type != V_NULL) || (v4->v_type != V_NUM && v4->v_type != V_NULL)) return error_value(E_QUOMOD2); s3 = v3->v_subtype; s4 = v4->v_subtype; if ((s3 | s4) & V_NOASSIGNTO) return error_value(E_QUOMOD3); freevalue(v3); freevalue(v4); v3->v_type = V_NUM; v4->v_type = V_NUM; v3->v_subtype = s3; v4->v_subtype = s4; res = qquomod(v1->v_num, v2->v_num, &v3->v_num, &v4->v_num, rnd); result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; result.v_num = res ? qlink(&_qone_) : qlink(&_qzero_); return result; } S_FUNC VALUE f_mmin(VALUE *v1, VALUE *v2) { VALUE sixteen, res; /* initialize VALUEs */ sixteen.v_subtype = V_NOSUBTYPE; res.v_subtype = V_NOSUBTYPE; sixteen.v_type = V_NUM; sixteen.v_num = itoq(16); modvalue(v1, v2, &sixteen, &res); qfree(sixteen.v_num); return res; } S_FUNC NUMBER * f_near(int count, NUMBER **vals) { NUMBER *val; val = conf->epsilon; if (count == 3) val = vals[2]; return itoq((long) qnear(vals[0], vals[1], val)); } S_FUNC NUMBER * f_cfsim(int count, NUMBER **vals) { long R; R = (count > 1) ? qtoi(vals[1]) : conf->cfsim; return qcfsim(vals[0], R); } S_FUNC NUMBER * f_cfappr(int count, NUMBER **vals) { long R; NUMBER *q; R = (count > 2) ? qtoi(vals[2]) : conf->cfappr; q = (count > 1) ? vals[1] : conf->epsilon; return qcfappr(vals[0], q, R); } S_FUNC VALUE f_ceil(VALUE *val) { VALUE tmp, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp.v_subtype = V_NOSUBTYPE; tmp.v_type = V_NUM; tmp.v_num = qlink(&_qone_); apprvalue(val, &tmp, &tmp, &res); return res; } S_FUNC VALUE f_floor(VALUE *val) { VALUE tmp1, tmp2, res; /* initialize VALUEs */ res.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; tmp1.v_type = V_NUM; tmp1.v_num = qlink(&_qone_); tmp2.v_type = V_NUM; tmp2.v_num = qlink(&_qzero_); apprvalue(val, &tmp1, &tmp2, &res); return res; } S_FUNC VALUE f_sqrt(int count, VALUE **vals) { VALUE tmp1, tmp2, result; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; tmp1.v_subtype = V_NOSUBTYPE; tmp2.v_subtype = V_NOSUBTYPE; if (count > 2) tmp2 = *vals[2]; else tmp2.v_type = V_NULL; if (count > 1) tmp1 = *vals[1]; else tmp1.v_type = V_NULL; sqrtvalue(vals[0], &tmp1, &tmp2, &result); return result; } S_FUNC VALUE f_root(int count, VALUE **vals) { VALUE *vp, err, result; /* initialize VALUEs */ err.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; if (count > 2) { vp = vals[2]; } else { err.v_num = conf->epsilon; err.v_type = V_NUM; vp = &err; } rootvalue(vals[0], vals[1], vp, &result); return result; } S_FUNC VALUE f_power(int count, VALUE **vals) { VALUE *vp, err, result; /* initialize VALUEs */ err.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; if (count > 2) { vp = vals[2]; } else { err.v_num = conf->epsilon; err.v_type = V_NUM; vp = &err; } powervalue(vals[0], vals[1], vp, &result); return result; } S_FUNC VALUE f_polar(int count, VALUE **vals) { VALUE *vp, err, result; COMPLEX *c; /* initialize VALUEs */ err.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; if (count > 2) { vp = vals[2]; } else { err.v_num = conf->epsilon; err.v_type = V_NUM; vp = &err; } if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM)) return error_value(E_POLAR1); if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) return error_value(E_POLAR2); c = c_polar(vals[0]->v_num, vals[1]->v_num, vp->v_num); result.v_com = c; result.v_type = V_COM; if (cisreal(c)) { result.v_num = qlink(c->real); result.v_type = V_NUM; comfree(c); } return result; } S_FUNC VALUE f_ilog(VALUE *v1, VALUE *v2) { VALUE res; if (v2->v_type != V_NUM || qisfrac(v2->v_num) || qiszero(v2->v_num) || qisunit(v2->v_num)) return error_value(E_ILOGB); switch(v1->v_type) { case V_NUM: res.v_num = qilog(v1->v_num, v2->v_num->num); break; case V_COM: res.v_num = c_ilog(v1->v_com, v2->v_num->num); break; default: return error_value(E_ILOG); } if (res.v_num == NULL) return error_value(E_LOGINF); res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_ilog2(VALUE *vp) { VALUE res; switch(vp->v_type) { case V_NUM: res.v_num = qilog(vp->v_num, _two_); break; case V_COM: res.v_num = c_ilog(vp->v_com, _two_); break; default: return error_value(E_ILOG2); } if (res.v_num == NULL) return error_value(E_LOGINF); res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_ilog10(VALUE *vp) { VALUE res; switch(vp->v_type) { case V_NUM: res.v_num = qilog(vp->v_num, _ten_); break; case V_COM: res.v_num = c_ilog(vp->v_com, _ten_); break; default: return error_value(E_ILOG10); } if (res.v_num == NULL) return error_value(E_LOGINF); res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC NUMBER * f_faccnt(NUMBER *val1, NUMBER *val2) { if (qisfrac(val1) || qisfrac(val2)) math_error("Non-integral argument for fcnt"); return itoq(zdivcount(val1->num, val2->num)); } S_FUNC VALUE f_matfill(int count, VALUE **vals) { VALUE *v1, *v2, *v3; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; v1 = vals[0]; v2 = vals[1]; if (v1->v_type != V_ADDR) return error_value(E_MATFILL1); v1 = v1->v_addr; if (v1->v_subtype & V_NOCOPYTO) return error_value(E_MATFILL3); if (v1->v_type != V_MAT) return error_value(E_MATFILL2); if (v2->v_type == V_ADDR) v2 = v2->v_addr; if (v2->v_subtype & V_NOASSIGNFROM) return error_value(E_MATFILL4); if (count == 3) { v3 = vals[2]; if (v3->v_type == V_ADDR) v3 = v3->v_addr; if (v3->v_subtype & V_NOASSIGNFROM) return error_value(E_MATFILL4); } else v3 = NULL; matfill(v1->v_mat, v2, v3); result.v_type = V_NULL; return result; } S_FUNC VALUE f_matsum(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* firewall */ if (vp->v_type != V_MAT) return error_value(E_MATSUM); /* sum matrix */ matsum(vp->v_mat, &result); return result; } S_FUNC VALUE f_isident(VALUE *vp) { VALUE result; /* initialize VALUEs */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; if (vp->v_type == V_MAT) { result.v_num = itoq((long) matisident(vp->v_mat)); } else { result.v_num = itoq(0); } return result; } S_FUNC VALUE f_mattrace(VALUE *vp) { if (vp->v_type != V_MAT) return error_value(E_MATTRACE1); return mattrace(vp->v_mat); } S_FUNC VALUE f_mattrans(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_MAT) return error_value(E_MATTRANS1); if (vp->v_mat->m_dim > 2) return error_value(E_MATTRANS2); result.v_type = V_MAT; result.v_mat = mattrans(vp->v_mat); return result; } S_FUNC VALUE f_det(VALUE *vp) { if (vp->v_type != V_MAT) return error_value(E_DET1); return matdet(vp->v_mat); } S_FUNC VALUE f_matdim(VALUE *vp) { VALUE result; /* initialize VALUEs */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; switch(vp->v_type) { case V_OBJ: result.v_num = itoq(vp->v_obj->o_actions->oa_count); break; case V_MAT: result.v_num = itoq((long) vp->v_mat->m_dim); break; default: return error_value(E_MATDIM); } return result; } S_FUNC VALUE f_matmin(VALUE *v1, VALUE *v2) { VALUE result; NUMBER *q; long i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_MAT) return error_value(E_MATMIN1); if (v2->v_type != V_NUM) return error_value(E_MATMIN2); q = v2->v_num; if (qisfrac(q) || qisneg(q) || qiszero(q)) return error_value(E_MATMIN2); i = qtoi(q); if (i > v1->v_mat->m_dim) return error_value(E_MATMIN3); result.v_type = V_NUM; result.v_num = itoq(v1->v_mat->m_min[i - 1]); return result; } S_FUNC VALUE f_matmax(VALUE *v1, VALUE *v2) { VALUE result; NUMBER *q; long i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_MAT) return error_value(E_MATMAX1); if (v2->v_type != V_NUM) return error_value(E_MATMAX2); q = v2->v_num; if (qisfrac(q) || qisneg(q) || qiszero(q)) return error_value(E_MATMAX2); i = qtoi(q); if (i > v1->v_mat->m_dim) return error_value(E_MATMAX3); result.v_type = V_NUM; result.v_num = itoq(v1->v_mat->m_max[i - 1]); return result; } S_FUNC VALUE f_cp(VALUE *v1, VALUE *v2) { MATRIX *m1, *m2; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) return error_value(E_CP1); m1 = v1->v_mat; m2 = v2->v_mat; if ((m1->m_dim != 1) || (m2->m_dim != 1)) return error_value(E_CP2); if ((m1->m_size != 3) || (m2->m_size != 3)) return error_value(E_CP3); result.v_type = V_MAT; result.v_mat = matcross(m1, m2); return result; } S_FUNC VALUE f_dp(VALUE *v1, VALUE *v2) { MATRIX *m1, *m2; if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) return error_value(E_DP1); m1 = v1->v_mat; m2 = v2->v_mat; if ((m1->m_dim != 1) || (m2->m_dim != 1)) return error_value(E_DP2); if (m1->m_size != m2->m_size) return error_value(E_DP3); return matdot(m1, m2); } S_FUNC VALUE f_strlen(VALUE *vp) { VALUE result; long len = 0; char *c; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_STR) return error_value(E_STRLEN); c = vp->v_str->s_str; while (*c++) len++; result.v_type = V_NUM; result.v_num = itoq(len); return result; } S_FUNC VALUE f_strcmp(VALUE *v1, VALUE *v2) { VALUE result; FLAG flag; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR || v2->v_type != V_STR) return error_value(E_STRCMP); flag = stringrel(v1->v_str, v2->v_str); result.v_type = V_NUM; result.v_num = itoq((long) flag); return result; } S_FUNC VALUE f_strncmp(VALUE *v1, VALUE *v2, VALUE *v3) { long n1, n2, n; FLAG flag; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR || v2->v_type != V_STR || v3->v_type != V_NUM || qisneg(v3->v_num) || qisfrac(v3->v_num) || zge31b(v3->v_num->num)) return error_value(E_STRNCMP); n1 = v1->v_str->s_len; n2 = v2->v_str->s_len; n = qtoi(v3->v_num); if (n < n1) v1->v_str->s_len = n; if (n < n2) v2->v_str->s_len = n; flag = stringrel(v1->v_str, v2->v_str); v1->v_str->s_len = n1; v2->v_str->s_len = n2; result.v_type = V_NUM; result.v_num = itoq((long) flag); return result; } S_FUNC VALUE f_strcat(int count, VALUE **vals) { VALUE **vp; char *c, *c1; int i; long len; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; len = 0; result.v_type = V_STR; vp = vals; for (i = 0; i < count; i++, vp++) { if ((*vp)->v_type != V_STR) return error_value(E_STRCAT); c = (*vp)->v_str->s_str; while (*c++) len++; } if (len == 0) { result.v_str = slink(&_nullstring_); return result; } c = (char *) malloc(len + 1) ; if (c == NULL) { math_error("No memory for strcat"); /*NOTREACHED*/ } result.v_str = stralloc(); result.v_str->s_str = c; result.v_str->s_len = len; for (vp = vals; count-- > 0; vp++) { c1 = (*vp)->v_str->s_str; while (*c1) *c++ = *c1++; } *c = '\0'; return result; } S_FUNC VALUE f_strcpy(VALUE *v1, VALUE *v2) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR || v2->v_type != V_STR) return error_value(E_STRCPY); result.v_str = stringcpy(v1->v_str, v2->v_str); result.v_type = V_STR; return result; } S_FUNC VALUE f_strncpy(VALUE *v1, VALUE *v2, VALUE *v3) { VALUE result; long num; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR || v2->v_type != V_STR || v3->v_type != V_NUM || qisfrac(v3->v_num) || qisneg(v3->v_num)) return error_value(E_STRNCPY); if (zge31b(v3->v_num->num)) num = v2->v_str->s_len; else num = qtoi(v3->v_num); result.v_str = stringncpy(v1->v_str, v2->v_str, num); result.v_type = V_STR; return result; } S_FUNC VALUE f_substr(VALUE *v1, VALUE *v2, VALUE *v3) { NUMBER *q1, *q2; size_t start, len; char *cp; char *ccp; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR) return error_value(E_SUBSTR1); if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM)) return error_value(E_SUBSTR2); q1 = v2->v_num; q2 = v3->v_num; if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2)) return error_value(E_SUBSTR2); start = qtoi(q1); len = qtoi(q2); if (start > 0) start--; result.v_type = V_STR; if (start >= v1->v_str->s_len || len == 0) { result.v_str = slink(&_nullstring_); return result; } if (len > v1->v_str->s_len - start) len = v1->v_str->s_len - start; cp = v1->v_str->s_str + start; ccp = (char *) malloc(len + 1); if (ccp == NULL) { math_error("No memory for substr"); /*NOTREACHED*/ } result.v_str = stralloc(); result.v_str->s_len = len; result.v_str->s_str = ccp; while (len-- > 0) *ccp++ = *cp++; *ccp = '\0'; return result; } S_FUNC VALUE f_char(VALUE *vp) { char ch; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; switch(vp->v_type) { case V_NUM: if (qisfrac(vp->v_num)) return error_value(E_CHAR); ch = (char) vp->v_num->num.v[0]; if (qisneg(vp->v_num)) ch = -ch; break; case V_OCTET: ch = *vp->v_octet; break; case V_STR: ch = *vp->v_str->s_str; break; default: return error_value(E_CHAR); } result.v_type = V_STR; result.v_str = charstring(ch); return result; } S_FUNC VALUE f_ord(VALUE *vp) { OCTET *c; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; switch(vp->v_type) { case V_STR: c = (OCTET *)vp->v_str->s_str; break; case V_OCTET: c = vp->v_octet; break; default: return error_value(E_ORD); } result.v_type = V_NUM; result.v_num = itoq((long) (*c & 0xff)); return result; } S_FUNC VALUE f_protect(int count, VALUE **vals) { int i, depth; VALUE *v1, *v2, *v3; VALUE result; BOOL have_nblock; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; v1 = vals[0]; have_nblock = (v1->v_type == V_NBLOCK); if (!have_nblock) { if (v1->v_type != V_ADDR) return error_value(E_PROTECT1); v1 = v1->v_addr; } if (count == 1) { result.v_type = V_NUM; if (have_nblock) result.v_num = itoq(v1->v_nblock->subtype); else result.v_num = itoq(v1->v_subtype); return result; } v2 = vals[1]; if (v2->v_type == V_ADDR) v2 = v2->v_addr; if (v2->v_type != V_NUM||qisfrac(v2->v_num)||zge16b(v2->v_num->num)) return error_value(E_PROTECT2); i = qtoi(v2->v_num); depth = 0; if (count > 2) { v3 = vals[2]; if (v3->v_type == V_ADDR) v3 = v3->v_addr; if (v3->v_type != V_NUM || qisfrac(v3->v_num) || qisneg(v3->v_num) || zge31b(v3->v_num->num)) return error_value(E_PROTECT3); depth = qtoi(v3->v_num); } protecttodepth(v1, i, depth); return result; } S_FUNC VALUE f_size(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* * return information about the number of elements * * This is not the sizeof, see f_sizeof() for that information. * This is not the memsize, see f_memsize() for that information. * * The size of a file is treated in a special way ... we do * not use the number of elements, but rather the length * of the file as would be reported by fsize(). */ if (vp->v_type == V_FILE) { return f_fsize(vp); } else { result.v_type = V_NUM; result.v_num = itoq(elm_count(vp)); } return result; } S_FUNC VALUE f_sizeof(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; /* * return information about memory footprint * * This is not the number of elements, see f_size() for that info. * This is not the memsize, see f_memsize() for that information. */ result.v_num = itoq(lsizeof(vp)); return result; } S_FUNC VALUE f_memsize(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; /* * return information about memory footprint * * This is not the number of elements, see f_size() for that info. * This is not the sizeof, see f_sizeof() for that information. */ result.v_num = itoq(memsize(vp)); return result; } S_FUNC VALUE f_search(int count, VALUE **vals) { VALUE *v1, *v2, *v3, *v4; NUMBER *start, *end; VALUE vsize; NUMBER *size; ZVALUE pos; ZVALUE indx; long len; ZVALUE zlen, tmp; VALUE result; long l_start = 0, l_end = 0; int i = 0; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; vsize.v_subtype = V_NOSUBTYPE; v1 = *vals++; v2 = *vals++; if ((v1->v_type == V_FILE || v1->v_type == V_STR) && v2->v_type != V_STR) return error_value(E_SEARCH2); start = end = NULL; if (count > 2) { v3 = *vals++; if (v3->v_type != V_NUM && v3->v_type != V_NULL) return error_value(E_SEARCH3); if (v3->v_type == V_NUM) { start = v3->v_num; if (qisfrac(start)) return error_value(E_SEARCH3); } } if (count > 3) { v4 = *vals; if (v4->v_type != V_NUM && v4->v_type != V_NULL) return error_value(E_SEARCH4); if (v4->v_type == V_NUM) { end = v4->v_num; if (qisfrac(end)) return error_value(E_SEARCH4); } } result.v_type = V_NULL; vsize = f_size(v1); if (vsize.v_type != V_NUM) return error_value(E_SEARCH5); size = vsize.v_num; if (start) { if (qisneg(start)) { start = qqadd(size, start); if (qisneg(start)) { qfree(start); start = qlink(&_qzero_); } } else { start = qlink(start); } } if (end) { if (!qispos(end)) { end = qqadd(size, end); } else { if (qrel(end, size) > 0) end = qlink(size); else end = qlink(end); } } if (v1->v_type == V_FILE) { if (count == 2|| (count == 4 && (start == NULL || end == NULL))) { i = ftellid(v1->v_file, &pos); if (i < 0) { qfree(size); if (start) qfree(start); if (end) qfree(end); return error_value(E_SEARCH5); } if (count == 2 || (count == 4 && end != NULL)) { start = qalloc(); start->num = pos; } else { end = qalloc(); end->num = pos; } } if (start == NULL) start = qlink(&_qzero_); if (end == NULL) end = size; else qfree(size); len = v2->v_str->s_len; utoz(len, &zlen); zsub(end->num, zlen, &tmp); zfree(zlen); i = fsearch(v1->v_file, v2->v_str->s_str, start->num, tmp, &indx); zfree(tmp); if (i == 2) { result.v_type = V_NUM; result.v_num = start; qfree(end); return result; } qfree(start); qfree(end); if (i == EOF) return error_value(errno); if (i < 0) return error_value(E_SEARCH6); if (i == 0) { result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = indx; } return result; } if (start == NULL) start = qlink(&_qzero_); if (end == NULL) end = qlink(size); if (qrel(start, end) >= 0) { qfree(size); qfree(start); qfree(end); return result; } qfree(size); l_start = ztolong(start->num); l_end = ztolong(end->num); switch (v1->v_type) { case V_MAT: i = matsearch(v1->v_mat, v2, l_start, l_end, &indx); break; case V_LIST: i = listsearch(v1->v_list, v2, l_start, l_end, &indx); break; case V_ASSOC: i = assocsearch(v1->v_assoc, v2, l_start, l_end, &indx); break; case V_STR: i = stringsearch(v1->v_str, v2->v_str, l_start, l_end, &indx); break; default: qfree(start); qfree(end); return error_value(E_SEARCH1); } qfree(start); qfree(end); if (i == 0) { result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = indx; } return result; } S_FUNC VALUE f_rsearch(int count, VALUE **vals) { VALUE *v1, *v2, *v3, *v4; NUMBER *start, *end; VALUE vsize; NUMBER *size; NUMBER *qlen; NUMBER *qtmp; ZVALUE pos; ZVALUE indx; VALUE result; long l_start = 0, l_end = 0; int i; /* initialize VALUEs */ vsize.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; v1 = *vals++; v2 = *vals++; if ((v1->v_type == V_FILE || v1->v_type == V_STR) && v2->v_type != V_STR) return error_value(E_RSEARCH2); start = end = NULL; if (count > 2) { v3 = *vals++; if (v3->v_type != V_NUM && v3->v_type != V_NULL) return error_value(E_RSEARCH3); if (v3->v_type == V_NUM) { start = v3->v_num; if (qisfrac(start)) return error_value(E_RSEARCH3); } } if (count > 3) { v4 = *vals; if (v4->v_type != V_NUM && v4->v_type != V_NULL) return error_value(E_RSEARCH4); if (v4->v_type == V_NUM) { end = v4->v_num; if (qisfrac(end)) return error_value(E_RSEARCH3); } } result.v_type = V_NULL; vsize = f_size(v1); if (vsize.v_type != V_NUM) return error_value(E_RSEARCH5); size = vsize.v_num; if (start) { if (qisneg(start)) { start = qqadd(size, start); if (qisneg(start)) { qfree(start); start = qlink(&_qzero_); } } else start = qlink(start); } if (end) { if (!qispos(end)) { end = qqadd(size, end); } else { if (qrel(end, size) > 0) end = qlink(size); else end = qlink(end); } } if (v1->v_type == V_FILE) { if (count == 2 || (count == 4 && (start == NULL || end == NULL))) { i = ftellid(v1->v_file, &pos); if (i < 0) { qfree(size); if (start) qfree(start); if (end) qfree(end); return error_value(E_RSEARCH5); } if (count == 2 || (count == 4 && end != NULL)) { start = qalloc(); start->num = pos; } else { end = qalloc(); end->num = pos; } } qlen = utoq(v2->v_str->s_len); qtmp = qsub(size, qlen); qfree(size); size = qtmp; if (count < 4) { end = start; start = NULL; } else { qtmp = qsub(end, qlen); qfree(end); end = qtmp; } if (end == NULL) end = qlink(size); if (start == NULL) start = qlink(&_qzero_); if (qrel(end, size) > 0) { qfree(end); end = qlink(size); } qfree(qlen); qfree(size); if (qrel(start, end) > 0) { qfree(start); qfree(end); return result; } i = frsearch(v1->v_file, v2->v_str->s_str, end->num,start->num, &indx); qfree(start); qfree(end); if (i == EOF) return error_value(errno); if (i < 0) return error_value(E_RSEARCH6); if (i == 0) { result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = indx; } return result; } if (count < 4) { if (start) { end = qinc(start); qfree(start); } else end = qlink(size); start = qlink(&_qzero_); } else { if (start == NULL) start = qlink(&_qzero_); if (end == NULL) end = qlink(size); } qfree(size); if (qrel(start, end) >= 0) { qfree(start); qfree(end); return result; } l_start = ztolong(start->num); l_end = ztolong(end->num); switch (v1->v_type) { case V_MAT: i = matrsearch(v1->v_mat, v2, l_start, l_end, &indx); break; case V_LIST: i = listrsearch(v1->v_list, v2, l_start, l_end, &indx); break; case V_ASSOC: i = assocrsearch(v1->v_assoc, v2, l_start, l_end, &indx); break; case V_STR: i = stringrsearch(v1->v_str, v2->v_str, l_start, l_end, &indx); break; default: qfree(start); qfree(end); return error_value(E_RSEARCH1); } qfree(start); qfree(end); if (i == 0) { result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = indx; } return result; } S_FUNC VALUE f_list(int count, VALUE **vals) { VALUE result; /* initialize VALUE */ result.v_type = V_LIST; result.v_subtype = V_NOSUBTYPE; result.v_list = listalloc(); while (count-- > 0) insertlistlast(result.v_list, *vals++); return result; } /*ARGSUSED*/ S_FUNC VALUE f_assoc(int UNUSED count, VALUE UNUSED **vals) { VALUE result; /* initialize VALUE */ result.v_type = V_ASSOC; result.v_subtype = V_NOSUBTYPE; result.v_assoc = assocalloc(0L); return result; } S_FUNC VALUE f_indices(VALUE *v1, VALUE *v2) { VALUE result; LIST *lp; if (v2->v_type != V_NUM || zge31b(v2->v_num->num)) return error_value(E_INDICES2); switch (v1->v_type) { case V_ASSOC: lp = associndices(v1->v_assoc, qtoi(v2->v_num)); break; case V_MAT: lp = matindices(v1->v_mat, qtoi(v2->v_num)); break; default: return error_value(E_INDICES1); } result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; if (lp) { result.v_type = V_LIST; result.v_list = lp; } return result; } S_FUNC VALUE f_listinsert(int count, VALUE **vals) { VALUE *v1, *v2, *v3; VALUE result; long pos; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; v1 = *vals++; if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) return error_value(E_INSERT1); if (v1->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST1); v2 = *vals++; if (v2->v_type == V_ADDR) v2 = v2->v_addr; if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) return error_value(E_INSERT2); pos = qtoi(v2->v_num); count--; while (--count > 0) { v3 = *vals++; if (v3->v_type == V_ADDR) v3 = v3->v_addr; insertlistmiddle(v1->v_addr->v_list, pos++, v3); } result.v_type = V_NULL; return result; } S_FUNC VALUE f_listpush(int count, VALUE **vals) { VALUE result; VALUE *v1, *v2; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; v1 = *vals++; if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) return error_value(E_PUSH); if (v1->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST3); while (--count > 0) { v2 = *vals++; if (v2->v_type == V_ADDR) v2 = v2->v_addr; insertlistfirst(v1->v_addr->v_list, v2); } result.v_type = V_NULL; return result; } S_FUNC VALUE f_listappend(int count, VALUE **vals) { VALUE *v1, *v2; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; v1 = *vals++; if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) return error_value(E_APPEND); if (v1->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST4); while (--count > 0) { v2 = *vals++; if (v2->v_type == V_ADDR) v2 = v2->v_addr; insertlistlast(v1->v_addr->v_list, v2); } result.v_type = V_NULL; return result; } S_FUNC VALUE f_listdelete(VALUE *v1, VALUE *v2) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) return error_value(E_DELETE1); if (v1->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST2); if (v2->v_type == V_ADDR) v2 = v2->v_addr; if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) return error_value(E_DELETE2); removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result); return result; } S_FUNC VALUE f_listpop(VALUE *vp) { VALUE result; if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST)) return error_value(E_POP); if (vp->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST5); removelistfirst(vp->v_addr->v_list, &result); return result; } S_FUNC VALUE f_listremove(VALUE *vp) { VALUE result; if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST)) return error_value(E_REMOVE); if (vp->v_addr->v_subtype & V_NOREALLOC) return error_value(E_LIST6); removelistlast(vp->v_addr->v_list, &result); return result; } /* * Return the current user time of calc in seconds. */ S_FUNC NUMBER * f_usertime(void) { #if defined(HAVE_GETRUSAGE) struct rusage usage; /* system resource usage */ int who = RUSAGE_SELF; /* obtain time for just this process */ int status; /* getrusage() return code */ NUMBER *ret; /* CPU time to return */ NUMBER *secret; /* whole sconds of CPU time to return */ NUMBER *usecret; /* microseconds of CPU time to return */ /* get the resource informaion for ourself */ status = getrusage(who, &usage); if (status < 0) { /* system call error, so return 0 */ return qlink(&_qzero_); } /* add user time */ secret = stoq(usage.ru_utime.tv_sec); usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L); ret = qqadd(secret, usecret); qfree(secret); qfree(usecret); /* return user CPU time */ return ret; #else /* HAVE_GETRUSAGE */ /* not a POSIX system */ return qlink(&_qzero_); #endif /* HAVE_GETRUSAGE */ } /* * Return the current kernel time of calc in seconds. * This is the kernel mode time only. */ S_FUNC NUMBER * f_systime(void) { #if defined(HAVE_GETRUSAGE) struct rusage usage; /* system resource usage */ int who = RUSAGE_SELF; /* obtain time for just this process */ int status; /* getrusage() return code */ NUMBER *ret; /* CPU time to return */ NUMBER *secret; /* whole sconds of CPU time to return */ NUMBER *usecret; /* microseconds of CPU time to return */ /* get the resource informaion for ourself */ status = getrusage(who, &usage); if (status < 0) { /* system call error, so return 0 */ return qlink(&_qzero_); } /* add kernel time */ secret = stoq(usage.ru_stime.tv_sec); usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L); ret = qqadd(secret, usecret); qfree(secret); qfree(usecret); /* return kernel CPU time */ return ret; #else /* HAVE_GETRUSAGE */ /* not a POSIX system */ return qlink(&_qzero_); #endif /* HAVE_GETRUSAGE */ } /* * Return the current user and kernel time of calc in seconds. */ S_FUNC NUMBER * f_runtime(void) { #if defined(HAVE_GETRUSAGE) struct rusage usage; /* system resource usage */ int who = RUSAGE_SELF; /* obtain time for just this process */ int status; /* getrusage() return code */ NUMBER *user; /* user CPU time to return */ NUMBER *sys; /* kernel CPU time to return */ NUMBER *ret; /* total CPU time to return */ NUMBER *secret; /* whole sconds of CPU time to return */ NUMBER *usecret; /* microseconds of CPU time to return */ /* get the resource informaion for ourself */ status = getrusage(who, &usage); if (status < 0) { /* system call error, so return 0 */ return qlink(&_qzero_); } /* add kernel time */ secret = stoq(usage.ru_stime.tv_sec); usecret = iitoq((long)usage.ru_stime.tv_usec, 1000000L); sys = qqadd(secret, usecret); qfree(secret); qfree(usecret); /* add user time */ secret = stoq(usage.ru_utime.tv_sec); usecret = iitoq((long)usage.ru_utime.tv_usec, 1000000L); user = qqadd(secret, usecret); qfree(secret); qfree(usecret); /* total time is user + kernel */ ret = qqadd(user, sys); qfree(user); qfree(sys); /* return CPU time */ return ret; #else /* HAVE_GETRUSAGE */ /* not a POSIX system */ return qlink(&_qzero_); #endif /* HAVE_GETRUSAGE */ } /* * return the number of second since the Epoch (00:00:00 1 Jan 1970 UTC). */ S_FUNC NUMBER * f_time(void) { return itoq((long) time(0)); } /* * time in asctime()/ctime() format */ S_FUNC VALUE f_ctime(void) { VALUE res; time_t now; /* the current time */ /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; res.v_type = V_STR; /* get the time */ now = time(NULL); res.v_str = makenewstring(ctime(&now)); return res; } S_FUNC VALUE f_fopen(VALUE *v1, VALUE *v2) { VALUE result; FILEID id; char *mode; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* check for a valid mode [rwa][b+\0][b+\0] */ if (v1->v_type != V_STR || v2->v_type != V_STR) return error_value(E_FOPEN1); mode = v2->v_str->s_str; if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) return error_value(E_FOPEN2); if (mode[1] != '\0') { if (mode[1] != '+' && mode[1] != 'b') return error_value(E_FOPEN2); if (mode[2] != '\0') { if ((mode[2] != '+' && mode[2] != 'b') || mode[1] == mode[2]) return error_value(E_FOPEN2); if (mode[3] != '\0') return error_value(E_FOPEN2); } } /* try to open */ errno = 0; id = openid(v1->v_str->s_str, v2->v_str->s_str); if (id == FILEID_NONE) return error_value(errno); if (id < 0) return error_value(-id); result.v_type = V_FILE; result.v_file = id; return result; } S_FUNC VALUE f_fpathopen(int count, VALUE **vals) { VALUE result; FILEID id; char *mode; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* check for valid strongs */ if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) { return error_value(E_FPATHOPEN1); } if (count == 3 && vals[2]->v_type != V_STR) { return error_value(E_FPATHOPEN1); } /* check for a valid mode [rwa][b+\0][b+\0] */ mode = vals[1]->v_str->s_str; if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) return error_value(E_FPATHOPEN2); if (mode[1] != '\0') { if (mode[1] != '+' && mode[1] != 'b') return error_value(E_FPATHOPEN2); if (mode[2] != '\0') { if ((mode[2] != '+' && mode[2] != 'b') || mode[1] == mode[2]) return error_value(E_FPATHOPEN2); if (mode[3] != '\0') return error_value(E_FPATHOPEN2); } } /* try to open along a path */ errno = 0; if (count == 2) { id = openpathid(vals[0]->v_str->s_str, vals[1]->v_str->s_str, calcpath); } else { id = openpathid(vals[0]->v_str->s_str, vals[1]->v_str->s_str, vals[2]->v_str->s_str); } if (id == FILEID_NONE) return error_value(errno); if (id < 0) return error_value(-id); result.v_type = V_FILE; result.v_file = id; return result; } S_FUNC VALUE f_freopen(int count, VALUE **vals) { VALUE result; FILEID id; char *mode; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* check for a valid mode [rwa][b+\0][b+\0] */ if (vals[0]->v_type != V_FILE) return error_value(E_FREOPEN1); if (vals[1]->v_type != V_STR) return error_value(E_FREOPEN2); mode = vals[1]->v_str->s_str; if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) return error_value(E_FREOPEN2); if (mode[1] != '\0') { if (mode[1] != '+' && mode[1] != 'b') return error_value(E_FREOPEN2); if (mode[2] != '\0') { if ((mode[2] != '+' && mode[2] != 'b') || mode[1] == mode[2]) return error_value(E_FOPEN2); if (mode[3] != '\0') return error_value(E_FREOPEN2); } } /* try to reopen */ errno = 0; if (count == 2) { id = reopenid(vals[0]->v_file, mode, NULL); } else { if (vals[2]->v_type != V_STR) return error_value(E_FREOPEN3); id = reopenid(vals[0]->v_file, mode, vals[2]->v_str->s_str); } if (id == FILEID_NONE) return error_value(errno); result.v_type = V_NULL; return result; } S_FUNC VALUE f_errno(int count, VALUE **vals) { int newerr, olderr; VALUE *vp; VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; newerr = -1; if (count > 0) { vp = vals[0]; if (vp->v_type <= 0) { newerr = (int) -vp->v_type; (void) set_errno(newerr); result.v_num = itoq((long) newerr); return result; } /* arg must be an integer */ if (vp->v_type != V_NUM || qisfrac(vp->v_num) || qisneg(vp->v_num) || zge16b(vp->v_num->num)) { math_error("errno argument out of range"); /*NOTREACHED*/ } newerr = (int) ztoi(vp->v_num->num); } olderr = set_errno(newerr); result.v_num = itoq((long) olderr); return result; } S_FUNC VALUE f_errcount(int count, VALUE **vals) { int newcount, oldcount; VALUE *vp; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; newcount = -1; if (count > 0) { vp = vals[0]; /* arg must be an integer */ if (vp->v_type != V_NUM || qisfrac(vp->v_num) || qisneg(vp->v_num) || zge31b(vp->v_num->num)) { math_error("errcount argument out of range"); /*NOTREACHED*/ } newcount = (int) ztoi(vp->v_num->num); } oldcount = set_errcount(newcount); result.v_type = V_NUM; result.v_num = itoq((long) oldcount); return result; } S_FUNC VALUE f_errmax(int count, VALUE **vals) { long oldmax; VALUE *vp; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; oldmax = errmax; if (count > 0) { vp = vals[0]; if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) { fprintf(stderr, "Out-of-range arg for errmax ignored\n"); } else { errmax = ztoi(vp->v_num->num); } } result.v_type = V_NUM; result.v_num = itoq((long) oldmax); return result; } S_FUNC VALUE f_stoponerror(int count, VALUE **vals) { long oldval; VALUE *vp; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; oldval = stoponerror; if (count > 0) { vp = vals[0]; if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num) || zltnegone(vp->v_num->num)) { fprintf(stderr, "Out-of-range arg for stoponerror ignored\n"); } else { stoponerror = ztoi(vp->v_num->num); } } result.v_type = V_NUM; result.v_num = itoq((long) oldval); return result; } S_FUNC VALUE f_fclose(int count, VALUE **vals) { VALUE result; VALUE *vp; int n, i=0; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; errno = 0; if (count == 0) { i = closeall(); } else { for (n = 0; n < count; n++) { vp = vals[n]; if (vp->v_type != V_FILE) return error_value(E_FCLOSE1); } for (n = 0; n < count; n++) { vp = vals[n]; i = closeid(vp->v_file); if (i < 0) return error_value(E_REWIND2); } } if (i < 0) return error_value(errno); result.v_type = V_NULL; return result; } S_FUNC VALUE f_rm(int count, VALUE **vals) { VALUE result; int force; /* TRUE -> -f was given as 1st arg */ int i; int j; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* * firewall */ if (!allow_write) return error_value(E_WRPERM); /* * check on each arg */ for (i=0; i < count; ++i) { if (vals[i]->v_type != V_STR) return error_value(E_RM1); if (vals[i]->v_str->s_str[0] == '\0') return error_value(E_RM1); } /* * look for a leading -f option */ force = (strcmp(vals[0]->v_str->s_str, "-f") == 0); if (force) { --count; ++vals; } /* * remove file(s) */ for (i=0; i < count; ++i) { j = remove(vals[i]->v_str->s_str); if (!force && j < 0) return error_value(errno); } result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; return result; } S_FUNC VALUE f_newerror(int count, VALUE **vals) { char *str; int index; int errnum; str = NULL; if (count > 0 && vals[0]->v_type == V_STR) str = vals[0]->v_str->s_str; if (str == NULL || str[0] == '\0') str = "???"; if (nexterrnum == E_USERDEF) initstr(&newerrorstr); index = findstr(&newerrorstr, str); if (index >= 0) { errnum = E_USERDEF + index; } else { if (nexterrnum == 32767) math_error("Too many new error values"); errnum = nexterrnum++; addstr(&newerrorstr, str); } return error_value(errnum); } S_FUNC VALUE f_strerror(int count, VALUE **vals) { VALUE *vp; VALUE result; long i; char *cp; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* parse args */ if (count > 0) { vp = vals[0]; if (vp->v_type < 0) { i = (long) -vp->v_type; } else { if (vp->v_type != V_NUM || qisfrac(vp->v_num)) return error_value(E_STRERROR1); i = qtoi(vp->v_num); if (i < 0 || i > 32767) return error_value(E_STRERROR2); } } else { i = set_errno(-1); } /* setup return type */ result.v_type = V_STR; /* change the meaning of error 0 */ if (i == 0) i = E__BASE; /* firewall - return generic error string if it is not assigned */ if (i >= nexterrnum || (i > E__HIGHEST && i < E_USERDEF) || (i < E__BASE && strerror(i) == NULL)) { cp = (char *) malloc(sizeof("Error 1234567890")+1); if (cp == NULL) { math_error("Out of memory for strerror"); /*NOTREACHED*/ } sprintf(cp, "Unknown error %ld", i); result.v_str = makestring(cp); return result; } /* system error */ if (i < E__BASE) { cp = strerror(i); /* user-described error */ } else if (i >= E_USERDEF) { cp = namestr(&newerrorstr, i - E_USERDEF); /* calc-described error */ } else { cp = (char *)error_table[i - E__BASE]; } /* return result as a V_STR */ result.v_str = makenewstring(cp); return result; } S_FUNC VALUE f_ferror(VALUE *vp) { VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FERROR1); i = errorid(vp->v_file); if (i < 0) return error_value(E_FERROR2); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_feof(VALUE *vp) { VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FEOF1); i = eofid(vp->v_file); if (i < 0) return error_value(E_FEOF2); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_fflush(int count, VALUE **vals) { VALUE result; int i, n; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; i = 0; errno = 0; if (count == 0) { i = flushall(); } else { for (n = 0; n < count; n++) { if (vals[n]->v_type != V_FILE) return error_value(E_FFLUSH); } for (n = 0; n < count; n++) { i |= flushid(vals[n]->v_file); } } if (i == EOF) return error_value(errno); result.v_type = V_NULL; return result; } S_FUNC VALUE f_error(int count, VALUE **vals) { VALUE *vp; long r; if (count > 0) { vp = vals[0]; if (vp->v_type <= 0) { r = (long) -vp->v_type; } else { if (vp->v_type != V_NUM || qisfrac(vp->v_num)) { r = E_ERROR1; } else { r = qtoi(vp->v_num); if (r < 0 || r >= 32768) r = E_ERROR2; } } } else { r = set_errno(-1); } return error_value(r); } S_FUNC VALUE f_iserror(VALUE *vp) { VALUE res; /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; res.v_type = V_NUM; res.v_num = itoq((long)((vp->v_type < 0) ? - vp->v_type : 0)); return res; } S_FUNC VALUE f_fsize(VALUE *vp) { VALUE result; ZVALUE len; /* file length */ int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FSIZE1); i = getsize(vp->v_file, &len); if (i == EOF) return error_value(errno); if (i) return error_value(E_FSIZE2); result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = len; return result; } S_FUNC VALUE f_fseek(int count, VALUE **vals) { VALUE result; int whence; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* firewalls */ errno = 0; if (vals[0]->v_type != V_FILE) return error_value(E_FSEEK1); if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) return error_value(E_FSEEK2); if (count == 2) { whence = 0; } else { if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num) || qisneg(vals[2]->v_num)) return error_value(E_FSEEK2); if (vals[2]->v_num->num.len > 1) return error_value (E_FSEEK2); whence = (int)(unsigned int)(vals[2]->v_num->num.v[0]); if (whence > 2) return error_value (E_FSEEK2); } i = fseekid(vals[0]->v_file, vals[1]->v_num->num, whence); result.v_type = V_NULL; if (i == EOF) return error_value(errno); if (i < 0) return error_value(E_FSEEK3); return result; } S_FUNC VALUE f_ftell(VALUE *vp) { VALUE result; ZVALUE pos; /* current file position */ int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; errno = 0; if (vp->v_type != V_FILE) return error_value(E_FTELL1); i = ftellid(vp->v_file, &pos); if (i < 0) return error_value(E_FTELL2); result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = pos; return result; } S_FUNC VALUE f_rewind(int count, VALUE **vals) { VALUE result; int n; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (count == 0) { rewindall(); } else { for (n = 0; n < count; n++) { if (vals[n]->v_type != V_FILE) return error_value(E_REWIND1); } for (n = 0; n < count; n++) { if (rewindid(vals[n]->v_file) != 0) { return error_value(E_REWIND2); } } } result.v_type = V_NULL; return result; } S_FUNC VALUE f_fprintf(int count, VALUE **vals) { VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type != V_FILE) return error_value(E_FPRINTF1); if (vals[1]->v_type != V_STR) return error_value(E_FPRINTF2); i = idprintf(vals[0]->v_file, vals[1]->v_str->s_str, count - 2, vals + 2); if (i > 0) return error_value(E_FPRINTF3); result.v_type = V_NULL; return result; } S_FUNC int strscan(char *s, int count, VALUE **vals) { char ch, chtmp; char *s0; int n = 0; VALUE val, result; VALUE *var; /* initialize VALUEs */ val.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; val.v_type = V_STR; while (*s != '\0') { s--; while ((ch = *++s)) { if (!isspace((int)ch)) break; } if (ch == '\0' || count-- == 0) return n; s0 = s; while ((ch = *++s)) { if (isspace((int)ch)) break; } chtmp = ch; *s = '\0'; n++; val.v_str = makenewstring(s0); result = f_eval(&val); var = *vals++; if (var->v_type == V_ADDR) { var = var->v_addr; freevalue(var); *var = result; } *s = chtmp; } return n; } S_FUNC int filescan(FILEID id, int count, VALUE **vals) { STRING *str; int i; int n = 0; VALUE val; VALUE result; VALUE *var; /* initialize VALUEs */ val.v_type = V_STR; val.v_subtype = V_NOSUBTYPE; result.v_subtype = V_NOSUBTYPE; while (count-- > 0) { i = readid(id, 6, &str); if (i == EOF) break; if (i > 0) return EOF; n++; val.v_str = str; result = f_eval(&val); var = *vals++; if (var->v_type == V_ADDR) { var = var->v_addr; freevalue(var); *var = result; } } return n; } S_FUNC VALUE f_scan(int count, VALUE **vals) { char *cp; VALUE result; int i; /* initialize VALUEs */ result.v_subtype = V_NOSUBTYPE; cp = nextline(); if (cp == NULL) { result.v_type = V_NULL; return result; } i = strscan(cp, count, vals); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_strscan(int count, VALUE **vals) { VALUE *vp; VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; vp = *vals; if (vp->v_type == V_ADDR) vp = vp->v_addr; if (vp->v_type != V_STR) return error_value(E_STRSCAN); i = strscan(vp->v_str->s_str, count - 1, vals + 1); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_fscan(int count, VALUE **vals) { VALUE *vp; VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; errno = 0; vp = *vals; if (vp->v_type == V_ADDR) vp = vp->v_addr; if (vp->v_type != V_FILE) return error_value(E_FSCAN1); i = filescan(vp->v_file, count - 1, vals + 1); if (i == EOF) return error_value(errno); if (i < 0) return error_value(E_FSCAN2); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_scanf(int count, VALUE **vals) { VALUE *vp; VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; vp = *vals; if (vp->v_type == V_ADDR) vp = vp->v_addr; if (vp->v_type != V_STR) return error_value(E_SCANF1); for (i = 1; i < count; i++) { if (vals[i]->v_type != V_ADDR) return error_value(E_SCANF2); } i = fscanfid(FILEID_STDIN, vp->v_str->s_str, count - 1, vals + 1); if (i < 0) return error_value(E_SCANF3); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_strscanf(int count, VALUE **vals) { VALUE *vp, *vq; VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; errno = 0; vp = vals[0]; if (vp->v_type == V_ADDR) vp = vp->v_addr; if (vp->v_type != V_STR) return error_value(E_STRSCANF1); vq = vals[1]; if (vq->v_type == V_ADDR) vq = vq->v_addr; if (vq->v_type != V_STR) return error_value(E_STRSCANF2); for (i = 2; i < count; i++) { if (vals[i]->v_type != V_ADDR) return error_value(E_STRSCANF3); } i = scanfstr(vp->v_str->s_str, vq->v_str->s_str, count - 2, vals + 2); if (i == EOF) return error_value(errno); if (i < 0) return error_value(E_STRSCANF4); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_fscanf(int count, VALUE **vals) { VALUE *vp, *sp; VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; vp = *vals++; if (vp->v_type == V_ADDR) vp = vp->v_addr; if (vp->v_type != V_FILE) return error_value(E_FSCANF1); sp = *vals++; if (sp->v_type == V_ADDR) sp = sp->v_addr; if (sp->v_type != V_STR) return error_value(E_FSCANF2); for (i = 0; i < count - 2; i++) { if (vals[i]->v_type != V_ADDR) return error_value(E_FSCANF3); } i = fscanfid(vp->v_file, sp->v_str->s_str, count - 2, vals); if (i == EOF) { result.v_type = V_NULL; return result; } if (i < 0) return error_value(E_FSCANF4); result.v_type = V_NUM; result.v_num = itoq((long) i); return result; } S_FUNC VALUE f_fputc(VALUE *v1, VALUE *v2) { VALUE result; NUMBER *q; int ch; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_FILE) return error_value(E_FPUTC1); switch (v2->v_type) { case V_STR: ch = v2->v_str->s_str[0]; break; case V_NUM: q = v2->v_num; if (!qisint(q)) return error_value(E_FPUTC2); ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) : (int)(q->num.v[0] & 0xff); break; case V_NULL: ch = 0; break; default: return error_value(E_FPUTC2); } i = idfputc(v1->v_file, ch); if (i > 0) return error_value(E_FPUTC3); result.v_type = V_NULL; return result; } S_FUNC VALUE f_fputs(int count, VALUE **vals) { VALUE result; int i, err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type != V_FILE) return error_value(E_FPUTS1); for (i = 1; i < count; i++) { if (vals[i]->v_type != V_STR) return error_value(E_FPUTS2); } for (i = 1; i < count; i++) { err = idfputs(vals[0]->v_file, vals[i]->v_str); if (err > 0) return error_value(E_FPUTS3); } result.v_type = V_NULL; return result; } S_FUNC VALUE f_fputstr(int count, VALUE **vals) { VALUE result; int i, err; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type != V_FILE) return error_value(E_FPUTSTR1); for (i = 1; i < count; i++) { if (vals[i]->v_type != V_STR) return error_value(E_FPUTSTR2); } for (i = 1; i < count; i++) { err = idfputstr(vals[0]->v_file, vals[i]->v_str->s_str); if (err > 0) return error_value(E_FPUTSTR3); } result.v_type = V_NULL; return result; } S_FUNC VALUE f_printf(int count, VALUE **vals) { VALUE result; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type != V_STR) return error_value(E_PRINTF1); i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str, count - 1, vals + 1); if (i) return error_value(E_PRINTF2); result.v_type = V_NULL; return result; } S_FUNC VALUE f_strprintf(int count, VALUE **vals) { VALUE result; int i; char *cp; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vals[0]->v_type != V_STR) return error_value(E_STRPRINTF1); math_divertio(); i = idprintf(FILEID_STDOUT, vals[0]->v_str->s_str, count - 1, vals + 1); if (i) { free(math_getdivertedio()); return error_value(E_STRPRINTF2); } cp = math_getdivertedio(); result.v_type = V_STR; result.v_str = makenewstring(cp); free(cp); return result; } S_FUNC VALUE f_fgetc(VALUE *vp) { VALUE result; int ch; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETC1); ch = getcharid(vp->v_file); if (ch == -2) return error_value(E_FGETC2); result.v_type = V_NULL; if (ch != EOF) { result.v_type = V_STR; result.v_str = charstring(ch); } return result; } S_FUNC VALUE f_ungetc(VALUE *v1, VALUE *v2) { VALUE result; NUMBER *q; int ch; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; errno = 0; if (v1->v_type != V_FILE) return error_value(E_UNGETC1); switch (v2->v_type) { case V_STR: ch = v2->v_str->s_str[0]; break; case V_NUM: q = v2->v_num; if (!qisint(q)) return error_value(E_UNGETC2); ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) : (int)(q->num.v[0] & 0xff); break; default: return error_value(E_UNGETC2); } i = idungetc(v1->v_file, ch); if (i == EOF) return error_value(errno); if (i == -2) return error_value(E_UNGETC3); result.v_type = V_NULL; return result; } S_FUNC VALUE f_fgetline(VALUE *vp) { VALUE result; STRING *str; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETLINE1); i = readid(vp->v_file, 9, &str); if (i > 0) return error_value(E_FGETLINE2); result.v_type = V_NULL; if (i == 0) { result.v_type = V_STR; result.v_str = str; } return result; } S_FUNC VALUE f_fgets(VALUE *vp) { VALUE result; STRING *str; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETS1); i = readid(vp->v_file, 1, &str); if (i > 0) return error_value(E_FGETS2); result.v_type = V_NULL; if (i == 0) { result.v_type = V_STR; result.v_str = str; } return result; } S_FUNC VALUE f_fgetstr(VALUE *vp) { VALUE result; STRING *str; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETSTR1); i = readid(vp->v_file, 10, &str); if (i > 0) return error_value(E_FGETSTR2); result.v_type = V_NULL; if (i == 0) { result.v_type = V_STR; result.v_str = str; } return result; } S_FUNC VALUE f_fgetfield(VALUE *vp) { VALUE result; STRING *str; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETFIELD1); i = readid(vp->v_file, 14, &str); if (i > 0) return error_value(E_FGETFIELD2); result.v_type = V_NULL; if (i == 0) { result.v_type = V_STR; result.v_str = str; } return result; } S_FUNC VALUE f_fgetfile(VALUE *vp) { VALUE result; STRING *str; int i; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_FILE) return error_value(E_FGETFILE1); i = readid(vp->v_file, 0, &str); if (i == 1) return error_value(E_FGETFILE2); if (i == 3) return error_value(E_FGETFILE3); result.v_type = V_NULL; if (i == 0) { result.v_type = V_STR; result.v_str = str; } return result; } S_FUNC VALUE f_files(int count, VALUE **vals) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (count == 0) { result.v_type = V_NUM; result.v_num = itoq((long) MAXFILES); return result; } if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num)) return error_value(E_FILES); result.v_type = V_NULL; result.v_file = indexid(qtoi(vals[0]->v_num)); if (result.v_file != FILEID_NONE) result.v_type = V_FILE; return result; } S_FUNC VALUE f_reverse(VALUE *val) { VALUE res; res.v_type = val->v_type; res.v_subtype = val->v_subtype; switch(val->v_type) { case V_MAT: res.v_mat = matcopy(val->v_mat); matreverse(res.v_mat); break; case V_LIST: res.v_list = listcopy(val->v_list); listreverse(res.v_list); break; case V_STR: res.v_str = stringneg(val->v_str); if (res.v_str == NULL) return error_value(E_STRNEG); break; default: math_error("Bad argument type for reverse"); /*NOTREACHED*/ } return res; } S_FUNC VALUE f_sort(VALUE *val) { VALUE res; res.v_type = val->v_type; res.v_subtype = val->v_subtype; switch (val->v_type) { case V_MAT: res.v_mat = matcopy(val->v_mat); matsort(res.v_mat); break; case V_LIST: res.v_list = listcopy(val->v_list); listsort(res.v_list); break; default: math_error("Bad argument type for sort"); /*NOTREACHED*/ } return res; } S_FUNC VALUE f_join(int count, VALUE **vals) { LIST *lp; LISTELEM *ep; VALUE res; /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; lp = listalloc(); while (count-- > 0) { if (vals[0]->v_type != V_LIST) { listfree(lp); printf("Non-list argument for join\n"); res.v_type = V_NULL; return res; } for (ep = vals[0]->v_list->l_first; ep; ep = ep->e_next) insertlistlast(lp, &ep->e_value); vals++; } res.v_type = V_LIST; res.v_list = lp; return res; } S_FUNC VALUE f_head(VALUE *v1, VALUE *v2) { VALUE res; long n; /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; if (v2->v_type != V_NUM || qisfrac(v2->v_num) || zge31b(v2->v_num->num)) return error_value(E_HEAD2); n = qtoi(v2->v_num); res.v_type = v1->v_type; switch (v1->v_type) { case V_LIST: if (n == 0) res.v_list = listalloc(); else if (n > 0) res.v_list = listsegment(v1->v_list,0,n-1); else res.v_list = listsegment(v1->v_list,-n-1,0); return res; case V_STR: if (n == 0) res.v_str = slink(&_nullstring_); else if (n > 0) res.v_str = stringsegment(v1->v_str,0,n-1); else res.v_str = stringsegment(v1->v_str,-n-1,0); if (res.v_str == NULL) return error_value(E_STRHEAD); return res; default: return error_value(E_HEAD1); } } S_FUNC VALUE f_tail(VALUE *v1, VALUE *v2) { long n; VALUE res; /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; if (v2->v_type != V_NUM || qisfrac(v2->v_num) || zge31b(v2->v_num->num)) return error_value(E_TAIL1); n = qtoi(v2->v_num); res.v_type = v1->v_type; switch (v1->v_type) { case V_LIST: if (n == 0) { res.v_list = listalloc(); } else if (n > 0) { res.v_list = listsegment(v1->v_list, v1->v_list->l_count - n, v1->v_list->l_count - 1); } else { res.v_list = listsegment(v1->v_list, v1->v_list->l_count - 1, v1->v_list->l_count + n); } return res; case V_STR: if (n == 0) { res.v_str = slink(&_nullstring_); } else if (n > 0) { res.v_str = stringsegment(v1->v_str, v1->v_str->s_len - n, v1->v_str->s_len - 1); } else { res.v_str = stringsegment(v1->v_str, v1->v_str->s_len - 1, v1->v_str->s_len + n); } if (res.v_str == V_NULL) return error_value(E_STRTAIL); return res; default: return error_value(E_TAIL1); } } S_FUNC VALUE f_segment(int count, VALUE **vals) { VALUE *vp; long n1, n2; VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; vp = vals[1]; if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num)) return error_value(E_SEG2); n1 = qtoi(vp->v_num); n2 = n1; if (count == 3) { vp = vals[2]; if (vp->v_type != V_NUM || qisfrac(vp->v_num) || zge31b(vp->v_num->num)) return error_value(E_SEG3); n2 = qtoi(vp->v_num); } vp = vals[0]; result.v_type = vp->v_type; switch (vp->v_type) { case V_LIST: result.v_list = listsegment(vp->v_list, n1, n2); return result; case V_STR: result.v_str = stringsegment(vp->v_str, n1, n2); if (result.v_str == NULL) return error_value(E_STRSEG); return result; default: return error_value(E_SEG1); } } S_FUNC VALUE f_modify(VALUE *v1, VALUE *v2) { FUNC *fp; LISTELEM *ep; long s; VALUE res; VALUE *vp; unsigned short subtype; if (v1->v_type != V_ADDR) return error_value(E_MODIFY1); v1 = v1->v_addr; if (v2->v_type == V_ADDR) v2 = v2->v_addr; if (v2->v_type != V_STR) return error_value(E_MODIFY2); if (v1->v_subtype & V_NONEWVALUE) return error_value(E_MODIFY3); fp = findfunc(adduserfunc(v2->v_str->s_str)); if (!fp) return error_value(E_MODIFY4); switch (v1->v_type) { case V_LIST: for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { subtype = ep->e_value.v_subtype; *++stack = ep->e_value; calculate(fp, 1); stack->v_subtype |= subtype; ep->e_value = *stack--; } break; case V_MAT: vp = v1->v_mat->m_table; s = v1->v_mat->m_size; while (s-- > 0) { subtype = vp->v_subtype; *++stack = *vp; calculate(fp, 1); stack->v_subtype |= subtype; *vp++ = *stack--; } break; case V_OBJ: vp = v1->v_obj->o_table; s = v1->v_obj->o_actions->oa_count; while (s-- > 0) { subtype = vp->v_subtype; *++stack = *vp; calculate(fp, 1); stack->v_subtype |= subtype; *vp++ = *stack--; } break; default: return error_value(E_MODIFY5); } res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_forall(VALUE *v1, VALUE *v2) { FUNC *fp; LISTELEM *ep; long s; VALUE res; VALUE *vp; /* initialize VALUE */ res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; if (v2->v_type != V_STR) { math_error("Non-string second argument for forall"); /*NOTREACHED*/ } fp = findfunc(adduserfunc(v2->v_str->s_str)); if (!fp) { math_error("Undefined function for forall"); /*NOTREACHED*/ } switch (v1->v_type) { case V_LIST: for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { copyvalue(&ep->e_value, ++stack); calculate(fp, 1); stack--; } break; case V_MAT: vp = v1->v_mat->m_table; s = v1->v_mat->m_size; while (s-- > 0) { copyvalue(vp++, ++stack); calculate(fp, 1); stack--; } break; default: math_error("Non list or matrix first argument for forall"); /*NOTREACHED*/ } return res; } S_FUNC VALUE f_select(VALUE *v1, VALUE *v2) { LIST *lp; LISTELEM *ep; FUNC *fp; VALUE res; /* initialize VALUE */ res.v_type = V_LIST; res.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_LIST) { math_error("Non-list first argument for select"); /*NOTREACHED*/ } if (v2->v_type != V_STR) { math_error("Non-string second argument for select"); /*NOTREACHED*/ } fp = findfunc(adduserfunc(v2->v_str->s_str)); if (!fp) { math_error("Undefined function for select"); /*NOTREACHED*/ } lp = listalloc(); for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { copyvalue(&ep->e_value, ++stack); calculate(fp, 1); if (testvalue(stack)) insertlistlast(lp, &ep->e_value); freevalue(stack--); } res.v_list = lp; return res; } S_FUNC VALUE f_count(VALUE *v1, VALUE *v2) { LISTELEM *ep; FUNC *fp; long s; long n = 0; VALUE res; VALUE *vp; /* initialize VALUE */ res.v_type = V_NUM; res.v_subtype = V_NOSUBTYPE; if (v2->v_type != V_STR) { math_error("Non-string second argument for select"); /*NOTREACHED*/ } fp = findfunc(adduserfunc(v2->v_str->s_str)); if (!fp) { math_error("Undefined function for select"); /*NOTREACHED*/ } switch (v1->v_type) { case V_LIST: for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { copyvalue(&ep->e_value, ++stack); calculate(fp, 1); if (testvalue(stack)) n++; freevalue(stack--); } break; case V_MAT: s = v1->v_mat->m_size; vp = v1->v_mat->m_table; while (s-- > 0) { copyvalue(vp++, ++stack); calculate(fp, 1); if (testvalue(stack)) n++; freevalue(stack--); } break; default: math_error("Bad argument type for count"); /*NOTREACHED*/ } res.v_num = itoq(n); return res; } S_FUNC VALUE f_makelist(VALUE *v1) { LIST *lp; VALUE res; long n; /* initialize VALUE */ res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_NUM || qisfrac(v1->v_num) || qisneg(v1->v_num)) { math_error("Bad argument for makelist"); /*NOTREACHED*/ } if (zge31b(v1->v_num->num)) { math_error("makelist count >= 2^31"); /*NOTREACHED*/ } n = qtoi(v1->v_num); lp = listalloc(); while (n-- > 0) insertlistlast(lp, &res); res.v_type = V_LIST; res.v_list = lp; return res; } S_FUNC VALUE f_randperm(VALUE *val) { VALUE res; /* initialize VALUE */ res.v_subtype = V_NOSUBTYPE; res.v_type = val->v_type; switch (val->v_type) { case V_MAT: res.v_mat = matcopy(val->v_mat); matrandperm(res.v_mat); break; case V_LIST: res.v_list = listcopy(val->v_list); listrandperm(res.v_list); break; default: math_error("Bad argument type for randperm"); /*NOTREACHED*/ } return res; } S_FUNC VALUE f_cmdbuf(void) { VALUE result; char *newcp; size_t cmdbuf_len; /* length of cmdbuf string */ /* initialize VALUE */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; cmdbuf_len = strlen(cmdbuf); newcp = (char *)malloc(cmdbuf_len+1); strncpy(newcp, cmdbuf, cmdbuf_len+1); result.v_str = makestring(newcp); return result; } S_FUNC VALUE f_getenv(VALUE *v1) { VALUE result; char *str; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (v1->v_type != V_STR) { math_error("Non-string argument for getenv"); /*NOTREACHED*/ } result.v_type = V_STR; str = getenv(v1->v_str->s_str); if (str == NULL) result.v_type = V_NULL; else result.v_str = makenewstring(str); return result; } S_FUNC VALUE f_isatty(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; result.v_type = V_NUM; if (vp->v_type == V_FILE && isattyid(vp->v_file) == 1) { result.v_num = itoq(1); } else { result.v_num = itoq(0); } return result; } S_FUNC VALUE f_calc_tty(void) { VALUE res; if (!calc_tty(FILEID_STDIN)) return error_value(E_TTY); res.v_type = V_NULL; res.v_subtype = V_NOSUBTYPE; return res; } S_FUNC VALUE f_inputlevel (void) { VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; result.v_num = itoq((long) inputlevel()); return result; } S_FUNC VALUE f_calclevel(void) { VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; result.v_num = itoq(calclevel()); return result; } S_FUNC VALUE f_calcpath(void) { VALUE result; /* initialize VALUE */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; result.v_str = makenewstring(calcpath); return result; } S_FUNC VALUE f_access(int count, VALUE **vals) { NUMBER *q; int m; char *s, *fname; VALUE result; size_t len; int i; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; errno = 0; if (vals[0]->v_type != V_STR) return error_value(E_ACCESS1); fname = vals[0]->v_str->s_str; m = 0; if (count == 2) { switch (vals[1]->v_type) { case V_NUM: q = vals[1]->v_num; if (qisfrac(q) || qisneg(q)) return error_value(E_ACCESS2); m = (int)(q->num.v[0] & 7); break; case V_STR: s = vals[1]->v_str->s_str; len = (long)strlen(s); while (len-- > 0) { switch (*s++) { case 'r': m |= 4; break; case 'w': m |= 2; break; case 'x': m |= 1; break; default: return error_value(E_ACCESS2); } } break; case V_NULL: break; default: return error_value(E_ACCESS2); } } i = access(fname, m); if (i) return error_value(errno); return result; } S_FUNC VALUE f_putenv(int count, VALUE **vals) { VALUE result; char *putenv_str; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; /* * parse args */ if (count == 2) { /* firewall */ if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) { math_error("Non-string argument for putenv"); /*NOTREACHED*/ } /* convert putenv("foo","bar") into putenv("foo=bar") */ putenv_str = (char *)malloc(vals[0]->v_str->s_len + 1 + vals[1]->v_str->s_len + 1); if (putenv_str == NULL) { math_error("Cannot allocate string in putenv"); /*NOTREACHED*/ } sprintf(putenv_str, "%s=%s", vals[0]->v_str->s_str, vals[1]->v_str->s_str); } else { /* firewall */ if (vals[0]->v_type != V_STR) { math_error("Non-string argument for putenv"); /*NOTREACHED*/ } /* putenv(arg) must be of the form "foo=bar" */ if ((char *)strchr(vals[0]->v_str->s_str, '=') == NULL) { math_error("putenv single arg string missing ="); /*NOTREACHED*/ } /* * make a copy of the arg because subsequent changes * would change the environment. */ putenv_str = (char *)malloc(vals[0]->v_str->s_len + 1); if (putenv_str == NULL) { math_error("Cannot allocate string in putenv"); /*NOTREACHED*/ } strncpy(putenv_str, vals[0]->v_str->s_str, vals[0]->v_str->s_len + 1); } /* return putenv result */ result.v_num = itoq((long) malloced_putenv(putenv_str)); return result; } S_FUNC VALUE f_strpos(VALUE *haystack, VALUE *needle) { VALUE result; char *cpointer; int cindex; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; if (haystack->v_type != V_STR || needle->v_type != V_STR) { math_error("Non-string argument for index"); /*NOTREACHED*/ } cpointer = strstr(haystack->v_str->s_str, needle->v_str->s_str); if (cpointer == NULL) cindex = 0; else cindex = cpointer - haystack->v_str->s_str + 1; result.v_num = itoq((long) cindex); return result; } S_FUNC VALUE f_system(VALUE *vp) { VALUE result; /* initialize VALUE */ result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; if (vp->v_type != V_STR) { math_error("Non-string argument for system"); /*NOTREACHED*/ } if (!allow_exec) { math_error("execution disallowed by -m"); /*NOTREACHED*/ } if (conf->calc_debug & CALCDBG_SYSTEM) { printf("%s\n", vp->v_str->s_str); } #if defined(_WIN32) /* if the execute length is 0 then just return 0 */ if (vp->v_str->s_len == 0) { result.v_num = itoq((long)0); } else { result.v_num = itoq((long)system(vp->v_str->s_str)); } #else /* Windoz free systems */ result.v_num = itoq((long)system(vp->v_str->s_str)); #endif /* Windoz free systems */ return result; } S_FUNC VALUE f_sleep(int count, VALUE **vals) { long time; VALUE res; NUMBER *q1, *q2; res.v_type = V_NULL; #if !defined(_WIN32) if (count > 0) { if (vals[0]->v_type != V_NUM || qisneg(vals[0]->v_num)) return error_value(E_SLEEP); if (qisint(vals[0]->v_num)) { if (zge31b(vals[0]->v_num->num)) return error_value(E_SLEEP); time = ztoi(vals[0]->v_num->num); time = sleep(time); } else { q1 = qscale(vals[0]->v_num, 20); q2 = qint(q1); qfree(q1); if (zge31b(q2->num)) { qfree(q2); return error_value(E_SLEEP); } time = ztoi(q2->num); qfree(q2); /* BSD 4.3 usleep has void return */ usleep(time); return res; } } else { time = sleep(1); } if (time) { res.v_type = V_NUM; res.v_num = itoq(time); } #endif /* Windoz free systems */ return res; } /* * set the default output base/mode */ S_FUNC NUMBER * f_base(int count, NUMBER **vals) { long base; /* output base/mode */ long oldbase=0; /* output base/mode */ /* deal with just a query */ if (count != 1) { return base_value(conf->outmode, conf->outmode); } /* deal with the specal modes first */ if (qisfrac(vals[0])) { return base_value(math_setmode(MODE_FRAC), conf->outmode); } if (vals[0]->num.len > 64/BASEB) { return base_value(math_setmode(MODE_EXP), conf->outmode); } /* set the base, if possible */ base = qtoi(vals[0]); switch (base) { case -10: oldbase = math_setmode(MODE_INT); break; case 2: oldbase = math_setmode(MODE_BINARY); break; case 8: oldbase = math_setmode(MODE_OCTAL); break; case 10: oldbase = math_setmode(MODE_REAL); break; case 16: oldbase = math_setmode(MODE_HEX); break; default: math_error("Unsupported base"); /*NOTREACHED*/ break; } /* return the old base */ return base_value(oldbase, conf->outmode); } /* * set the default secondary output base/mode */ S_FUNC NUMBER * f_base2(int count, NUMBER **vals) { long base; /* output base/mode */ long oldbase=0; /* output base/mode */ /* deal with just a query */ if (count != 1) { return base_value(conf->outmode2, conf->outmode2); } /* deal with the specal modes first */ if (qisfrac(vals[0])) { return base_value(math_setmode2(MODE_FRAC), conf->outmode2); } if (vals[0]->num.len > 64/BASEB) { return base_value(math_setmode2(MODE_EXP), conf->outmode2); } /* set the base, if possible */ base = qtoi(vals[0]); switch (base) { case 0: oldbase = math_setmode2(MODE2_OFF); break; case -10: oldbase = math_setmode2(MODE_INT); break; case 2: oldbase = math_setmode2(MODE_BINARY); break; case 8: oldbase = math_setmode2(MODE_OCTAL); break; case 10: oldbase = math_setmode2(MODE_REAL); break; case 16: oldbase = math_setmode2(MODE_HEX); break; default: math_error("Unsupported base"); /*NOTREACHED*/ break; } /* return the old base */ return base_value(oldbase, conf->outmode2); } /* * return a numerical 'value' of the mode/base */ S_FUNC NUMBER * base_value(long mode, int defval) { NUMBER *result; /* return the old base */ switch (mode) { case MODE_DEFAULT: switch (defval) { case MODE_DEFAULT: result = itoq(10); break; case MODE_FRAC: result = qalloc(); itoz(3, &result->den); break; case MODE_INT: result = itoq(-10); break; case MODE_REAL: result = itoq(10); break; case MODE_EXP: result = qalloc(); ztenpow(20, &result->num); break; case MODE_HEX: result = itoq(16); break; case MODE_OCTAL: result = itoq(8); break; case MODE_BINARY: result = itoq(2); break; case MODE2_OFF: result = itoq(0); break; default: result = itoq(0); break; } break; case MODE_FRAC: result = qalloc(); itoz(3, &result->den); break; case MODE_INT: result = itoq(-10); break; case MODE_REAL: result = itoq(10); break; case MODE_EXP: result = qalloc(); ztenpow(20, &result->num); break; case MODE_HEX: result = itoq(16); break; case MODE_OCTAL: result = itoq(8); break; case MODE_BINARY: result = itoq(2); break; case MODE2_OFF: result = itoq(0); break; default: result = itoq(0); break; } return result; } S_FUNC VALUE f_custom(int count, VALUE **vals) { VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; /* * disable custom functions unless -C was given */ if (!allow_custom) { fprintf(stderr, #if defined(CUSTOM) "%sCalc must be run with a -C argument to " "use custom function\n", #else /* CUSTOM */ "%sCalc was built with custom functions disabled\n", #endif /* CUSTOM */ (conf->tab_ok ? "\t" : "")); return error_value(E_CUSTOM_ERROR); } /* * perform the custom operation */ if (count <= 0) { /* perform the usage function function */ showcustom(); } else { /* firewall */ if (vals[0]->v_type != V_STR) { math_error("custom: 1st arg not a string name"); /*NOTREACHED*/ } /* perform the custom function */ result = custom(vals[0]->v_str->s_str, count-1, vals+1); } /* * return the custom result */ return result; } S_FUNC VALUE f_blk(int count, VALUE **vals) { int len; /* number of octets to malloc */ int chunk; /* block chunk size */ VALUE result; int id; VALUE *vp = NULL; int type; /* initialize VALUE */ result.v_type = V_BLOCK; result.v_subtype = V_NOSUBTYPE; type = V_NULL; if (count > 0) { vp = *vals; type = vp->v_type; if (type == V_STR || type == V_NBLOCK || type == V_BLOCK) { vals++; count--; } } len = -1; /* signal to use old or zero len */ chunk = -1; /* signal to use old or default chunksize */ if (count > 0 && vals[0]->v_type != V_NULL) { /* parse len */ if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num)) return error_value(E_BLK1); if (qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num)) return error_value(E_BLK2); len = qtoi(vals[0]->v_num); } if (count > 1 && vals[1]->v_type != V_NULL) { /* parse chunk */ if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) return error_value(E_BLK3); if (qisneg(vals[1]->v_num) || zge31b(vals[1]->v_num->num)) return error_value(E_BLK4); chunk = qtoi(vals[1]->v_num); } if (type == V_STR) { result.v_type = V_NBLOCK; id = findnblockid(vp->v_str->s_str); if (id < 0) { /* create new named block */ result.v_nblock = createnblock(vp->v_str->s_str, len, chunk); return result; } /* reallocate nblock */ result.v_nblock = reallocnblock(id, len, chunk); return result; } if (type == V_NBLOCK) { /* reallocate nblock */ result.v_type = V_NBLOCK; id = vp->v_nblock->id; result.v_nblock = reallocnblock(id, len, chunk); return result; } if (type == V_BLOCK) { /* reallocate block */ result.v_type = V_BLOCK; result.v_block = copyrealloc(vp->v_block, len, chunk); return result; } /* allocate block */ result.v_block = blkalloc(len, chunk); return result; } S_FUNC VALUE f_blkfree(VALUE *vp) { int id; VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; id = 0; switch (vp->v_type) { case V_NBLOCK: id = vp->v_nblock->id; break; case V_STR: id = findnblockid(vp->v_str->s_str); if (id < 0) return error_value(E_BLKFREE1); break; case V_NUM: if (qisfrac(vp->v_num) || qisneg(vp->v_num)) return error_value(E_BLKFREE2); if (zge31b(vp->v_num->num)) return error_value(E_BLKFREE3); id = qtoi(vp->v_num); break; default: return error_value(E_BLKFREE4); } id = removenblock(id); if (id) return error_value(id); return result; } S_FUNC VALUE f_blocks(int count, VALUE **vals) { NBLOCK *nblk; VALUE result; int id; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; if (count == 0) { result.v_type = V_NUM; result.v_num = itoq((long) countnblocks()); return result; } if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num)) return error_value(E_BLOCKS1); id = (int) qtoi(vals[0]->v_num); nblk = findnblock(id); if (nblk == NULL) { return error_value(E_BLOCKS2); } else { result.v_type = V_NBLOCK; result.v_nblock = nblk; } return result; } S_FUNC VALUE f_free(int count, VALUE **vals) { VALUE result; VALUE *val; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; result.v_type = V_NULL; while (count-- > 0) { val = *vals++; if (val->v_type == V_ADDR) freevalue(val->v_addr); } return result; } S_FUNC VALUE f_freeglobals(void) { VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; freeglobals(); return result; } S_FUNC VALUE f_freeredc(void) { VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; freeredcdata(); return result; } S_FUNC VALUE f_freestatics(void) { VALUE result; /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; freestatics(); return result; } /* * f_copy - copy consecutive items between values * * copy(src, dst [, ssi [, num [, dsi]]]) * * Copy 'num' consecutive items from 'src' with index 'ssi' to * 'dest', starting at position with index 'dsi'. */ S_FUNC VALUE f_copy(int count, VALUE **vals) { long ssi = 0; /* source start index */ long num = -1; /* number of items to copy (-1 ==> all) */ long dsi = -1; /* destination start index, -1 ==> default */ int errtype; /* error type if unable to perform copy */ VALUE result; /* null if successful */ /* initialize VALUE */ result.v_type = V_NULL; result.v_subtype = V_NOSUBTYPE; /* * parse args */ switch(count) { case 5: /* parse dsi */ if (vals[4]->v_type != V_NULL) { if (vals[4]->v_type != V_NUM || qisfrac(vals[4]->v_num) || qisneg(vals[4]->v_num)) { return error_value(E_COPY6); } if (zge31b(vals[4]->v_num->num)) { return error_value(E_COPY7); } dsi = qtoi(vals[4]->v_num); } /*FALLTHRU*/ case 4: /* parse num */ if (vals[3]->v_type != V_NULL) { if (vals[3]->v_type != V_NUM || qisfrac(vals[3]->v_num) || qisneg(vals[3]->v_num)) { return error_value(E_COPY1); } if (zge31b(vals[3]->v_num->num)) { return error_value(E_COPY2); } num = qtoi(vals[3]->v_num); } /*FALLTHRU*/ case 3: /* parse ssi */ if (vals[2]->v_type != V_NULL) { if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num) || qisneg(vals[2]->v_num)) { return error_value(E_COPY4); } if (zge31b(vals[2]->v_num->num)) { return error_value(E_COPY5); } ssi = qtoi(vals[2]->v_num); } break; } /* * copy */ errtype = copystod(vals[0], ssi, num, vals[1], dsi); if (errtype > 0) return error_value(errtype); return result; } /* * f_blkcpy - copy consecutive items between values * * copy(dst, src [, num [, dsi [, ssi]]]) * * Copy 'num' consecutive items from 'src' with index 'ssi' to * 'dest', starting at position with index 'dsi'. */ S_FUNC VALUE f_blkcpy(int count, VALUE **vals) { VALUE *args[5]; /* args to re-order */ VALUE null_value; /* dummy argument */ /* initialize VALUE */ null_value.v_subtype = V_NOSUBTYPE; /* * parse args into f_copy order */ args[0] = vals[1]; args[1] = vals[0]; switch(count) { case 5: args[2] = vals[4]; args[4] = vals[3]; args[3] = vals[2]; break; case 4: count = 5; args[4] = vals[3]; args[3] = vals[2]; null_value.v_type = V_NULL; args[2] = &null_value; break; case 3: count = 4; args[3] = vals[2]; null_value.v_type = V_NULL; args[2] = &null_value; break; } /* * copy */ return f_copy(count, args); } S_FUNC VALUE f_sha(int count, VALUE **vals) { VALUE result; HASH *state; /* pointer to hash state to use */ int i; /* vals[i] to hash */ /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; state = NULL; /* * arg check */ if (count == 0) { /* return an initial hash state */ result.v_type = V_HASH; result.v_hash = hash_init(SHS_HASH_TYPE, NULL); } else if (count == 1 && vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == SHS_HASH_TYPE) { /* if just a hash value, finalize it */ state = hash_copy(vals[0]->v_hash); result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = hash_final(state); hash_free(state); } else { /* * If the first value is a hash, use that as * the initial hash state */ if (vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == SHS_HASH_TYPE) { state = hash_copy(vals[0]->v_hash); i = 1; /* * otherwise use the default initial state */ } else { state = hash_init(SHS_HASH_TYPE, NULL); i = 0; } /* * hash the remaining values */ do { state = hash_value(SHS_HASH_TYPE, vals[i], state); } while (++i < count); /* * return the current hash state */ result.v_type = V_HASH; result.v_hash = state; } /* return the result */ return result; } S_FUNC VALUE f_sha1(int count, VALUE **vals) { VALUE result; HASH *state; /* pointer to hash state to use */ int i; /* vals[i] to hash */ /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* * arg check */ if (count == 0) { /* return an initial hash state */ result.v_type = V_HASH; result.v_hash = hash_init(SHS1_HASH_TYPE, NULL); } else if (count == 1 && vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == SHS1_HASH_TYPE) { /* if just a hash value, finalize it */ state = hash_copy(vals[0]->v_hash); result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = hash_final(state); hash_free(state); } else { /* * If the first value is a hash, use that as * the initial hash state */ if (vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == SHS1_HASH_TYPE) { state = hash_copy(vals[0]->v_hash); i = 1; /* * otherwise use the default initial state */ } else { state = hash_init(SHS1_HASH_TYPE, NULL); i = 0; } /* * hash the remaining values */ do { state = hash_value(SHS1_HASH_TYPE, vals[i], state); } while (++i < count); /* * return the current hash state */ result.v_type = V_HASH; result.v_hash = state; } /* return the result */ return result; } S_FUNC VALUE f_md5(int count, VALUE **vals) { VALUE result; HASH *state; /* pointer to hash state to use */ int i; /* vals[i] to hash */ /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; state = NULL; /* * arg check */ if (count == 0) { /* return an initial hash state */ result.v_type = V_HASH; result.v_hash = hash_init(MD5_HASH_TYPE, NULL); } else if (count == 1 && vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == MD5_HASH_TYPE) { /* if just a hash value, finalize it */ state = hash_copy(vals[0]->v_hash); result.v_type = V_NUM; result.v_num = qalloc(); result.v_num->num = hash_final(state); hash_free(state); } else { /* * If the first value is a hash, use that as * the initial hash state */ if (vals[0]->v_type == V_HASH && vals[0]->v_hash->hashtype == MD5_HASH_TYPE) { state = hash_copy(vals[0]->v_hash); i = 1; /* * otherwise use the default initial state */ } else { state = hash_init(MD5_HASH_TYPE, NULL); i = 0; } /* * hash the remaining values */ do { state = hash_value(MD5_HASH_TYPE, vals[i], state); } while (++i < count); /* * return the current hash state */ result.v_type = V_HASH; result.v_hash = state; } /* return the result */ return result; } S_FUNC VALUE f_argv(int count, VALUE **vals) { int arg; /* the argv_value string index */ VALUE result; /* initialize VALUE */ result.v_subtype = V_NOSUBTYPE; /* * arg check */ if (count == 0) { /* return the argc count */ result.v_type = V_NUM; result.v_num = itoq((long) argc_value); } else { /* firewall */ if (vals[0]->v_type != V_NUM || qisfrac(vals[0]->v_num) || qisneg(vals[0]->v_num) || zge31b(vals[0]->v_num->num)) { math_error("argv argument must be a integer [0,2^31)"); /*NOTREACHED*/ } /* return the n-th argv string */ arg = qtoi(vals[0]->v_num); if (arg < argc_value && argv_value[arg] != NULL) { result.v_type = V_STR; result.v_str = makestring(strdup(argv_value[arg])); } else { result.v_type = V_NULL; } } /* return the result */ return result; } S_FUNC VALUE f_version(void) { VALUE result; /* return the calc verstion string */ result.v_type = V_STR; result.v_subtype = V_NOSUBTYPE; result.v_str = makestring(strdup(version())); return result; } #endif /* !FUNCLIST */ /* * builtins - List of primitive built-in functions * * NOTE: This table is also used by the help/Makefile builtin rule to * form the builtin help file. This rule will cause a sed script * to strip this table down into a just the information needed * to print builtin function list: b_name, b_minargs, b_maxargs * and b_desc. All other struct elements will be converted to 0. * The sed script expects to find entries of the form: * * {"...", number, number, stuff, stuff, stuff, stuff, * "...."}, * * please keep this table in that form. * * For nice output, when the description of function (b_desc) * gets too long (extends into col 79) you should chop the * line and add "\n\t\t\t", that's newline and 3 tabs. * For example the description: * * ... very long description that goes beyond col 79 * * should be written as: * * "... very long description that\n\t\t\tgoes beyond col 79"}, * * fields: * b_name name of built-in function * b_minargs minimum number of arguments * b_maxargs maximum number of arguments * b_flags special handling flags * b_opcode opcode which makes the call quick * b_numfunc routine to calculate numeric function * b_valfunc routine to calculate general values * b_desc description of function */ STATIC CONST struct builtin builtins[] = { {"abs", 1, 2, 0, OP_ABS, 0, 0, "absolute value within accuracy b"}, {"access", 1, 2, 0, OP_NOP, 0, f_access, "determine accessibility of file a for mode b"}, {"acos", 1, 2, 0, OP_NOP, 0, f_acos, "arccosine of a within accuracy b"}, {"acosh", 1, 2, 0, OP_NOP, 0, f_acosh, "inverse hyperbolic cosine of a within accuracy b"}, {"acot", 1, 2, 0, OP_NOP, 0, f_acot, "arccotangent of a within accuracy b"}, {"acoth", 1, 2, 0, OP_NOP, 0, f_acoth, "inverse hyperbolic cotangent of a within accuracy b"}, {"acsc", 1, 2, 0, OP_NOP, 0, f_acsc, "arccosecant of a within accuracy b"}, {"acsch", 1, 2, 0, OP_NOP, 0, f_acsch, "inverse csch of a within accuracy b"}, {"agd", 1, 2, 0, OP_NOP, 0, f_agd, "inverse gudermannian function"}, {"append", 1, IN, FA, OP_NOP, 0, f_listappend, "append values to end of list"}, {"appr", 1, 3, 0, OP_NOP, 0, f_appr, "approximate a by multiple of b using rounding c"}, {"arg", 1, 2, 0, OP_NOP, 0, f_arg, "argument (the angle) of complex number"}, {"argv", 0, 1, 0, OP_NOP, 0, f_argv, "calc argc or argv string"}, {"asec", 1, 2, 0, OP_NOP, 0, f_asec, "arcsecant of a within accuracy b"}, {"asech", 1, 2, 0, OP_NOP, 0, f_asech, "inverse hyperbolic secant of a within accuracy b"}, {"asin", 1, 2, 0, OP_NOP, 0, f_asin, "arcsine of a within accuracy b"}, {"asinh", 1, 2, 0, OP_NOP, 0, f_asinh, "inverse hyperbolic sine of a within accuracy b"}, {"assoc", 0, 0, 0, OP_NOP, 0, f_assoc, "create new association array"}, {"atan", 1, 2, 0, OP_NOP, 0, f_atan, "arctangent of a within accuracy b"}, {"atan2", 2, 3, FE, OP_NOP, qatan2, 0, "angle to point (b,a) within accuracy c"}, {"atanh", 1, 2, 0, OP_NOP, 0, f_atanh, "inverse hyperbolic tangent of a within accuracy b"}, {"avg", 0, IN, 0, OP_NOP, 0, f_avg, "arithmetic mean of values"}, {"base", 0, 1, 0, OP_NOP, f_base, 0, "set default output base"}, {"base2", 0, 1, 0, OP_NOP, f_base2, 0, "set default secondary output base"}, {"bernoulli", 1, 1, 0, OP_NOP, 0, f_bern, "Bernoulli number for index a"}, {"bit", 2, 2, 0, OP_BIT, 0, 0, "whether bit b in value a is set"}, {"blk", 0, 3, 0, OP_NOP, 0, f_blk, "block with or without name, octet number, chunksize"}, {"blkcpy", 2, 5, 0, OP_NOP, 0, f_blkcpy, "copy value to/from a block: blkcpy(d,s,len,di,si)"}, {"blkfree", 1, 1, 0, OP_NOP, 0, f_blkfree, "free all storage from a named block"}, {"blocks", 0, 1, 0, OP_NOP, 0, f_blocks, "named block with specified index, or null value"}, {"bround", 1, 3, 0, OP_NOP, 0, f_bround, "round value a to b number of binary places"}, {"btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0, "truncate a to b number of binary places"}, {"calc_tty", 0, 0, 0, OP_NOP, 0, f_calc_tty, "set tty for interactivity"}, {"calclevel", 0, 0, 0, OP_NOP, 0, f_calclevel, "current calculation level"}, {"calcpath", 0, 0, 0, OP_NOP, 0, f_calcpath, "current CALCPATH search path value"}, {"catalan", 1, 1, 0, OP_NOP, 0, f_catalan, "catalan number for index a"}, {"ceil", 1, 1, 0, OP_NOP, 0, f_ceil, "smallest integer greater than or equal to number"}, {"cfappr", 1, 3, 0, OP_NOP, f_cfappr, 0, "approximate a within accuracy b using\n\t\t\tcontinued fractions"}, {"cfsim", 1, 2, 0, OP_NOP, f_cfsim, 0, "simplify number using continued fractions"}, {"char", 1, 1, 0, OP_NOP, 0, f_char, "character corresponding to integer value"}, {"cmdbuf", 0, 0, 0, OP_NOP, 0, f_cmdbuf, "command buffer"}, {"cmp", 2, 2, 0, OP_CMP, 0, 0, "compare values returning -1, 0, or 1"}, {"comb", 2, 2, 0, OP_NOP, 0, f_comb, "combinatorial number a!/b!(a-b)!"}, {"config", 1, 2, 0, OP_SETCONFIG, 0, 0, "set or read configuration value"}, {"conj", 1, 1, 0, OP_CONJUGATE, 0, 0, "complex conjugate of value"}, {"copy", 2, 5, 0, OP_NOP, 0, f_copy, "copy value to/from a block: copy(s,d,len,si,di)"}, {"cos", 1, 2, 0, OP_NOP, 0, f_cos, "cosine of value a within accuracy b"}, {"cosh", 1, 2, 0, OP_NOP, 0, f_cosh, "hyperbolic cosine of a within accuracy b"}, {"cot", 1, 2, 0, OP_NOP, 0, f_cot, "cotangent of a within accuracy b"}, {"coth", 1, 2, 0, OP_NOP, 0, f_coth, "hyperbolic cotangent of a within accuracy b"}, {"count", 2, 2, 0, OP_NOP, 0, f_count, "count listr/matrix elements satisfying some condition"}, {"cp", 2, 2, 0, OP_NOP, 0, f_cp, "cross product of two vectors"}, {"csc", 1, 2, 0, OP_NOP, 0, f_csc, "cosecant of a within accuracy b"}, {"csch", 1, 2, 0, OP_NOP, 0, f_csch, "hyperbolic cosecant of a within accuracy b"}, {"ctime", 0, 0, 0, OP_NOP, 0, f_ctime, "date and time as string"}, {"custom", 0, IN, 0, OP_NOP, 0, f_custom, "custom builtin function interface"}, {"delete", 2, 2, FA, OP_NOP, 0, f_listdelete, "delete element from list a at position b"}, {"den", 1, 1, 0, OP_DENOMINATOR, qden, 0, "denominator of fraction"}, {"det", 1, 1, 0, OP_NOP, 0, f_det, "determinant of matrix"}, {"digit", 2, 3, 0, OP_NOP, 0, f_digit, "digit at specified decimal place of number"}, {"digits", 1, 2, 0, OP_NOP, 0, f_digits, "number of digits in base b representation of a"}, {"display", 0, 1, 0, OP_NOP, 0, f_display, "number of decimal digits for displaying numbers"}, {"dp", 2, 2, 0, OP_NOP, 0, f_dp, "dot product of two vectors"}, {"epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0, "set or read allowed error for real calculations"}, {"errcount", 0, 1, 0, OP_NOP, 0, f_errcount, "set or read error count"}, {"errmax", 0, 1, 0, OP_NOP, 0, f_errmax, "set or read maximum for error count"}, {"errno", 0, 1, 0, OP_NOP, 0, f_errno, "set or read calc_errno"}, {"error", 0, 1, 0, OP_NOP, 0, f_error, "generate error value"}, {"estr", 1, 1, 0, OP_NOP, 0, f_estr, "exact text string representation of value"}, {"euler", 1, 1, 0, OP_NOP, 0, f_euler, "Euler number"}, {"eval", 1, 1, 0, OP_NOP, 0, f_eval, "evaluate expression from string to value"}, {"exp", 1, 2, 0, OP_NOP, 0, f_exp, "exponential of value a within accuracy b"}, {"factor", 1, 3, 0, OP_NOP, f_factor, 0, "lowest prime factor < b of a, return c if error"}, {"fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0, "count of times one number divides another"}, {"fib", 1, 1, 0, OP_NOP, qfib, 0, "Fibonacci number F(n)"}, {"forall", 2, 2, 0, OP_NOP, 0, f_forall, "do function for all elements of list or matrix"}, {"frem", 2, 2, 0, OP_NOP, qfacrem, 0, "number with all occurrences of factor removed"}, {"fact", 1, 1, 0, OP_NOP, 0, f_fact, "factorial"}, {"fclose", 0, IN, 0, OP_NOP, 0, f_fclose, "close file"}, {"feof", 1, 1, 0, OP_NOP, 0, f_feof, "whether EOF reached for file"}, {"ferror", 1, 1, 0, OP_NOP, 0, f_ferror, "whether error occurred for file"}, {"fflush", 0, IN, 0, OP_NOP, 0, f_fflush, "flush output to file(s)"}, {"fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, "read next char from file"}, {"fgetfield", 1, 1, 0, OP_NOP, 0, f_fgetfield, "read next white-space delimited field from file"}, {"fgetfile", 1, 1, 0, OP_NOP, 0, f_fgetfile, "read to end of file"}, {"fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, "read next line from file, newline removed"}, {"fgets", 1, 1, 0, OP_NOP, 0, f_fgets, "read next line from file, newline is kept"}, {"fgetstr", 1, 1, 0, OP_NOP, 0, f_fgetstr, "read next null-terminated string from file, null\n\t\t\tcharacter is kept"}, {"files", 0, 1, 0, OP_NOP, 0, f_files, "return opened file or max number of opened files"}, {"floor", 1, 1, 0, OP_NOP, 0, f_floor, "greatest integer less than or equal to number"}, {"fopen", 2, 2, 0, OP_NOP, 0, f_fopen, "open file name a in mode b"}, {"fpathopen", 2, 3, 0, OP_NOP, 0, f_fpathopen, "open file name a in mode b, search for a along\n\t\t\tCALCPATH or path c"}, {"fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf, "print formatted output to opened file"}, {"fputc", 2, 2, 0, OP_NOP, 0, f_fputc, "write a character to a file"}, {"fputs", 2, IN, 0, OP_NOP, 0, f_fputs, "write one or more strings to a file"}, {"fputstr", 2, IN, 0, OP_NOP, 0, f_fputstr, "write one or more null-terminated strings to a file"}, {"free", 0, IN, FA, OP_NOP, 0, f_free, "free listed or all global variables"}, {"freebernoulli", 0, 0, 0, OP_NOP, 0, f_freebern, "free stored Bernoulli numbers"}, {"freeeuler", 0, 0, 0, OP_NOP, 0, f_freeeuler, "free stored Euler numbers"}, {"freeglobals", 0, 0, 0, OP_NOP, 0, f_freeglobals, "free all global and visible static variables"}, {"freeredc", 0, 0, 0, OP_NOP, 0, f_freeredc, "free redc data cache"}, {"freestatics", 0, 0, 0, OP_NOP, 0, f_freestatics, "free all unscoped static variables"}, {"freopen", 2, 3, 0, OP_NOP, 0, f_freopen, "reopen a file stream to a named file"}, {"fscan", 2, IN, FA, OP_NOP, 0, f_fscan, "scan a file for assignments to one or\n\t\t\tmore variables"}, {"fscanf", 2, IN, FA, OP_NOP, 0, f_fscanf, "formatted scan of a file for assignment to one\n\t\t\tor more variables"}, {"fseek", 2, 3, 0, OP_NOP, 0, f_fseek, "seek to position b (offset from c) in file a"}, {"fsize", 1, 1, 0, OP_NOP, 0, f_fsize, "return the size of the file"}, {"ftell", 1, 1, 0, OP_NOP, 0, f_ftell, "return the file position"}, {"frac", 1, 1, 0, OP_FRAC, qfrac, 0, "fractional part of value"}, {"gcd", 1, IN, 0, OP_NOP, f_gcd, 0, "greatest common divisor"}, {"gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0, "a divided repeatedly by gcd with b"}, {"gd", 1, 2, 0, OP_NOP, 0, f_gd, "gudermannian function"}, {"getenv", 1, 1, 0, OP_NOP, 0, f_getenv, "value of environment variable (or NULL)"}, {"hash", 1, IN, 0, OP_NOP, 0, f_hash, "return non-negative hash value for one or\n\t\t\tmore values"}, {"head", 2, 2, 0, OP_NOP, 0, f_head, "return list of specified number at head of a list"}, {"highbit", 1, 1, 0, OP_HIGHBIT, 0, 0, "high bit number in base 2 representation"}, {"hmean", 0, IN, 0, OP_NOP, 0, f_hmean, "harmonic mean of values"}, {"hnrmod", 4, 4, 0, OP_NOP, f_hnrmod, 0, "v mod h*2^n+r, h>0, n>0, r = -1, 0 or 1"}, {"hypot", 2, 3, FE, OP_NOP, qhypot, 0, "hypotenuse of right triangle within accuracy c"}, {"ilog", 2, 2, 0, OP_NOP, 0, f_ilog, "integral log of a to integral base b"}, {"ilog10", 1, 1, 0, OP_NOP, 0, f_ilog10, "integral log of a number base 10"}, {"ilog2", 1, 1, 0, OP_NOP, 0, f_ilog2, "integral log of a number base 2"}, {"im", 1, 1, 0, OP_IM, 0, 0, "imaginary part of complex number"}, {"indices", 2, 2, 0, OP_NOP, 0, f_indices, "indices of a specified assoc or mat value"}, {"inputlevel", 0, 0, 0, OP_NOP, 0, f_inputlevel, "current input depth"}, {"insert", 2, IN, FA, OP_NOP, 0, f_listinsert, "insert values c ... into list a at position b"}, {"int", 1, 1, 0, OP_INT, qint, 0, "integer part of value"}, {"inverse", 1, 1, 0, OP_INVERT, 0, 0, "multiplicative inverse of value"}, {"iroot", 2, 2, 0, OP_NOP, qiroot, 0, "integer b'th root of a"}, {"isassoc", 1, 1, 0, OP_ISASSOC, 0, 0, "whether a value is an association"}, {"isatty", 1, 1, 0, OP_NOP, 0, f_isatty, "whether a file is a tty"}, {"isblk", 1, 1, 0, OP_ISBLK, 0, 0, "whether a value is a block"}, {"isconfig", 1, 1, 0, OP_ISCONFIG, 0, 0, "whether a value is a config state"}, {"isdefined", 1, 1, 0, OP_ISDEFINED, 0, 0, "whether a string names a function"}, {"iserror", 1, 1, 0, OP_NOP, 0, f_iserror, "where a value is an error"}, {"iseven", 1, 1, 0, OP_ISEVEN, 0, 0, "whether a value is an even integer"}, {"isfile", 1, 1, 0, OP_ISFILE, 0, 0, "whether a value is a file"}, {"ishash", 1, 1, 0, OP_ISHASH, 0, 0, "whether a value is a hash state"}, {"isident", 1, 1, 0, OP_NOP, 0, f_isident, "returns 1 if identity matrix"}, {"isint", 1, 1, 0, OP_ISINT, 0, 0, "whether a value is an integer"}, {"islist", 1, 1, 0, OP_ISLIST, 0, 0, "whether a value is a list"}, {"ismat", 1, 1, 0, OP_ISMAT, 0, 0, "whether a value is a matrix"}, {"ismult", 2, 2, 0, OP_NOP, f_ismult, 0, "whether a is a multiple of b"}, {"isnull", 1, 1, 0, OP_ISNULL, 0, 0, "whether a value is the null value"}, {"isnum", 1, 1, 0, OP_ISNUM, 0, 0, "whether a value is a number"}, {"isobj", 1, 1, 0, OP_ISOBJ, 0, 0, "whether a value is an object"}, {"isobjtype", 1, 1, 0, OP_ISOBJTYPE, 0,0, "whether a string names an object type"}, {"isodd", 1, 1, 0, OP_ISODD, 0, 0, "whether a value is an odd integer"}, {"isoctet", 1, 1, 0, OP_ISOCTET, 0, 0, "whether a value is an octet"}, {"isprime", 1, 2, 0, OP_NOP, f_isprime, 0, "whether a is a small prime, return b if error"}, {"isptr", 1, 1, 0, OP_ISPTR, 0, 0, "whether a value is a pointer"}, {"isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, "integer part of square root"}, {"isrand", 1, 1, 0, OP_ISRAND, 0, 0, "whether a value is a additive 55 state"}, {"israndom", 1, 1, 0, OP_ISRANDOM, 0, 0, "whether a value is a Blum state"}, {"isreal", 1, 1, 0, OP_ISREAL, 0, 0, "whether a value is a real number"}, {"isrel", 2, 2, 0, OP_NOP, f_isrel, 0, "whether two numbers are relatively prime"}, {"isstr", 1, 1, 0, OP_ISSTR, 0, 0, "whether a value is a string"}, {"issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0, "whether value is a simple type"}, {"issq", 1, 1, 0, OP_NOP, f_issquare, 0, "whether or not number is a square"}, {"istype", 2, 2, 0, OP_ISTYPE, 0, 0, "whether the type of a is same as the type of b"}, {"jacobi", 2, 2, 0, OP_NOP, qjacobi, 0, "-1 => a is not quadratic residue mod b\n\t\t\t1 => b is composite, or a is quad residue of b"}, {"join", 1, IN, 0, OP_NOP, 0, f_join, "join one or more lists into one list"}, {"lcm", 1, IN, 0, OP_NOP, f_lcm, 0, "least common multiple"}, {"lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0, "lcm of all integers up till number"}, {"lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0, "lowest prime factor of a in first b primes"}, {"links", 1, 1, 0, OP_LINKS, 0, 0, "links to number or string value"}, {"list", 0, IN, 0, OP_NOP, 0, f_list, "create list of specified values"}, {"ln", 1, 2, 0, OP_NOP, 0, f_ln, "natural logarithm of value a within accuracy b"}, {"log", 1, 2, 0, OP_NOP, 0, f_log, "base 10 logarithm of value a within accuracy b"}, {"lowbit", 1, 1, 0, OP_LOWBIT, 0, 0, "low bit number in base 2 representation"}, {"ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0, "leg-to-leg of unit right triangle (sqrt(1 - a^2))"}, {"makelist", 1, 1, 0, OP_NOP, 0, f_makelist, "create a list with a null elements"}, {"matdim", 1, 1, 0, OP_NOP, 0, f_matdim, "number of dimensions of matrix"}, {"matfill", 2, 3, FA, OP_NOP, 0, f_matfill, "fill matrix with value b (value c on diagonal)"}, {"matmax", 2, 2, 0, OP_NOP, 0, f_matmax, "maximum index of matrix a dim b"}, {"matmin", 2, 2, 0, OP_NOP, 0, f_matmin, "minimum index of matrix a dim b"}, {"matsum", 1, 1, 0, OP_NOP, 0, f_matsum, "sum the numeric values in a matrix"}, {"mattrace", 1, 1, 0, OP_NOP, 0, f_mattrace, "return the trace of a square matrix"}, {"mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans, "transpose of matrix"}, {"max", 0, IN, 0, OP_NOP, 0, f_max, "maximum value"}, {"md5", 0, IN, 0, OP_NOP, 0, f_md5, "MD5 Hash Algorithm"}, {"memsize", 1, 1, 0, OP_NOP, 0, f_memsize, "number of octets used by the value, including overhead"}, {"meq", 3, 3, 0, OP_NOP, f_meq, 0, "whether a and b are equal modulo c"}, {"min", 0, IN, 0, OP_NOP, 0, f_min, "minimum value"}, {"minv", 2, 2, 0, OP_NOP, qminv, 0, "inverse of a modulo b"}, {"mmin", 2, 2, 0, OP_NOP, 0, f_mmin, "a mod b value with smallest abs value"}, {"mne", 3, 3, 0, OP_NOP, f_mne, 0, "whether a and b are not equal modulo c"}, {"mod", 2, 3, 0, OP_NOP, 0, f_mod, "residue of a modulo b, rounding type c"}, {"modify", 2, 2, FA, OP_NOP, 0, f_modify, "modify elements of a list or matrix"}, {"name", 1, 1, 0, OP_NOP, 0, f_name, "name assigned to block or file"}, {"near", 2, 3, 0, OP_NOP, f_near, 0, "sign of (abs(a-b) - c)"}, {"newerror", 0, 1, 0, OP_NOP, 0, f_newerror, "create new error type with message a"}, {"nextcand", 1, 5, 0, OP_NOP, f_nextcand, 0, "smallest value == d mod e > a, ptest(a,b,c) true"}, {"nextprime", 1, 2, 0, OP_NOP, f_nprime, 0, "return next small prime, return b if err"}, {"norm", 1, 1, 0, OP_NORM, 0, 0, "norm of a value (square of absolute value)"}, {"null", 0, IN, 0, OP_NOP, 0, f_null, "null value"}, {"num", 1, 1, 0, OP_NUMERATOR, qnum, 0, "numerator of fraction"}, {"ord", 1, 1, 0, OP_NOP, 0, f_ord, "integer corresponding to character value"}, {"param", 1, 1, 0, OP_ARGVALUE, 0, 0, "value of parameter n (or parameter count if n\n\t\t\tis zero)"}, {"perm", 2, 2, 0, OP_NOP, qperm, 0, "permutation number a!/(a-b)!"}, {"prevcand", 1, 5, 0, OP_NOP, f_prevcand, 0, "largest value == d mod e < a, ptest(a,b,c) true"}, {"prevprime", 1, 2, 0, OP_NOP, f_pprime, 0, "return previous small prime, return b if err"}, {"pfact", 1, 1, 0, OP_NOP, qpfact, 0, "product of primes up till number"}, {"pi", 0, 1, FE, OP_NOP, qpi, 0, "value of pi accurate to within epsilon"}, {"pix", 1, 2, 0, OP_NOP, f_pix, 0, "number of primes <= a < 2^32, return b if error"}, {"places", 1, 2, 0, OP_NOP, 0, f_places, "places after \"decimal\" point (-1 if infinite)"}, {"pmod", 3, 3, 0, OP_NOP, qpowermod,0, "mod of a power (a ^ b (mod c))"}, {"polar", 2, 3, 0, OP_NOP, 0, f_polar, "complex value of polar coordinate (a * exp(b*1i))"}, {"poly", 1, IN, 0, OP_NOP, 0, f_poly, "evaluates a polynomial given its coefficients\n\t\t\tor coefficient-list"}, {"pop", 1, 1, FA, OP_NOP, 0, f_listpop, "pop value from front of list"}, {"popcnt", 1, 2, 0, OP_NOP, f_popcnt, 0, "number of bits in a that match b (or 1)"}, {"power", 2, 3, 0, OP_NOP, 0, f_power, "value a raised to the power b within accuracy c"}, {"protect", 1, 3, FA, OP_NOP, 0, f_protect, "read or set protection level for variable"}, {"ptest", 1, 3, 0, OP_NOP, f_primetest, 0, "probabilistic primality test"}, {"printf", 1, IN, 0, OP_NOP, 0, f_printf, "print formatted output to stdout"}, {"prompt", 1, 1, 0, OP_NOP, 0, f_prompt, "prompt for input line using value a"}, {"push", 1, IN, FA, OP_NOP, 0, f_listpush, "push values onto front of list"}, {"putenv", 1, 2, 0, OP_NOP, 0, f_putenv, "define an environment variable"}, {"quo", 2, 3, 0, OP_NOP, 0, f_quo, "integer quotient of a by b, rounding type c"}, {"quomod", 4, 5, FA, OP_NOP, 0, f_quomod, "set c and d to quotient and remainder of a\n\t\t\tdivided by b"}, {"rand", 0, 2, 0, OP_NOP, f_rand, 0, "additive 55 random number [0,2^64), [0,a), or [a,b)"}, {"randbit", 0, 1, 0, OP_NOP, f_randbit, 0, "additive 55 random number [0,2^a)"}, {"random", 0, 2, 0, OP_NOP, f_random, 0, "Blum-Blum-Shub random number [0,2^64), [0,a), or [a,b)"}, {"randombit", 0, 1, 0, OP_NOP, f_randombit, 0, "Blum-Blum-Sub random number [0,2^a)"}, {"randperm", 1, 1, 0, OP_NOP, 0, f_randperm, "random permutation of a list or matrix"}, {"rcin", 2, 2, 0, OP_NOP, qredcin, 0, "convert normal number a to REDC number mod b"}, {"rcmul", 3, 3, 0, OP_NOP, qredcmul, 0, "multiply REDC numbers a and b mod c"}, {"rcout", 2, 2, 0, OP_NOP, qredcout, 0, "convert REDC number a mod b to normal number"}, {"rcpow", 3, 3, 0, OP_NOP, qredcpower, 0, "raise REDC number a to power b mod c"}, {"rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0, "square REDC number a mod b"}, {"re", 1, 1, 0, OP_RE, 0, 0, "real part of complex number"}, {"remove", 1, 1, FA, OP_NOP, 0, f_listremove, "remove value from end of list"}, {"reverse", 1, 1, 0, OP_NOP, 0, f_reverse, "reverse a copy of a matrix or list"}, {"rewind", 0, IN, 0, OP_NOP, 0, f_rewind, "rewind file(s)"}, {"rm", 1, IN, 0, OP_NOP, 0, f_rm, "remove file(s), -f turns off no-such-file errors"}, {"root", 2, 3, 0, OP_NOP, 0, f_root, "value a taken to the b'th root within accuracy c"}, {"round", 1, 3, 0, OP_NOP, 0, f_round, "round value a to b number of decimal places"}, {"rsearch", 2, 4, 0, OP_NOP, 0, f_rsearch, "reverse search matrix or list for value b\n\t\t\tstarting at index c"}, {"runtime", 0, 0, 0, OP_NOP, f_runtime, 0, "user and kernel mode cpu time in seconds"}, {"saveval", 1, 1, 0, OP_SAVEVAL, 0, 0, "set flag for saving values"}, {"scale", 2, 2, 0, OP_SCALE, 0, 0, "scale value up or down by a power of two"}, {"scan", 1, IN, FA, OP_NOP, 0, f_scan, "scan standard input for assignment to one\n\t\t\tor more variables"}, {"scanf", 2, IN, FA, OP_NOP, 0, f_scanf, "formatted scan of standard input for assignment\n\t\t\tto variables"}, {"search", 2, 4, 0, OP_NOP, 0, f_search, "search matrix or list for value b starting\n\t\t\tat index c"}, {"sec", 1, 2, 0, OP_NOP, 0, f_sec, "sec of a within accuracy b"}, {"sech", 1, 2, 0, OP_NOP, 0, f_sech, "hyperbolic secant of a within accuracy b"}, {"seed", 0, 0, 0, OP_NOP, f_seed, 0, "return a 64 bit seed for a psuedo-random generator"}, {"segment", 2, 3, 0, OP_NOP, 0, f_segment, "specified segment of specified list"}, {"select", 2, 2, 0, OP_NOP, 0, f_select, "form sublist of selected elements from list"}, {"setbit", 2, 3, 0, OP_NOP, 0, f_setbit, "set specified bit in string"}, {"sgn", 1, 1, 0, OP_SGN, qsign, 0, "sign of value (-1, 0, 1)"}, {"sha", 0, IN, 0, OP_NOP, 0, f_sha, "old Secure Hash Algorithm (SHS FIPS Pub 180)"}, {"sha1", 0, IN, 0, OP_NOP, 0, f_sha1, "Secure Hash Algorithm (SHS-1 FIPS Pub 180-1)"}, {"sin", 1, 2, 0, OP_NOP, 0, f_sin, "sine of value a within accuracy b"}, {"sinh", 1, 2, 0, OP_NOP, 0, f_sinh, "hyperbolic sine of a within accuracy b"}, {"size", 1, 1, 0, OP_NOP, 0, f_size, "total number of elements in value"}, {"sizeof", 1, 1, 0, OP_NOP, 0, f_sizeof, "number of octets used to hold the value"}, {"sleep", 0, 1, 0, OP_NOP, 0, f_sleep, "suspend operation for a seconds"}, {"sort", 1, 1, 0, OP_NOP, 0, f_sort, "sort a copy of a matrix or list"}, {"sqrt", 1, 3, 0, OP_NOP, 0, f_sqrt, "square root of value a within accuracy b"}, {"srand", 0, 1, 0, OP_NOP, 0, f_srand, "seed the rand() function"}, {"srandom", 0, 4, 0, OP_NOP, 0, f_srandom, "seed the random() function"}, {"ssq", 1, IN, 0, OP_NOP, 0, f_ssq, "sum of squares of values"}, {"stoponerror", 0, 1, 0, OP_NOP, 0, f_stoponerror, "assign value to stoponerror flag"}, {"str", 1, 1, 0, OP_NOP, 0, f_str, "simple value converted to string"}, {"strcat", 1,IN, 0, OP_NOP, 0, f_strcat, "concatenate strings together"}, {"strcmp", 2, 2, 0, OP_NOP, 0, f_strcmp, "compare two strings"}, {"strcpy", 2, 2, 0, OP_NOP, 0, f_strcpy, "copy string to string"}, {"strerror", 0, 1, 0, OP_NOP, 0, f_strerror, "string describing error type"}, {"strlen", 1, 1, 0, OP_NOP, 0, f_strlen, "length of string"}, {"strncmp", 3, 3, 0, OP_NOP, 0, f_strncmp, "compare strings a, b to c characters"}, {"strncpy", 3, 3, 0, OP_NOP, 0, f_strncpy, "copy up to c characters from string to string"}, {"strpos", 2, 2, 0, OP_NOP, 0, f_strpos, "index of first occurrence of b in a"}, {"strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, "return formatted output as a string"}, {"strscan", 2, IN, FA, OP_NOP, 0, f_strscan, "scan a string for assignments to one or more variables"}, {"strscanf", 2, IN, FA, OP_NOP, 0, f_strscanf, "formatted scan of string for assignments to variables"}, {"substr", 3, 3, 0, OP_NOP, 0, f_substr, "substring of a from position b for c chars"}, {"sum", 0, IN, 0, OP_NOP, 0, f_sum, "sum of list or object sums and/or other terms"}, {"swap", 2, 2, 0, OP_SWAP, 0, 0, "swap values of variables a and b (can be dangerous)"}, {"system", 1, 1, 0, OP_NOP, 0, f_system, "call Unix command"}, {"systime", 0, 0, 0, OP_NOP, f_systime, 0, "kernel mode cpu time in seconds"}, {"tail", 2, 2, 0, OP_NOP, 0, f_tail, "retain list of specified number at tail of list"}, {"tan", 1, 2, 0, OP_NOP, 0, f_tan, "tangent of a within accuracy b"}, {"tanh", 1, 2, 0, OP_NOP, 0, f_tanh, "hyperbolic tangent of a within accuracy b"}, {"test", 1, 1, 0, OP_TEST, 0, 0, "test that value is nonzero"}, {"time", 0, 0, 0, OP_NOP, f_time, 0, "number of seconds since 00:00:00 1 Jan 1970 UTC"}, {"trunc", 1, 2, 0, OP_NOP, f_trunc, 0, "truncate a to b number of decimal places"}, {"ungetc", 2, 2, 0, OP_NOP, 0, f_ungetc, "unget char read from file"}, {"usertime", 0, 0, 0, OP_NOP, f_usertime, 0, "user mode cpu time in seconds"}, {"version", 0, 0, 0, OP_NOP, 0, f_version, "calc version string"}, {"xor", 1, IN, 0, OP_NOP, 0, f_xor, "logical xor"}, /* end of table */ {NULL, 0, 0, 0, 0, 0, 0, NULL} }; /* * Show the list of primitive built-in functions * * When FUNCLIST is defined, we are being compiled by rules from the help * sub-directory to form a program that will produce the main part of the * buiiltin help file. * * See the builtin rule in the help/Makefile for details. */ #if defined(FUNCLIST) /*ARGSUSED*/ int main(int argc, char *argv[]) { CONST struct builtin *bp; /* current function */ printf("\nName\tArgs\tDescription\n\n"); for (bp = builtins; bp->b_name; bp++) { printf("%-9s ", bp->b_name); if (bp->b_maxargs == IN) printf("%d+ ", bp->b_minargs); else if (bp->b_minargs == bp->b_maxargs) printf("%-6d", bp->b_minargs); else printf("%d-%-4d", bp->b_minargs, bp->b_maxargs); printf("%s\n", bp->b_desc); } printf("\n"); return 0; /* exit(0); */ } #else /* FUNCLIST */ void showbuiltins(void) { CONST struct builtin *bp; /* current function */ int i; printf("\nName\tArgs\tDescription\n\n"); for (bp = builtins, i = 0; bp->b_name; bp++, i++) { printf("%-14s ", bp->b_name); if (bp->b_maxargs == IN) printf("%d+ ", bp->b_minargs); else if (bp->b_minargs == bp->b_maxargs) printf("%-6d", bp->b_minargs); else printf("%d-%-4d", bp->b_minargs, bp->b_maxargs); printf("%s\n", bp->b_desc); if (i == 32) { i = 0; if (getchar() == 27) break; } } printf("\n"); } #endif /* FUNCLIST */ #if !defined(FUNCLIST) /* * Call a built-in function. * Arguments to the function are on the stack, but are not removed here. * Functions are either purely numeric, or else can take any value type. * * given: * index index on where to scan in builtin table * argcount number of args * stck arguments on the stack */ VALUE builtinfunc(long index, int argcount, VALUE *stck) { VALUE *sp; /* pointer to stack entries */ VALUE **vpp; /* pointer to current value address */ CONST struct builtin *bp; /* builtin function to be called */ NUMBER *numargs[IN]; /* numeric arguments for function */ VALUE *valargs[IN]; /* addresses of actual arguments */ VALUE result; /* general result of function */ long i; if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1) { math_error("Bad built-in function index"); /*NOTREACHED*/ } bp = &builtins[index]; if (argcount < bp->b_minargs) { math_error("Too few arguments for builtin function \"%s\"", bp->b_name); /*NOTREACHED*/ } if ((argcount > bp->b_maxargs) || (argcount > IN)) { math_error("Too many arguments for builtin function \"%s\"", bp->b_name); /*NOTREACHED*/ } /* * If an address was passed, then point at the real variable, * otherwise point at the stack value itself (unless the function * is very special). */ sp = stck - argcount + 1; vpp = valargs; for (i = argcount; i > 0; i--) { if ((sp->v_type != V_ADDR) || (bp->b_flags & FA)) *vpp = sp; else *vpp = sp->v_addr; sp++; vpp++; } /* * Handle general values if the function accepts them. */ if (bp->b_valfunc) { vpp = valargs; if ((bp->b_minargs == 1) && (bp->b_maxargs == 1)) result = (*bp->b_valfunc)(vpp[0]); else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2)) result = (*bp->b_valfunc)(vpp[0], vpp[1]); else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3)) result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]); else if ((bp->b_minargs == 4) && (bp->b_maxargs == 4)) result = (*bp->b_valfunc)(vpp[0],vpp[1],vpp[2],vpp[3]); else result = (*bp->b_valfunc)(argcount, vpp); return result; } /* * Function must be purely numeric, so handle that. */ vpp = valargs; for (i = 0; i < argcount; i++) { if ((*vpp)->v_type != V_NUM) { math_error("Non-real argument for builtin function %s", bp->b_name); /*NOTREACHED*/ } numargs[i] = (*vpp)->v_num; vpp++; } result.v_type = V_NUM; result.v_subtype = V_NOSUBTYPE; if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) { result.v_num = (*bp->b_numfunc)(argcount, numargs); return result; } if ((bp->b_flags & FE) && (argcount < bp->b_maxargs)) numargs[argcount++] = conf->epsilon; switch (argcount) { case 0: result.v_num = (*bp->b_numfunc)(); break; case 1: result.v_num = (*bp->b_numfunc)(numargs[0]); break; case 2: result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]); break; case 3: result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2]); break; case 4: result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2], numargs[3]); break; default: math_error("Bad builtin function call"); /*NOTREACHED*/ } return result; } /* * Return the index of a built-in function given its name. * Returns minus one if the name is not known. */ int getbuiltinfunc(char *name) { CONST struct builtin *bp; for (bp = builtins; bp->b_name; bp++) { if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0)) return (bp - builtins); } return -1; } /* * Given the index of a built-in function, return its name. */ char * builtinname(long index) { if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1) return ""; return builtins[index].b_name; } /* * Given the index of a built-in function, and the number of arguments seen, * determine if the number of arguments are legal. This routine is called * during parsing time. */ void builtincheck(long index, int count) { CONST struct builtin *bp; if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1) { math_error("Unknown built in index"); /*NOTREACHED*/ } bp = &builtins[index]; if (count < bp->b_minargs) scanerror(T_NULL, "Too few arguments for builtin function \"%s\"", bp->b_name); if (count > bp->b_maxargs) scanerror(T_NULL, "Too many arguments for builtin function \"%s\"", bp->b_name); } /* * Return the opcode for a built-in function that can be used to avoid * the function call at all. */ int builtinopcode(long index) { if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1) return OP_NOP; return builtins[index].b_opcode; } /* * Show the error-values created by newerror(str). */ void showerrors(void) { int i; if (nexterrnum == E_USERDEF) printf("No new error-values created\n"); for (i = E_USERDEF; i < nexterrnum; i++) printf("%d: %s\n", i, namestr(&newerrorstr, i - E_USERDEF)); } /* * malloced_putenv - Keep track of malloced environment variable storage * * given: * str a malloced string which will be given to putenv * * returns: * putenv() return value * * NOTE: The caller MUST pass a string that the caller has previously malloced. */ S_FUNC int malloced_putenv(char *str) { char *value; /* location of the value part of the str argument */ char *old_val; /* previously stored (or inherited) env value */ int found_cnt; /* number of active env_pool entries found */ struct env_pool *new; /* new e_pool */ int i; /* * firewall */ if (str == NULL) { math_error("malloced_putenv given a NULL pointer!!"); /*NOTREACHED*/ } if (str[0] == '=') { math_error("malloced_putenv = is first character in string!!"); /*NOTREACHED*/ } /* * determine the place where getenv would return */ value = strchr(str, '='); if (value == NULL) { math_error("malloced_putenv = not found in string!!"); /*NOTREACHED*/ } ++value; /* * lookup for an existing environment value */ *(value-1) = '\0'; old_val = getenv(str); *(value-1) = '='; /* * If we have the value in our environment, look for a * previously malloced string and free it */ if (old_val != NULL && env_pool_cnt > 0) { for (i=0, found_cnt=0; i < env_pool_max && found_cnt < env_pool_cnt; ++i) { /* skip an unused entry */ if (e_pool[i].getenv == NULL) { continue; } ++found_cnt; /* look for the 1st match */ if (e_pool[i].getenv == value) { /* found match, free the storage */ if (e_pool[i].putenv != NULL) { free(e_pool[i].putenv); } e_pool[i].getenv = NULL; --env_pool_cnt; break; } } } /* * ensure that we have room in the e_pool */ if (env_pool_max == 0) { /* allocate an initial pool (with one extra guard value) */ new = (struct env_pool *)malloc((ENV_POOL_CHUNK+1) * sizeof(struct env_pool)); if (new == NULL) { math_error("malloced_putenv malloc failed"); /*NOTREACHED*/ } e_pool = new; env_pool_max = ENV_POOL_CHUNK; for (i=0; i <= ENV_POOL_CHUNK; ++i) { e_pool[i].getenv = NULL; } } else if (env_pool_cnt >= env_pool_max) { /* expand the current pool (with one extra guard value) */ new = (struct env_pool *)realloc(e_pool, (env_pool_max+ENV_POOL_CHUNK+1) * sizeof(struct env_pool)); if (new == NULL) { math_error("malloced_putenv realloc failed"); /*NOTREACHED*/ } e_pool = new; for (i=env_pool_max; i <= env_pool_max + ENV_POOL_CHUNK; ++i) { e_pool[i].getenv = NULL; } env_pool_max += ENV_POOL_CHUNK; } /* * store our data into the first e_pool entry */ for (i=0; i < env_pool_max; ++i) { /* skip used entries */ if (e_pool[i].getenv != NULL) { continue; } /* store in this free entry and stop looping */ e_pool[i].getenv = value; e_pool[i].putenv = str; ++env_pool_cnt; break; } if (i >= env_pool_max) { math_error("malloced_putenv missed unused entry!!"); /*NOTREACHED*/ } /* * finally, do the putenv action */ return putenv(str); } #endif /* FUNCLIST */