src/common/calfunc.c

#ifndef lint
static const char       RCSid[] = "$Id$";
#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.
 */

/* ====================================================================
 * The Radiance Software License, Version 1.0
 *
 * Copyright (c) 1990 - 2002 The Regents of the University of California,
 * through Lawrence Berkeley National Laboratory.   All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1. Redistributions of source code must retain the above copyright
 *         notice, this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright
 *       notice, this list of conditions and the following disclaimer in
 *       the documentation and/or other materials provided with the
 *       distribution.
 *
 * 3. The end-user documentation included with the redistribution,
 *           if any, must include the following acknowledgment:
 *             "This product includes Radiance software
 *                 (http://radsite.lbl.gov/)
 *                 developed by the Lawrence Berkeley National Laboratory
 *               (http://www.lbl.gov/)."
 *       Alternately, this acknowledgment may appear in the software itself,
 *       if and wherever such third-party acknowledgments normally appear.
 *
 * 4. The names "Radiance," "Lawrence Berkeley National Laboratory"
 *       and "The Regents of the University of California" must
 *       not be used to endorse or promote products derived from this
 *       software without prior written permission. For written
 *       permission, please contact [email protected].
 *
 * 5. Products derived from this software may not be called "Radiance",
 *       nor may "Radiance" appear in their name, without prior written
 *       permission of Lawrence Berkeley National Laboratory.
 *
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
 * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED.   IN NO EVENT SHALL Lawrence Berkeley National Laboratory OR
 * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
 * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
 * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
 * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 * ====================================================================
 *
 * This software consists of voluntary contributions made by many
 * individuals on behalf of Lawrence Berkeley National Laboratory.   For more
 * information on Lawrence Berkeley National Laboratory, please see
 * <http://www.lbl.gov/>.
 */

#include  <stdio.h>

#include  <errno.h>

#include  <math.h>

#include  "calcomp.h"

                                /* bits in argument flag (better be right!) */
#define  AFLAGSIZ       (8*sizeof(unsigned long))
#define  ALISTSIZ       6       /* 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 double  libfunc();

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

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

                        /* functions must be listed alphabetically */
static LIBR  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 },
    { "rand", 1, ':', l_rand },
    { "select", 1, ':', l_select },
    { "sin", 1, ':', l_sin },
    { "sqrt", 1, ':', l_sqrt },
    { "tan", 1, ':', l_tan },
};

static int  libsize = 16;

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


int
fundefined(fname)               /* return # of arguments for function */
char  *fname;
{
    register LIBR  *lp;
    register 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 : liblookup(fname);
    if (lp == NULL)
        return(0);
    return(lp->nargs);
}


double
funvalue(fname, n, a)           /* return a function value to the user */
char  *fname;
int  n;
double  *a;
{
    ACTIVATION  act;
    register VARDEF  *vp;
    double  rval;
                                        /* push environment */
    act.name = fname;
    act.prev = curact;
    act.ap = a;
    if (n >= AFLAGSIZ)
        act.an = ~0;
    else
        act.an = (1L<<n)-1;
    act.fun = NULL;
    curact = &act;

    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;                  /* pop environment */
    return(rval);
}


void
funset(fname, nargs, assign, fptr)      /* set a library function */
char  *fname;
int  nargs;
int  assign;
double  (*fptr)();
{
    int  oldlibsize = libsize;
    char *cp;
    register LIBR  *lp;
                                                /* check for context */
    for (cp = fname; *cp; cp++)
        ;
    if (cp == fname)
        return;
    if (cp[-1] == CNTXMARK)
        *--cp = '\0';
    if ((lp = liblookup(fname)) == NULL) {      /* insert */
        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].fname = lp[-1].fname;
                lp[0].nargs = lp[-1].nargs;
                lp[0].atyp = lp[-1].atyp;
                lp[0].f = lp[-1].f;
            } else
                break;
        libsize++;
    }
    if (fptr == NULL) {                         /* delete */
        while (lp < &library[libsize-1]) {
            lp[0].fname = lp[1].fname;
            lp[0].nargs = lp[1].nargs;
            lp[0].atyp = lp[1].atyp;
            lp[0].f = lp[1].f;
            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)
        libupdate(fname);                       /* relink library */
}


int
nargum()                        /* return number of available arguments */
{
    register 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(n)                     /* return nth argument for active function */
register int  n;
{
    register ACTIVATION  *actp = curact;
    register EPNODE  *ep;
    double  aval;

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

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


VARDEF *
argf(n)                         /* return function def for nth argument */
int  n;
{
    register ACTIVATION  *actp;
    register 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 argf!\n");
    quit(1);

badarg:
    eputs(actp->name);
    eputs(": argument not a function\n");
    quit(1);
}


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


double
efunc(ep)                               /* evaluate a function */
register EPNODE  *ep;
{
    ACTIVATION  act;
    double  alist[ALISTSIZ];
    double  rval;
    register 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 (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;                  /* pop environment */
    return(rval);
}


LIBR *
liblookup(fname)                /* look up a library function */
char  *fname;
{
    int  upper, lower;
    register 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 double
libfunc(fname, vp)                      /* execute library function */
char  *fname;
VARDEF  *vp;
{
    register LIBR  *lp;
    double  d;
    int  lasterrno;

    if (vp != NULL)
        lp = vp->lib;
    else
        lp = liblookup(fname);
    if (lp == NULL) {
        eputs(fname);
        eputs(": undefined function\n");
        quit(1);
    }
    lasterrno = errno;
    errno = 0;
    d = (*lp->f)(lp->fname);
#ifdef  IEEE
    if (errno == 0)
        if (isnan(d))
            errno = EDOM;
        else if (isinf(d))
            errno = ERANGE;
#endif
    if (errno) {
        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()                  /* 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()              /* return argument #(A1+1) */
{
        register int  n;

        n = argument(1) + .5;
        if (n == 0)
                return(nargum()-1);
        if (n < 1 || n > nargum()-1) {
                errno = EDOM;
                return(0.0);
        }
        return(argument(n+1));
}


static double
l_rand()                /* 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()               /* return largest integer not greater than arg1 */
{
    return(floor(argument(1)));
}


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


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


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


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


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


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


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


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


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


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


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


static double
l_log10()
{
    return(log10(argument(1)));
}
Revision:	2.8
Committed:	Sat Feb 22 02:07:21 2003 UTC (21 years, 2 months ago) by greg
Content type:	text/plain
Branch:	MAIN
Changes since 2.7:	+71 -90 lines
Log Message:	Changes and check-in for 3.5 release Includes new source files and modifications not recorded for many years See ray/doc/notes/ReleaseNotes for notes between 3.1 and 3.5 release
#	User	Rev	Content
1	greg	1.1	#ifndef lint
2	greg	2.8	static const char RCSid[] = "$Id$";
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			/* ====================================================================
14			* The Radiance Software License, Version 1.0
15			*
16			* Copyright (c) 1990 - 2002 The Regents of the University of California,
17			* through Lawrence Berkeley National Laboratory. All rights reserved.
18	greg	1.1	*
19	greg	2.8	* Redistribution and use in source and binary forms, with or without
20			* modification, are permitted provided that the following conditions
21			* are met:
22			*
23			* 1. Redistributions of source code must retain the above copyright
24			* notice, this list of conditions and the following disclaimer.
25			*
26			* 2. Redistributions in binary form must reproduce the above copyright
27			* notice, this list of conditions and the following disclaimer in
28			* the documentation and/or other materials provided with the
29			* distribution.
30			*
31			* 3. The end-user documentation included with the redistribution,
32			* if any, must include the following acknowledgment:
33			* "This product includes Radiance software
34			* (http://radsite.lbl.gov/)
35			* developed by the Lawrence Berkeley National Laboratory
36			* (http://www.lbl.gov/)."
37			* Alternately, this acknowledgment may appear in the software itself,
38			* if and wherever such third-party acknowledgments normally appear.
39			*
40			* 4. The names "Radiance," "Lawrence Berkeley National Laboratory"
41			* and "The Regents of the University of California" must
42			* not be used to endorse or promote products derived from this
43			* software without prior written permission. For written
44			* permission, please contact [email protected].
45			*
46			* 5. Products derived from this software may not be called "Radiance",
47			* nor may "Radiance" appear in their name, without prior written
48			* permission of Lawrence Berkeley National Laboratory.
49			*
50			* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
51			* WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
52			* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
53			* DISCLAIMED. IN NO EVENT SHALL Lawrence Berkeley National Laboratory OR
54			* ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
55			* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
56			* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
57			* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
58			* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
59			* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
60			* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
61			* SUCH DAMAGE.
62			* ====================================================================
63	greg	1.1	*
64	greg	2.8	* This software consists of voluntary contributions made by many
65			* individuals on behalf of Lawrence Berkeley National Laboratory. For more
66			* information on Lawrence Berkeley National Laboratory, please see
67			* <http://www.lbl.gov/>.
68	greg	1.1	*/
69
70			#include <stdio.h>
71
72			#include <errno.h>
73
74	greg	2.5	#include <math.h>
75
76	greg	1.1	#include "calcomp.h"
77
78	greg	1.5	/* bits in argument flag (better be right!) */
79			#define AFLAGSIZ (8*sizeof(unsigned long))
80	greg	1.1	#define ALISTSIZ 6 /* maximum saved argument list */
81
82			typedef struct activation {
83			char name; / function name */
84			struct activation prev; / previous activation */
85			double ap; / argument list */
86			unsigned long an; /* computed argument flags */
87			EPNODE fun; / argument function */
88			} ACTIVATION; /* an activation record */
89
90			static ACTIVATION *curact = NULL;
91
92	greg	1.2	static double libfunc();
93	greg	1.1
94	greg	2.8	#ifndef MAXLIB
95	greg	1.1	#define MAXLIB 64 /* maximum number of library functions */
96	greg	2.8	#endif
97	greg	1.1
98	greg	1.2	static double l_if(), l_select(), l_rand();
99			static double l_floor(), l_ceil();
100			static double l_sqrt();
101			static double l_sin(), l_cos(), l_tan();
102			static double l_asin(), l_acos(), l_atan(), l_atan2();
103			static double l_exp(), l_log(), l_log10();
104	greg	1.1
105			/* functions must be listed alphabetically */
106			static LIBR library[MAXLIB] = {
107	greg	1.4	{ "acos", 1, ':', l_acos },
108			{ "asin", 1, ':', l_asin },
109			{ "atan", 1, ':', l_atan },
110			{ "atan2", 2, ':', l_atan2 },
111			{ "ceil", 1, ':', l_ceil },
112			{ "cos", 1, ':', l_cos },
113			{ "exp", 1, ':', l_exp },
114			{ "floor", 1, ':', l_floor },
115			{ "if", 3, ':', l_if },
116			{ "log", 1, ':', l_log },
117			{ "log10", 1, ':', l_log10 },
118			{ "rand", 1, ':', l_rand },
119			{ "select", 1, ':', l_select },
120			{ "sin", 1, ':', l_sin },
121			{ "sqrt", 1, ':', l_sqrt },
122			{ "tan", 1, ':', l_tan },
123	greg	1.1	};
124
125			static int libsize = 16;
126
127			#define resolve(ep) ((ep)->type==VAR?(ep)->v.ln:argf((ep)->v.chan))
128
129
130			int
131			fundefined(fname) /* return # of arguments for function */
132			char *fname;
133			{
134	greg	2.7	register LIBR *lp;
135	greg	1.1	register VARDEF *vp;
136
137	greg	2.7	if ((vp = varlookup(fname)) != NULL && vp->def != NULL
138			&& vp->def->v.kid->type == FUNC)
139	greg	1.1	return(nekids(vp->def->v.kid) - 1);
140	greg	2.7	lp = vp != NULL ? vp->lib : liblookup(fname);
141			if (lp == NULL)
142			return(0);
143			return(lp->nargs);
144	greg	1.1	}
145
146
147			double
148			funvalue(fname, n, a) /* return a function value to the user */
149			char *fname;
150			int n;
151			double *a;
152			{
153			ACTIVATION act;
154			register VARDEF *vp;
155			double rval;
156			/* push environment */
157			act.name = fname;
158			act.prev = curact;
159			act.ap = a;
160	greg	1.5	if (n >= AFLAGSIZ)
161			act.an = ~0;
162			else
163			act.an = (1L<<n)-1;
164	greg	1.1	act.fun = NULL;
165			curact = &act;
166
167			if ((vp = varlookup(fname)) == NULL \|\| vp->def == NULL
168			\|\| vp->def->v.kid->type != FUNC)
169			rval = libfunc(fname, vp);
170			else
171			rval = evalue(vp->def->v.kid->sibling);
172
173			curact = act.prev; /* pop environment */
174			return(rval);
175			}
176
177
178	greg	2.8	void
179	greg	1.4	funset(fname, nargs, assign, fptr) /* set a library function */
180	greg	1.1	char *fname;
181			int nargs;
182	greg	1.4	int assign;
183	greg	1.1	double (*fptr)();
184			{
185	greg	2.6	int oldlibsize = libsize;
186	greg	2.8	char *cp;
187	greg	1.1	register LIBR *lp;
188	greg	2.8	/* check for context */
189			for (cp = fname; *cp; cp++)
190			;
191			if (cp == fname)
192			return;
193			if (cp[-1] == CNTXMARK)
194			*--cp = '\0';
195	greg	2.2	if ((lp = liblookup(fname)) == NULL) { /* insert */
196	greg	1.1	if (libsize >= MAXLIB) {
197			eputs("Too many library functons!\n");
198			quit(1);
199			}
200			for (lp = &library[libsize]; lp > library; lp--)
201			if (strcmp(lp[-1].fname, fname) > 0) {
202			lp[0].fname = lp[-1].fname;
203			lp[0].nargs = lp[-1].nargs;
204	greg	1.4	lp[0].atyp = lp[-1].atyp;
205	greg	1.1	lp[0].f = lp[-1].f;
206			} else
207			break;
208			libsize++;
209			}
210	greg	2.2	if (fptr == NULL) { /* delete */
211			while (lp < &library[libsize-1]) {
212			lp[0].fname = lp[1].fname;
213			lp[0].nargs = lp[1].nargs;
214			lp[0].atyp = lp[1].atyp;
215			lp[0].f = lp[1].f;
216			lp++;
217			}
218			libsize--;
219			} else { /* or assign */
220			lp[0].fname = fname; /* string must be static! */
221			lp[0].nargs = nargs;
222			lp[0].atyp = assign;
223			lp[0].f = fptr;
224			}
225	greg	2.6	if (libsize != oldlibsize)
226			libupdate(fname); /* relink library */
227	greg	1.1	}
228
229
230			int
231			nargum() /* return number of available arguments */
232			{
233			register int n;
234
235			if (curact == NULL)
236			return(0);
237			if (curact->fun == NULL) {
238			for (n = 0; (1L<<n) & curact->an; n++)
239			;
240			return(n);
241			}
242			return(nekids(curact->fun) - 1);
243			}
244
245
246			double
247			argument(n) /* return nth argument for active function */
248			register int n;
249			{
250			register ACTIVATION *actp = curact;
251	greg	1.7	register EPNODE *ep;
252	greg	1.1	double aval;
253
254			if (actp == NULL \|\| --n < 0) {
255			eputs("Bad call to argument!\n");
256			quit(1);
257			}
258			/* already computed? */
259	greg	1.5	if (n < AFLAGSIZ && 1L<<n & actp->an)
260	greg	1.1	return(actp->ap[n]);
261
262			if (actp->fun == NULL \|\| (ep = ekid(actp->fun, n+1)) == NULL) {
263			eputs(actp->name);
264			eputs(": too few arguments\n");
265			quit(1);
266			}
267			curact = actp->prev; /* pop environment */
268			aval = evalue(ep); /* compute argument */
269			curact = actp; /* push back environment */
270			if (n < ALISTSIZ) { /* save value */
271			actp->ap[n] = aval;
272			actp->an \|= 1L<<n;
273			}
274			return(aval);
275			}
276
277
278			VARDEF *
279			argf(n) /* return function def for nth argument */
280			int n;
281			{
282			register ACTIVATION *actp;
283			register EPNODE *ep;
284
285			for (actp = curact; actp != NULL; actp = actp->prev) {
286
287			if (n <= 0)
288			break;
289
290			if (actp->fun == NULL)
291			goto badarg;
292
293			if ((ep = ekid(actp->fun, n)) == NULL) {
294			eputs(actp->name);
295			eputs(": too few arguments\n");
296			quit(1);
297			}
298			if (ep->type == VAR)
299			return(ep->v.ln); /* found it */
300
301			if (ep->type != ARG)
302			goto badarg;
303
304			n = ep->v.chan; /* try previous context */
305			}
306			eputs("Bad call to argf!\n");
307			quit(1);
308
309			badarg:
310			eputs(actp->name);
311			eputs(": argument not a function\n");
312			quit(1);
313			}
314
315
316			char *
317			argfun(n) /* return function name for nth argument */
318			int n;
319			{
320			return(argf(n)->name);
321			}
322
323
324			double
325			efunc(ep) /* evaluate a function */
326			register EPNODE *ep;
327			{
328			ACTIVATION act;
329			double alist[ALISTSIZ];
330			double rval;
331			register VARDEF *dp;
332			/* push environment */
333			dp = resolve(ep->v.kid);
334			act.name = dp->name;
335			act.prev = curact;
336			act.ap = alist;
337			act.an = 0;
338			act.fun = ep;
339			curact = &act;
340
341			if (dp->def == NULL \|\| dp->def->v.kid->type != FUNC)
342			rval = libfunc(act.name, dp);
343			else
344			rval = evalue(dp->def->v.kid->sibling);
345
346			curact = act.prev; /* pop environment */
347			return(rval);
348			}
349
350
351			LIBR *
352			liblookup(fname) /* look up a library function */
353			char *fname;
354			{
355			int upper, lower;
356			register int cm, i;
357
358			lower = 0;
359			upper = cm = libsize;
360
361			while ((i = (lower + upper) >> 1) != cm) {
362			cm = strcmp(fname, library[i].fname);
363			if (cm > 0)
364			lower = i;
365			else if (cm < 0)
366			upper = i;
367			else
368			return(&library[i]);
369			cm = i;
370			}
371			return(NULL);
372			}
373
374
375			/*
376			* The following routines are for internal use:
377			*/
378
379
380			static double
381			libfunc(fname, vp) /* execute library function */
382			char *fname;
383	greg	2.3	VARDEF *vp;
384	greg	1.1	{
385	greg	2.3	register LIBR *lp;
386	greg	1.1	double d;
387			int lasterrno;
388
389	greg	2.3	if (vp != NULL)
390			lp = vp->lib;
391			else
392			lp = liblookup(fname);
393			if (lp == NULL) {
394	greg	1.1	eputs(fname);
395			eputs(": undefined function\n");
396			quit(1);
397			}
398			lasterrno = errno;
399			errno = 0;
400	greg	2.3	d = (*lp->f)(lp->fname);
401	greg	1.1	#ifdef IEEE
402	greg	1.9	if (errno == 0)
403			if (isnan(d))
404			errno = EDOM;
405			else if (isinf(d))
406			errno = ERANGE;
407	greg	1.1	#endif
408			if (errno) {
409			wputs(fname);
410	greg	1.8	if (errno == EDOM)
411			wputs(": domain error\n");
412			else if (errno == ERANGE)
413			wputs(": range error\n");
414			else
415			wputs(": error in call\n");
416	greg	1.1	return(0.0);
417			}
418			errno = lasterrno;
419			return(d);
420			}
421
422
423			/*
424			* Library functions:
425			*/
426
427
428			static double
429			l_if() /* if(cond, then, else) conditional expression */
430			/* cond evaluates true if greater than zero */
431			{
432			if (argument(1) > 0.0)
433			return(argument(2));
434			else
435			return(argument(3));
436			}
437
438
439			static double
440			l_select() /* return argument #(A1+1) */
441			{
442			register int n;
443
444			n = argument(1) + .5;
445			if (n == 0)
446			return(nargum()-1);
447			if (n < 1 \|\| n > nargum()-1) {
448			errno = EDOM;
449			return(0.0);
450			}
451			return(argument(n+1));
452			}
453
454
455			static double
456			l_rand() /* random function between 0 and 1 */
457			{
458			double x;
459
460			x = argument(1);
461			x = 1.0/(1.0 + xx) + 2.71828182845904;
462			x += .785398163397447 - floor(x);
463			x = 1e5 / x;
464			return(x - floor(x));
465			}
466
467
468			static double
469			l_floor() /* return largest integer not greater than arg1 */
470			{
471			return(floor(argument(1)));
472			}
473
474
475			static double
476			l_ceil() /* return smallest integer not less than arg1 */
477			{
478			return(ceil(argument(1)));
479			}
480
481
482			static double
483			l_sqrt()
484			{
485			return(sqrt(argument(1)));
486			}
487
488
489			static double
490			l_sin()
491			{
492			return(sin(argument(1)));
493			}
494
495
496			static double
497			l_cos()
498			{
499			return(cos(argument(1)));
500			}
501
502
503			static double
504			l_tan()
505			{
506			return(tan(argument(1)));
507			}
508
509
510			static double
511			l_asin()
512			{
513			return(asin(argument(1)));
514			}
515
516
517			static double
518			l_acos()
519			{
520			return(acos(argument(1)));
521			}
522
523
524			static double
525			l_atan()
526			{
527			return(atan(argument(1)));
528			}
529
530
531			static double
532			l_atan2()
533			{
534			return(atan2(argument(1), argument(2)));
535			}
536
537
538			static double
539			l_exp()
540			{
541			return(exp(argument(1)));
542			}
543
544
545			static double
546			l_log()
547			{
548			return(log(argument(1)));
549			}
550
551
552			static double
553			l_log10()
554			{
555			return(log10(argument(1)));
556			}