drygdryg/calc
1
0
Fork 0
mirror of https://github.com/lcn2/calc.git synced 2025-08-16 01:03:29 +03:00
Code Issues Packages Projects Releases Wiki Activity
Files
2.12.4.12
calc/func.c
Landon Curt Noll 57a22a6f39 Release calc version 2.12.4.12
2017-05-21 15:38:58 -07:00

9477 lines
191 KiB
C
Raw Permalink Blame History

/*
* 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.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.9 $
* @(#) $Id: func.c,v 30.9 2013/09/02 01:38:08 chongo Exp $
* @(#) $Source: /usr/local/src/bin/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 <stdio.h>
#include <ctype.h>
#include <sys/types.h>
#include <errno.h>
#if defined(_WIN32)
# include <io.h>
# 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 <unistd.h>
#endif
#include "have_stdlib.h"
#if defined(HAVE_STDLIB_H)
#include <stdlib.h>
#endif
#include "have_string.h"
#if defined(HAVE_STRING_H)
#include <string.h>
#endif
#include "have_times.h"
#if defined(HAVE_TIME_H)
#include <time.h>
#endif
#if defined(HAVE_TIMES_H)
#include <times.h>
#endif
#if defined(HAVE_SYS_TIME_H)
#include <sys/time.h>
#endif
#if defined(HAVE_SYS_TIMES_H)
#include <sys/times.h>
#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 <sys/resource.h>
#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 "str.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_strcasecmp(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_STRCASECMP);
flag = stringcaserel(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_strncasecmp(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_STRNCASECMP);
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 = stringcaserel(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_strtoupper(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR)
return error_value(E_STRTOUPPER);
result.v_str = stringtoupper(vp->v_str);
result.v_type = V_STR;
return result;
}
S_FUNC VALUE
f_strtolower(VALUE *vp)
{
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
if (vp->v_type != V_STR)
return error_value(E_STRTOLOWER);
result.v_str = stringtolower(vp->v_str);
result.v_type = V_STR;
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_isupper(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISUPPER);
}
result.v_type = V_NUM;
result.v_num = itoq( (isupper( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_islower(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISLOWER);
}
result.v_type = V_NUM;
result.v_num = itoq( (islower( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isalnum(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISALNUM);
}
result.v_type = V_NUM;
result.v_num = itoq( (isalnum( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isalpha(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISALPHA);
}
result.v_type = V_NUM;
result.v_num = itoq( (isalpha( c ))?1l:0l);
return result;
}
#if 0
/* Not in C-standard, marked as obsolete in POSIX.1-2008 */
S_FUNC VALUE
f_isascii(VALUE *vp)
{
char c;
VALUE result;
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISASCII);
}
result.v_type = V_NUM;
result.v_num = itoq( (isascii( c ))?1l:0l);
return result;
}
#endif /* 0 */
S_FUNC VALUE
f_iscntrl(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISCNTRL);
}
result.v_type = V_NUM;
result.v_num = itoq( (iscntrl( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isdigit(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISDIGIT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isdigit( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isgraph(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISGRAPH);
}
result.v_type = V_NUM;
result.v_num = itoq( (isgraph( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isprint(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISPRINT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isprint( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_ispunct(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISPUNCT);
}
result.v_type = V_NUM;
result.v_num = itoq( (ispunct( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isspace(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISSPACE);
}
result.v_type = V_NUM;
result.v_num = itoq( (isspace( c ))?1l:0l);
return result;
}
S_FUNC VALUE
f_isxdigit(VALUE *vp)
{
char c;
VALUE result;
/* initialize VALUE */
result.v_subtype = V_NOSUBTYPE;
switch(vp->v_type) {
case V_STR:
c = *vp->v_str->s_str;
break;
case V_OCTET:
c = *vp->v_octet;
break;
default:
return error_value(E_ISXDIGIT);
}
result.v_type = V_NUM;
result.v_num = itoq( (isxdigit( c ))?1l:0l);
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) {
#if !defined(_WIN32)
i = flushall();
#endif /* Windoz free systems */
} 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_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(SHA1_HASH_TYPE, NULL);
} else if (count == 1 && vals[0]->v_type == V_HASH &&
vals[0]->v_hash->hashtype == SHA1_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 == SHA1_HASH_TYPE) {
state = hash_copy(vals[0]->v_hash);
i = 1;
/*
* otherwise use the default initial state
*/
} else {
state = hash_init(SHA1_HASH_TYPE, NULL);
i = 0;
}
/*
* hash the remaining values
*/
do {
state = hash_value(SHA1_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"},
{"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"},
{"isupper", 1, 1, 0, OP_NOP, 0, f_isupper,
"whether character is upper case"},
{"islower", 1, 1, 0, OP_NOP, 0, f_islower,
"whether character is lower case"},
{"isalnum", 1, 1, 0, OP_NOP, 0, f_isalnum,
"whether character is alpha-numeric"},
{"isalpha", 1, 1, 0, OP_NOP, 0, f_isalpha,
"whether character is alphabetic"},
{"iscntrl", 1, 1, 0, OP_NOP, 0, f_iscntrl,
"whether character is a control character"},
{"isdigit", 1, 1, 0, OP_NOP, 0, f_isdigit,
"whether character is a digit"},
{"isgraph", 1, 1, 0, OP_NOP, 0, f_isgraph,
"whether character is a graphical character"},
{"isprint", 1, 1, 0, OP_NOP, 0, f_isprint,
"whether character is printable"},
{"ispunct", 1, 1, 0, OP_NOP, 0, f_ispunct,
"whether character is a punctuation"},
{"isspace", 1, 1, 0, OP_NOP, 0, f_isspace,
"whether character is a space character"},
{"isxdigit", 1, 1, 0, OP_NOP, 0, f_isxdigit,
"whether character is a hexadecimal digit"},
{"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)"},
{"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"},
{"strtoupper", 1, 1, 0, OP_NOP, 0, f_strtoupper,
"Make string upper case"},
{"strtolower", 1, 1, 0, OP_NOP, 0, f_strtolower,
"Make string lower case"},
{"strcat", 1,IN, 0, OP_NOP, 0, f_strcat,
"concatenate strings together"},
{"strcmp", 2, 2, 0, OP_NOP, 0, f_strcmp,
"compare two strings"},
{"strcasecmp", 2, 2, 0, OP_NOP, 0, f_strcasecmp,
"compare two strings case independent"},
{"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"},
{"strncasecmp", 3, 3, 0, OP_NOP, 0, f_strncasecmp,
"compare strings a, b to c characters case independent"},
{"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 */
Reference in New Issue View Git Blame Copy Permalink