src/common/calfunc.c

/* Copyright (c) 1992 Regents of the University of California */

#ifndef lint
static char SCCSid[] = "$SunId$ LBL";
#endif

/*
 *  calfunc.c - routines for calcomp using functions.
 *
 *      The define BIGLIB pulls in a large number of the
 *  available math routines.
 *
 *      If VARIABLE is not defined, only library functions
 *  can be accessed.
 *
 *     4/2/86
 */

#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();

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

static double  l_if(), l_select(), l_rand();
static double  l_floor(), l_ceil();
#ifdef  BIGLIB
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();
#endif

#ifdef  BIGLIB
                        /* 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;

#else
                        /* functions must be listed alphabetically */
static LIBR  library[MAXLIB] = {
    { "ceil", 1, ':', l_ceil },
    { "floor", 1, ':', l_floor },
    { "if", 3, ':', l_if },
    { "rand", 1, ':', l_rand },
    { "select", 1, ':', l_select },
};

static int  libsize = 5;

#endif

extern char  *savestr(), *emalloc();

extern VARDEF  *argf();

#ifdef  VARIABLE
#define  resolve(ep)    ((ep)->type==VAR?(ep)->v.ln:argf((ep)->v.chan))
#else
#define  resolve(ep)    ((ep)->v.ln)
#define varlookup(name) NULL
#endif


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


funset(fname, nargs, assign, fptr)      /* set a library function */
char  *fname;
int  nargs;
int  assign;
double  (*fptr)();
{
    int  oldlibsize = libsize;
    register LIBR  *lp;

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


#ifdef  VARIABLE
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);
}
#endif


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


#ifndef  VARIABLE
static VARDEF  *varlist = NULL;         /* our list of dummy variables */


VARDEF *
varinsert(vname)                /* dummy variable insert */
char  *vname;
{
    register VARDEF  *vp;

    vp = (VARDEF *)emalloc(sizeof(VARDEF));
    vp->name = savestr(vname);
    vp->nlinks = 1;
    vp->def = NULL;
    vp->lib = liblookup(vname);
    vp->next = varlist;
    varlist = vp;
    return(vp);
}


varfree(vp)                     /* free dummy variable */
register VARDEF  *vp;
{
    register VARDEF  *vp2;

    if (vp == varlist)
        varlist = vp->next;
    else {
        for (vp2 = varlist; vp2->next != vp; vp2 = vp2->next)
                ;
        vp2->next = vp->next;
    }
    freestr(vp->name);
    efree((char *)vp);
}


libupdate(nm)                   /* update library */
char  *nm;
{
    register VARDEF  *vp;

    for (vp = varlist; vp != NULL; vp = vp->next)
        vp->lib = liblookup(vp->name);
}
#endif


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


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