func.c

Calc Software Package for Number Calc

/*
 * func - built-in functions implemented here
 *
 * Copyright (C) 1999-2006  David I. Bell, Landon Curt Noll and Ernest Bowen
 *
 * Primary author:  David I. Bell
 *
 * Calc is open software; you can redistribute it and/or modify it under
 * the terms of the version 2.1 of the GNU Lesser General Public License
 * as published by the Free Software Foundation.
 *
 * Calc is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
 * or FITNESS FOR A PARTICULAR PURPOSE.	 See the GNU Lesser General
 * Public License for more details.
 *
 * A copy of version 2.1 of the GNU Lesser General Public License is
 * distributed with calc under the filename COPYING-LGPL.  You should have
 * received a copy with calc; if not, write to Free Software Foundation, Inc.
 * 59 Temple Place, Suite 330, Boston, MA  02111-1307, USA.
 *
 * @(#) $Revision: 29.32 $
 * @(#) $Id: func.c,v 29.32 2006/12/16 10:46:07 chongo Exp $
 * @(#) $Source: /usr/local/src/cmd/calc/RCS/func.c,v $
 *
 * Under source code control:	1990/02/15 01:48:15
 * File existed as early as:	before 1990
 *
 * Share and enjoy!  :-)	http://www.isthe.com/chongo/tech/comp/calc/
 */


#include <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 */

#else /* FUNCLIST */

#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 "string.h"
#include "symbol.h"
#include "prime.h"
#include "file.h"
#include "zrand.h"
#include "zrandom.h"
#include "custom.h"

#if defined(CUSTOM)
# define E_CUSTOM_ERROR E_NO_C_ARG
#else
# define E_CUSTOM_ERROR E_NO_CUSTOM
#endif


/*
 * forward declarations
 */
static NUMBER *base_value(long mode, int defval);
static int strscan(char *s, int count, VALUE **vals);
static int filescan(FILEID id, int count, VALUE **vals);
static VALUE f_eval(VALUE *vp);
static VALUE f_fsize(VALUE *vp);
static 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 */
extern void matrandperm(MATRIX *M);
extern void listrandperm(LIST *lp);
extern int idungetc(FILEID id, int ch);
extern LIST* associndices(ASSOC *ap, long index);
extern 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)

static 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);
}


static 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;
}


static 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*/
static 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;
}


static 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;
}


static 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;
}


static 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;
}



static 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;
}


static 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;
}


static 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));
}


static NUMBER *
f_issquare(NUMBER *vp)
{
	return itoq((long) qissquare(vp));
}


static 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);
}


static 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);
}


static 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);
}


static 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);