src/common/calfunc.c

#ifndef lint
static const char       RCSid[] = "$Id: calfunc.c,v 2.34 2025/08/15 20:14:57 greg Exp $";
#endif
/*
 *  calfunc.c - routines for calcomp using functions.
 *
 *      If VARIABLE is not set, only library functions
 *  can be accessed.
 *
 *  2/19/03     Eliminated conditional compiles in favor of esupport extern.
 */

#include "copyright.h"

#include  <stdio.h>
#include  <string.h>
#include  <errno.h>
#include  <stdlib.h>
#include  <math.h>

#include  "rterror.h"
#include  "calcomp.h"

                                /* bits in argument flag (better be right!) */
#define  AFLAGSIZ       (8*sizeof(unsigned long))
#define  ALISTSIZ       10      /* maximum saved argument list */

typedef struct activation {
    char  *name;                /* function name */
    struct activation  *prev;   /* previous activation */
    double  *ap;                /* argument list */
    unsigned long  an;          /* computed argument flags */
    EPNODE  *fun;               /* argument function */
}  ACTIVATION;          /* an activation record */

static ACTIVATION  *curact = NULL;
static unsigned long  curdepth = 0, next_dreport = 100;

static double  libfunc(char *fname, VARDEF *vp);
static void  report_depth(char *nm);

#ifndef  MAXLIB
#define  MAXLIB         64      /* maximum number of library functions */
#endif

static double  l_if(char *), l_select(char *);
static double  l_min(char *), l_max(char *);
static double  l_rand(char *);
static double  l_floor(char *), l_ceil(char *);
static double  l_sqrt(char *);
static double  l_sin(char *), l_cos(char *), l_tan(char *);
static double  l_asin(char *), l_acos(char *), l_atan(char *), l_atan2(char *);
static double  l_exp(char *), l_log(char *), l_log10(char *);

                        /* functions must be listed alphabetically */
static ELIBR  library[MAXLIB] = {
    { "acos", 1, ':', l_acos },
    { "asin", 1, ':', l_asin },
    { "atan", 1, ':', l_atan },
    { "atan2", 2, ':', l_atan2 },
    { "ceil", 1, ':', l_ceil },
    { "cos", 1, ':', l_cos },
    { "exp", 1, ':', l_exp },
    { "floor", 1, ':', l_floor },
    { "if", 3, ':', l_if },
    { "log", 1, ':', l_log },
    { "log10", 1, ':', l_log10 },
    { "max", 1, ':', l_max },
    { "min", 1, ':', l_min },
    { "rand", 1, ':', l_rand },
    { "select", 1, ':', l_select },
    { "sin", 1, ':', l_sin },
    { "sqrt", 1, ':', l_sqrt },
    { "tan", 1, ':', l_tan },
};

static int  libsize = 18;

#define  resolve(ep)    ((ep)->type==VAR?(ep)->v.ln:eargf((ep)->v.chan))


int
fundefined(                     /* return # of req'd arguments for function */
        char  *fname
)
{
    ELIBR  *lp;
    VARDEF  *vp;

    if ((vp = varlookup(fname)) != NULL && vp->def != NULL
                && vp->def->v.kid->type == FUNC)
        return(nekids(vp->def->v.kid) - 1);
    lp = vp != NULL ? vp->lib : eliblookup(fname);
    if (lp == NULL)
        return(0);
    return(lp->nargs);
}


double
funvalue(                       /* return a function value to the user */
        char  *fname,
        int  n,
        double  *a
)
{
    ACTIVATION  act;
    VARDEF  *vp;
    double  rval;
                                        /* push environment */
    act.name = fname;
    act.prev = curact;
    act.ap = a;
    if (n < AFLAGSIZ)
        act.an = (1L<<n)-1;
    else {
        act.an = ~0;
        if (n > AFLAGSIZ)
            wputs("Excess arguments in funvalue()\n");
    }
    act.fun = NULL;
    curact = &act;
    if (++curdepth >= next_dreport)
        report_depth(act.name);

    if ((vp = varlookup(fname)) == NULL || vp->def == NULL
                || vp->def->v.kid->type != FUNC)
        rval = libfunc(fname, vp);
    else
        rval = evalue(vp->def->v.kid->sibling);

    curact = act.prev; curdepth--;      /* pop environment */
    return(rval);
}


void
funset(                         /* set a library function */
        char  *fname,
        int  nargs,
        int  assign,
        double  (*fptr)(char *)
)
{
    int  oldlibsize = libsize;
    char *cp;
    ELIBR  *lp;
                                                /* check for context */
    for (cp = fname; *cp; cp++)
        ;
    if (cp == fname)
        return;
    while (cp[-1] == CNTXMARK) {
        *--cp = '\0';
        if (cp == fname) return;
    }
    if ((lp = eliblookup(fname)) == NULL) {     /* insert */
        if (fptr == NULL)
                return;                         /* nothing! */
        if (libsize >= MAXLIB) {
            eputs("Too many library functons!\n");
            quit(1);
        }
        for (lp = &library[libsize]; lp > library; lp--)
            if (strcmp(lp[-1].fname, fname) > 0)
                lp[0] = lp[-1];
            else
                break;
        libsize++;
    }
    if (fptr == NULL) {                         /* delete */
        while (lp < &library[libsize-1]) {
            lp[0] = lp[1];
            lp++;
        }
        libsize--;
    } else {                                    /* or assign */
        lp[0].fname = fname;            /* string must be static! */
        lp[0].nargs = nargs;
        lp[0].atyp = assign;
        lp[0].f = fptr;
    }
    if (libsize != oldlibsize)
        elibupdate(fname);                      /* relink library */
}


int
nargum(void)                    /* return number of available arguments */
{
    int  n;

    if (curact == NULL)
        return(0);
    if (curact->fun == NULL) {
        for (n = 0; (1L<<n) & curact->an; n++)
            ;
        return(n);
    }
    return(nekids(curact->fun) - 1);
}


double
argument(int n)                 /* return nth argument for active function */
{
    ACTIVATION  *actp = curact;
    EPNODE  *ep;
    double  aval;

    if (!actp | (--n < 0)) {
        eputs("Bad call to argument!\n");
        quit(1);
    }
    if ((n < AFLAGSIZ) & actp->an >> n)         /* already computed? */
        return(actp->ap[n]);

    if (!actp->fun || !(ep = ekid(actp->fun, n+1))) {
        eputs(actp->name);
        eputs("(): too few arguments\n");
        quit(1);
    }
    curact = actp->prev; curdepth--;            /* previous context */
    aval = evalue(ep);                          /* compute argument */
    curact = actp; curdepth++;                  /* put back calling context */
    if (n < ALISTSIZ) {                         /* save value if room */
        actp->ap[n] = aval;
        actp->an |= 1L<<n;
    }
    return(aval);
}


VARDEF *
eargf(int n)                    /* return function def for nth argument */
{
    ACTIVATION  *actp;
    EPNODE  *ep;

    for (actp = curact; actp != NULL; actp = actp->prev) {

        if (n <= 0)
            break;

        if (actp->fun == NULL)
            goto badarg;

        if ((ep = ekid(actp->fun, n)) == NULL) {
            eputs(actp->name);
            eputs("(): too few arguments\n");
            quit(1);
        }
        if (ep->type == VAR)
            return(ep->v.ln);                   /* found it */

        if (ep->type != ARG)
            goto badarg;

        n = ep->v.chan;                         /* try previous context */
    }
    eputs("Bad call to eargf!\n");
    quit(1);

badarg:
    eputs(actp->name);
    eputs("(): argument not a function\n");
    quit(1);
        return NULL; /* pro forma return */
}


char *
eargfun(int n)                  /* return function name for nth argument */
{
    return(eargf(n)->name);
}


double
efunc(EPNODE *ep)                       /* evaluate a function */
{
    ACTIVATION  act;
    double  alist[ALISTSIZ];
    double  rval;
    VARDEF  *dp;
                                        /* push environment */
    dp = resolve(ep->v.kid);
    act.name = dp->name;
    act.prev = curact;
    act.ap = alist;
    act.an = 0;
    act.fun = ep;
    curact = &act;
    if (++curdepth >= next_dreport)
        report_depth(act.name);

    if (dp->def == NULL || dp->def->v.kid->type != FUNC)
        rval = libfunc(act.name, dp);
    else
        rval = evalue(dp->def->v.kid->sibling);
    
    curact = act.prev; curdepth--;      /* pop environment */
    return(rval);
}


double
eargument(                              /* evaluate an argument */
    EPNODE      *ep
)
{
    if ((ep->v.chan <= AFLAGSIZ) & curact->an >> (ep->v.chan-1))
        return(curact->ap[ep->v.chan-1]);

    return(argument(ep->v.chan));
}


ELIBR *
eliblookup(char *fname)         /* look up a library function */
{
    int  upper, lower;
    int  cm, i;

    lower = 0;
    upper = cm = libsize;

    while ((i = (lower + upper) >> 1) != cm) {
        cm = strcmp(fname, library[i].fname);
        if (cm > 0)
            lower = i;
        else if (cm < 0)
            upper = i;
        else
            return(&library[i]);
        cm = i;
    }
    return(NULL);
}


/*
 *  The following routines are for internal use:
 */


static void
report_depth(char *nm)                  /* report current function call depth */
{
        char    msg[RMAXWORD+48];

        sprintf(msg, "%s(): depth level at %lu\n", nm, curdepth);
        wputs(msg);
        if (curdepth >= next_dreport)
                next_dreport *= 10;
}


static double
libfunc(                                /* execute library function */
        char  *fname,
        VARDEF  *vp
)
{
    ELIBR  *lp;
    double  d;
    int  lasterrno;

    if (vp != NULL)
        lp = vp->lib;
    else
        lp = eliblookup(fname);
    if (lp == NULL) {
        eputs(fname);
        eputs("(): undefined function\n");
        quit(1);
    }
    lasterrno = errno;
    errno = 0;
    d = (*lp->f)(lp->fname);
#ifdef  isnan
    if (errno == 0) {
        if (isnan(d))
            errno = EDOM;
        else if (isinf(d))
            errno = ERANGE;
    }
#endif
    if ((errno == EDOM) | (errno == ERANGE)) {
        wputs(fname);
        if (errno == EDOM)
                wputs("(): domain error\n");
        else if (errno == ERANGE)
                wputs("(): range error\n");
        else
                wputs("(): error in call\n");
        return(0.0);
    }
    errno = lasterrno;
    return(d);
}


/*
 *  Library functions:
 */


static double
l_if(char *nm)          /* if(cond, then, else) conditional expression */
                        /* cond evaluates true if greater than zero */
{
    if (argument(1) > 0.0)
        return(argument(2));
    else
        return(argument(3));
}


static double
l_select(char *nm)      /* return argument #(A1+1) */
{
        int     narg = nargum();
        double  a1 = argument(1);
        int  n = (int)(a1 + .5);

        if ((a1 < -.5) | (n >= narg)) {
                errno = EDOM;
                return(0.0);
        }
        if (!n)         /* asking max index? */
                return(narg-1);
        return(argument(n+1));
}


static double
l_max(char *nm)         /* general maximum function */
{
        int  n = nargum();
        double  vmax = argument(1);

        while (n > 1) {
                double  v = argument(n--);
                if (vmax < v)
                        vmax = v;
        }
        return(vmax);
}


static double
l_min(char *nm)         /* general minimum function */
{
        int  n = nargum();
        double  vmin = argument(1);

        while (n > 1) {
                double  v = argument(n--);
                if (vmin > v)
                        vmin = v;
        }
        return(vmin);
}


static double
l_rand(char *nm)                /* random function between 0 and 1 */
{
    double  x;

    x = argument(1);
    x *= 1.0/(1.0 + x*x) + 2.71828182845904;
    x += .785398163397447 - floor(x);
    x = 1e5 / x;
    return(x - floor(x));
}


static double
l_floor(char *nm)               /* return largest integer not greater than arg1 */
{
    return(floor(argument(1)));
}


static double
l_ceil(char *nm)                /* return smallest integer not less than arg1 */
{
    return(ceil(argument(1)));
}


static double
l_sqrt(char *nm)
{
    return(sqrt(argument(1)));
}


static double
l_sin(char *nm)
{
    return(sin(argument(1)));
}


static double
l_cos(char *nm)
{
    return(cos(argument(1)));
}


static double
l_tan(char *nm)
{
    return(tan(argument(1)));
}


static double
l_asin(char *nm)
{
    return(asin(argument(1)));
}


static double
l_acos(char *nm)
{
    return(acos(argument(1)));
}


static double
l_atan(char *nm)
{
    return(atan(argument(1)));
}


static double
l_atan2(char *nm)
{
    return(atan2(argument(1), argument(2)));
}


static double
l_exp(char *nm)
{
    return(exp(argument(1)));
}


static double
l_log(char *nm)
{
    return(log(argument(1)));
}


static double
l_log10(char *nm)
{
    return(log10(argument(1)));
}
Revision:	2.35
Committed:	Wed Nov 19 18:34:37 2025 UTC (5 weeks, 4 days ago) by greg
Content type:	text/plain
Branch:	MAIN
CVS Tags:	HEAD
Changes since 2.34:	+4 -3 lines
Log Message:	refactor: Clarifying change in stack depth warning function
#	User	Rev	Content
1	greg	1.1	#ifndef lint
2	greg	2.35	static const char RCSid[] = "$Id: calfunc.c,v 2.34 2025/08/15 20:14:57 greg Exp $";
3	greg	1.1	#endif
4			/*
5			* calfunc.c - routines for calcomp using functions.
6			*
7	greg	2.8	* If VARIABLE is not set, only library functions
8			* can be accessed.
9			*
10			* 2/19/03 Eliminated conditional compiles in favor of esupport extern.
11			*/
12
13	greg	2.9	#include "copyright.h"
14	greg	1.1
15			#include <stdio.h>
16	schorsch	2.11	#include <string.h>
17	greg	1.1	#include <errno.h>
18	greg	2.30	#include <stdlib.h>
19	greg	2.5	#include <math.h>
20
21	schorsch	2.12	#include "rterror.h"
22	greg	1.1	#include "calcomp.h"
23
24	greg	1.5	/* bits in argument flag (better be right!) */
25			#define AFLAGSIZ (8*sizeof(unsigned long))
26	greg	2.29	#define ALISTSIZ 10 /* maximum saved argument list */
27	greg	1.1
28			typedef struct activation {
29			char name; / function name */
30			struct activation prev; / previous activation */
31			double ap; / argument list */
32			unsigned long an; /* computed argument flags */
33			EPNODE fun; / argument function */
34			} ACTIVATION; /* an activation record */
35
36			static ACTIVATION *curact = NULL;
37	greg	2.33	static unsigned long curdepth = 0, next_dreport = 100;
38	greg	1.1
39	schorsch	2.12	static double libfunc(char fname, VARDEF vp);
40	greg	2.33	static void report_depth(char *nm);
41	greg	1.1
42	greg	2.8	#ifndef MAXLIB
43	greg	1.1	#define MAXLIB 64 /* maximum number of library functions */
44	greg	2.8	#endif
45	greg	1.1
46	greg	2.21	static double l_if(char ), l_select(char );
47			static double l_min(char ), l_max(char );
48			static double l_rand(char *);
49	greg	2.13	static double l_floor(char ), l_ceil(char );
50			static double l_sqrt(char *);
51			static double l_sin(char ), l_cos(char ), l_tan(char *);
52			static double l_asin(char ), l_acos(char ), l_atan(char ), l_atan2(char );
53			static double l_exp(char ), l_log(char ), l_log10(char *);
54	greg	1.1
55			/* functions must be listed alphabetically */
56	greg	2.32	static ELIBR library[MAXLIB] = {
57	greg	1.4	{ "acos", 1, ':', l_acos },
58			{ "asin", 1, ':', l_asin },
59			{ "atan", 1, ':', l_atan },
60			{ "atan2", 2, ':', l_atan2 },
61			{ "ceil", 1, ':', l_ceil },
62			{ "cos", 1, ':', l_cos },
63			{ "exp", 1, ':', l_exp },
64			{ "floor", 1, ':', l_floor },
65			{ "if", 3, ':', l_if },
66			{ "log", 1, ':', l_log },
67			{ "log10", 1, ':', l_log10 },
68	greg	2.21	{ "max", 1, ':', l_max },
69			{ "min", 1, ':', l_min },
70	greg	1.4	{ "rand", 1, ':', l_rand },
71			{ "select", 1, ':', l_select },
72			{ "sin", 1, ':', l_sin },
73			{ "sqrt", 1, ':', l_sqrt },
74			{ "tan", 1, ':', l_tan },
75	greg	1.1	};
76
77	greg	2.22	static int libsize = 18;
78	greg	1.1
79	greg	2.32	#define resolve(ep) ((ep)->type==VAR?(ep)->v.ln:eargf((ep)->v.chan))
80	greg	1.1
81
82			int
83	greg	2.21	fundefined( /* return # of req'd arguments for function */
84	greg	2.16	char *fname
85			)
86	greg	1.1	{
87	greg	2.32	ELIBR *lp;
88	greg	2.16	VARDEF *vp;
89	greg	1.1
90	greg	2.7	if ((vp = varlookup(fname)) != NULL && vp->def != NULL
91			&& vp->def->v.kid->type == FUNC)
92	greg	1.1	return(nekids(vp->def->v.kid) - 1);
93	greg	2.32	lp = vp != NULL ? vp->lib : eliblookup(fname);
94	greg	2.7	if (lp == NULL)
95			return(0);
96			return(lp->nargs);
97	greg	1.1	}
98
99
100			double
101	greg	2.16	funvalue( /* return a function value to the user */
102			char *fname,
103			int n,
104			double *a
105			)
106	greg	1.1	{
107			ACTIVATION act;
108	greg	2.16	VARDEF *vp;
109	greg	1.1	double rval;
110			/* push environment */
111			act.name = fname;
112			act.prev = curact;
113			act.ap = a;
114	greg	2.19	if (n < AFLAGSIZ)
115			act.an = (1L<<n)-1;
116			else {
117	greg	1.5	act.an = ~0;
118	greg	2.19	if (n > AFLAGSIZ)
119			wputs("Excess arguments in funvalue()\n");
120			}
121	greg	1.1	act.fun = NULL;
122			curact = &act;
123	greg	2.33	if (++curdepth >= next_dreport)
124			report_depth(act.name);
125	greg	1.1
126			if ((vp = varlookup(fname)) == NULL \|\| vp->def == NULL
127			\|\| vp->def->v.kid->type != FUNC)
128			rval = libfunc(fname, vp);
129			else
130			rval = evalue(vp->def->v.kid->sibling);
131
132	greg	2.33	curact = act.prev; curdepth--; /* pop environment */
133	greg	1.1	return(rval);
134			}
135
136
137	greg	2.8	void
138	greg	2.16	funset( /* set a library function */
139			char *fname,
140			int nargs,
141			int assign,
142			double (fptr)(char )
143			)
144	greg	1.1	{
145	greg	2.6	int oldlibsize = libsize;
146	greg	2.8	char *cp;
147	greg	2.32	ELIBR *lp;
148	greg	2.8	/* check for context */
149			for (cp = fname; *cp; cp++)
150			;
151			if (cp == fname)
152			return;
153	greg	2.21	while (cp[-1] == CNTXMARK) {
154	greg	2.8	*--cp = '\0';
155	greg	2.21	if (cp == fname) return;
156			}
157	greg	2.32	if ((lp = eliblookup(fname)) == NULL) { /* insert */
158	greg	2.25	if (fptr == NULL)
159			return; /* nothing! */
160	greg	1.1	if (libsize >= MAXLIB) {
161			eputs("Too many library functons!\n");
162			quit(1);
163			}
164			for (lp = &library[libsize]; lp > library; lp--)
165	greg	2.17	if (strcmp(lp[-1].fname, fname) > 0)
166			lp[0] = lp[-1];
167			else
168	greg	1.1	break;
169			libsize++;
170			}
171	greg	2.2	if (fptr == NULL) { /* delete */
172			while (lp < &library[libsize-1]) {
173	greg	2.17	lp[0] = lp[1];
174	greg	2.2	lp++;
175			}
176			libsize--;
177			} else { /* or assign */
178			lp[0].fname = fname; /* string must be static! */
179			lp[0].nargs = nargs;
180			lp[0].atyp = assign;
181			lp[0].f = fptr;
182			}
183	greg	2.6	if (libsize != oldlibsize)
184	greg	2.32	elibupdate(fname); /* relink library */
185	greg	1.1	}
186
187
188			int
189	greg	2.16	nargum(void) /* return number of available arguments */
190	greg	1.1	{
191	greg	2.16	int n;
192	greg	1.1
193			if (curact == NULL)
194			return(0);
195			if (curact->fun == NULL) {
196			for (n = 0; (1L<<n) & curact->an; n++)
197			;
198			return(n);
199			}
200			return(nekids(curact->fun) - 1);
201			}
202
203
204			double
205	greg	2.16	argument(int n) /* return nth argument for active function */
206	greg	1.1	{
207	greg	2.16	ACTIVATION *actp = curact;
208	greg	2.30	EPNODE *ep;
209	greg	1.1	double aval;
210
211	greg	2.19	if (!actp \| (--n < 0)) {
212	greg	1.1	eputs("Bad call to argument!\n");
213			quit(1);
214			}
215	greg	2.20	if ((n < AFLAGSIZ) & actp->an >> n) /* already computed? */
216	greg	1.1	return(actp->ap[n]);
217
218	greg	2.19	if (!actp->fun \|\| !(ep = ekid(actp->fun, n+1))) {
219	greg	1.1	eputs(actp->name);
220	greg	2.33	eputs("(): too few arguments\n");
221	greg	1.1	quit(1);
222			}
223	greg	2.33	curact = actp->prev; curdepth--; /* previous context */
224	greg	1.1	aval = evalue(ep); /* compute argument */
225	greg	2.33	curact = actp; curdepth++; /* put back calling context */
226	greg	2.20	if (n < ALISTSIZ) { /* save value if room */
227	greg	1.1	actp->ap[n] = aval;
228			actp->an \|= 1L<<n;
229			}
230			return(aval);
231			}
232
233
234			VARDEF *
235	greg	2.32	eargf(int n) /* return function def for nth argument */
236	greg	1.1	{
237	greg	2.16	ACTIVATION *actp;
238			EPNODE *ep;
239	greg	1.1
240			for (actp = curact; actp != NULL; actp = actp->prev) {
241
242			if (n <= 0)
243			break;
244
245			if (actp->fun == NULL)
246			goto badarg;
247
248			if ((ep = ekid(actp->fun, n)) == NULL) {
249			eputs(actp->name);
250	greg	2.33	eputs("(): too few arguments\n");
251	greg	1.1	quit(1);
252			}
253			if (ep->type == VAR)
254			return(ep->v.ln); /* found it */
255
256			if (ep->type != ARG)
257			goto badarg;
258
259			n = ep->v.chan; /* try previous context */
260			}
261	greg	2.32	eputs("Bad call to eargf!\n");
262	greg	1.1	quit(1);
263
264			badarg:
265			eputs(actp->name);
266	greg	2.33	eputs("(): argument not a function\n");
267	greg	1.1	quit(1);
268	schorsch	2.11	return NULL; /* pro forma return */
269	greg	1.1	}
270
271
272			char *
273	greg	2.32	eargfun(int n) /* return function name for nth argument */
274	greg	1.1	{
275	greg	2.32	return(eargf(n)->name);
276	greg	1.1	}
277
278
279			double
280	greg	2.16	efunc(EPNODE ep) / evaluate a function */
281	greg	1.1	{
282			ACTIVATION act;
283			double alist[ALISTSIZ];
284			double rval;
285	greg	2.16	VARDEF *dp;
286	greg	1.1	/* push environment */
287			dp = resolve(ep->v.kid);
288			act.name = dp->name;
289			act.prev = curact;
290			act.ap = alist;
291			act.an = 0;
292			act.fun = ep;
293			curact = &act;
294	greg	2.33	if (++curdepth >= next_dreport)
295			report_depth(act.name);
296	greg	1.1
297			if (dp->def == NULL \|\| dp->def->v.kid->type != FUNC)
298			rval = libfunc(act.name, dp);
299			else
300			rval = evalue(dp->def->v.kid->sibling);
301
302	greg	2.33	curact = act.prev; curdepth--; /* pop environment */
303	greg	1.1	return(rval);
304			}
305
306
307	greg	2.30	double
308			eargument( /* evaluate an argument */
309			EPNODE *ep
310			)
311			{
312	greg	2.31	if ((ep->v.chan <= AFLAGSIZ) & curact->an >> (ep->v.chan-1))
313			return(curact->ap[ep->v.chan-1]);
314	greg	2.30
315			return(argument(ep->v.chan));
316			}
317
318
319	greg	2.32	ELIBR *
320			eliblookup(char fname) / look up a library function */
321	greg	1.1	{
322			int upper, lower;
323	greg	2.16	int cm, i;
324	greg	1.1
325			lower = 0;
326			upper = cm = libsize;
327
328			while ((i = (lower + upper) >> 1) != cm) {
329			cm = strcmp(fname, library[i].fname);
330			if (cm > 0)
331			lower = i;
332			else if (cm < 0)
333			upper = i;
334			else
335			return(&library[i]);
336			cm = i;
337			}
338			return(NULL);
339			}
340
341
342			/*
343			* The following routines are for internal use:
344			*/
345
346
347	greg	2.33	static void
348			report_depth(char nm) / report current function call depth */
349			{
350	greg	2.34	char msg[RMAXWORD+48];
351	greg	2.33
352	greg	2.35	sprintf(msg, "%s(): depth level at %lu\n", nm, curdepth);
353	greg	2.33	wputs(msg);
354	greg	2.35	if (curdepth >= next_dreport)
355			next_dreport *= 10;
356	greg	2.33	}
357
358
359	greg	1.1	static double
360	greg	2.16	libfunc( /* execute library function */
361			char *fname,
362			VARDEF *vp
363			)
364	greg	1.1	{
365	greg	2.32	ELIBR *lp;
366	greg	1.1	double d;
367			int lasterrno;
368
369	greg	2.3	if (vp != NULL)
370			lp = vp->lib;
371			else
372	greg	2.32	lp = eliblookup(fname);
373	greg	2.3	if (lp == NULL) {
374	greg	1.1	eputs(fname);
375	greg	2.33	eputs("(): undefined function\n");
376	greg	1.1	quit(1);
377			}
378			lasterrno = errno;
379			errno = 0;
380	greg	2.3	d = (*lp->f)(lp->fname);
381	greg	2.15	#ifdef isnan
382	greg	2.18	if (errno == 0) {
383	greg	1.9	if (isnan(d))
384			errno = EDOM;
385			else if (isinf(d))
386			errno = ERANGE;
387	greg	2.18	}
388	greg	1.1	#endif
389	greg	2.28	if ((errno == EDOM) \| (errno == ERANGE)) {
390	greg	1.1	wputs(fname);
391	greg	1.8	if (errno == EDOM)
392	greg	2.33	wputs("(): domain error\n");
393	greg	1.8	else if (errno == ERANGE)
394	greg	2.33	wputs("(): range error\n");
395	greg	1.8	else
396	greg	2.33	wputs("(): error in call\n");
397	greg	1.1	return(0.0);
398			}
399			errno = lasterrno;
400			return(d);
401			}
402
403
404			/*
405			* Library functions:
406			*/
407
408
409			static double
410	greg	2.13	l_if(char nm) / if(cond, then, else) conditional expression */
411	greg	1.1	/* cond evaluates true if greater than zero */
412			{
413			if (argument(1) > 0.0)
414			return(argument(2));
415			else
416			return(argument(3));
417			}
418
419
420			static double
421	greg	2.13	l_select(char nm) / return argument #(A1+1) */
422	greg	1.1	{
423	greg	2.23	int narg = nargum();
424			double a1 = argument(1);
425			int n = (int)(a1 + .5);
426	greg	1.1
427	greg	2.28	if ((a1 < -.5) \| (n >= narg)) {
428	greg	1.1	errno = EDOM;
429			return(0.0);
430			}
431	greg	2.23	if (!n) /* asking max index? */
432			return(narg-1);
433	greg	1.1	return(argument(n+1));
434			}
435
436
437			static double
438	greg	2.21	l_max(char nm) / general maximum function */
439			{
440			int n = nargum();
441	greg	2.24	double vmax = argument(1);
442	greg	2.21
443	greg	2.27	while (n > 1) {
444			double v = argument(n--);
445	greg	2.21	if (vmax < v)
446			vmax = v;
447			}
448			return(vmax);
449			}
450
451
452			static double
453			l_min(char nm) / general minimum function */
454			{
455			int n = nargum();
456	greg	2.24	double vmin = argument(1);
457	greg	2.21
458	greg	2.27	while (n > 1) {
459			double v = argument(n--);
460	greg	2.21	if (vmin > v)
461			vmin = v;
462			}
463			return(vmin);
464			}
465
466
467			static double
468	greg	2.13	l_rand(char nm) / random function between 0 and 1 */
469	greg	1.1	{
470			double x;
471
472			x = argument(1);
473			x = 1.0/(1.0 + xx) + 2.71828182845904;
474			x += .785398163397447 - floor(x);
475			x = 1e5 / x;
476			return(x - floor(x));
477			}
478
479
480			static double
481	greg	2.13	l_floor(char nm) / return largest integer not greater than arg1 */
482	greg	1.1	{
483			return(floor(argument(1)));
484			}
485
486
487			static double
488	greg	2.13	l_ceil(char nm) / return smallest integer not less than arg1 */
489	greg	1.1	{
490			return(ceil(argument(1)));
491			}
492
493
494			static double
495	greg	2.13	l_sqrt(char *nm)
496	greg	1.1	{
497			return(sqrt(argument(1)));
498			}
499
500
501			static double
502	greg	2.13	l_sin(char *nm)
503	greg	1.1	{
504			return(sin(argument(1)));
505			}
506
507
508			static double
509	greg	2.13	l_cos(char *nm)
510	greg	1.1	{
511			return(cos(argument(1)));
512			}
513
514
515			static double
516	greg	2.13	l_tan(char *nm)
517	greg	1.1	{
518			return(tan(argument(1)));
519			}
520
521
522			static double
523	greg	2.13	l_asin(char *nm)
524	greg	1.1	{
525			return(asin(argument(1)));
526			}
527
528
529			static double
530	greg	2.13	l_acos(char *nm)
531	greg	1.1	{
532			return(acos(argument(1)));
533			}
534
535
536			static double
537	greg	2.13	l_atan(char *nm)
538	greg	1.1	{
539			return(atan(argument(1)));
540			}
541
542
543			static double
544	greg	2.13	l_atan2(char *nm)
545	greg	1.1	{
546			return(atan2(argument(1), argument(2)));
547			}
548
549
550			static double
551	greg	2.13	l_exp(char *nm)
552	greg	1.1	{
553			return(exp(argument(1)));
554			}
555
556
557			static double
558	greg	2.13	l_log(char *nm)
559	greg	1.1	{
560			return(log(argument(1)));
561			}
562
563
564			static double
565	greg	2.13	l_log10(char *nm)
566	greg	1.1	{
567			return(log10(argument(1)));
568			}