Back to index

radiance  4R0+20100331
calfunc.c
Go to the documentation of this file.
00001 #ifndef lint
00002 static const char    RCSid[] = "$Id: calfunc.c,v 2.15 2006/05/10 15:21:20 greg Exp $";
00003 #endif
00004 /*
00005  *  calfunc.c - routines for calcomp using functions.
00006  *
00007  *      If VARIABLE is not set, only library functions
00008  *  can be accessed.
00009  *
00010  *  2/19/03   Eliminated conditional compiles in favor of esupport extern.
00011  */
00012 
00013 #include "copyright.h"
00014 
00015 #include  <stdio.h>
00016 #include  <string.h>
00017 #include  <errno.h>
00018 #include  <math.h>
00019 
00020 #include  "rterror.h"
00021 #include  "calcomp.h"
00022 
00023                             /* bits in argument flag (better be right!) */
00024 #define  AFLAGSIZ    (8*sizeof(unsigned long))
00025 #define  ALISTSIZ    6      /* maximum saved argument list */
00026 
00027 typedef struct activation {
00028     char  *name;            /* function name */
00029     struct activation  *prev;      /* previous activation */
00030     double  *ap;            /* argument list */
00031     unsigned long  an;             /* computed argument flags */
00032     EPNODE  *fun;           /* argument function */
00033 }  ACTIVATION;              /* an activation record */
00034 
00035 static ACTIVATION  *curact = NULL;
00036 
00037 static double  libfunc(char *fname, VARDEF *vp);
00038 
00039 #ifndef  MAXLIB
00040 #define  MAXLIB             64     /* maximum number of library functions */
00041 #endif
00042 
00043 static double  l_if(char *), l_select(char *), l_rand(char *);
00044 static double  l_floor(char *), l_ceil(char *);
00045 static double  l_sqrt(char *);
00046 static double  l_sin(char *), l_cos(char *), l_tan(char *);
00047 static double  l_asin(char *), l_acos(char *), l_atan(char *), l_atan2(char *);
00048 static double  l_exp(char *), l_log(char *), l_log10(char *);
00049 
00050                      /* functions must be listed alphabetically */
00051 static LIBR  library[MAXLIB] = {
00052     { "acos", 1, ':', l_acos },
00053     { "asin", 1, ':', l_asin },
00054     { "atan", 1, ':', l_atan },
00055     { "atan2", 2, ':', l_atan2 },
00056     { "ceil", 1, ':', l_ceil },
00057     { "cos", 1, ':', l_cos },
00058     { "exp", 1, ':', l_exp },
00059     { "floor", 1, ':', l_floor },
00060     { "if", 3, ':', l_if },
00061     { "log", 1, ':', l_log },
00062     { "log10", 1, ':', l_log10 },
00063     { "rand", 1, ':', l_rand },
00064     { "select", 1, ':', l_select },
00065     { "sin", 1, ':', l_sin },
00066     { "sqrt", 1, ':', l_sqrt },
00067     { "tan", 1, ':', l_tan },
00068 };
00069 
00070 static int  libsize = 16;
00071 
00072 #define  resolve(ep) ((ep)->type==VAR?(ep)->v.ln:argf((ep)->v.chan))
00073 
00074 
00075 int
00076 fundefined(fname)           /* return # of arguments for function */
00077 char  *fname;
00078 {
00079     register LIBR  *lp;
00080     register VARDEF  *vp;
00081 
00082     if ((vp = varlookup(fname)) != NULL && vp->def != NULL
00083               && vp->def->v.kid->type == FUNC)
00084        return(nekids(vp->def->v.kid) - 1);
00085     lp = vp != NULL ? vp->lib : liblookup(fname);
00086     if (lp == NULL)
00087        return(0);
00088     return(lp->nargs);
00089 }
00090 
00091 
00092 double
00093 funvalue(fname, n, a)              /* return a function value to the user */
00094 char  *fname;
00095 int  n;
00096 double  *a;
00097 {
00098     ACTIVATION  act;
00099     register VARDEF  *vp;
00100     double  rval;
00101                                    /* push environment */
00102     act.name = fname;
00103     act.prev = curact;
00104     act.ap = a;
00105     if (n >= AFLAGSIZ)
00106        act.an = ~0;
00107     else
00108        act.an = (1L<<n)-1;
00109     act.fun = NULL;
00110     curact = &act;
00111 
00112     if ((vp = varlookup(fname)) == NULL || vp->def == NULL
00113               || vp->def->v.kid->type != FUNC)
00114        rval = libfunc(fname, vp);
00115     else
00116        rval = evalue(vp->def->v.kid->sibling);
00117 
00118     curact = act.prev;                    /* pop environment */
00119     return(rval);
00120 }
00121 
00122 
00123 void
00124 funset(fname, nargs, assign, fptr) /* set a library function */
00125 char  *fname;
00126 int  nargs;
00127 int  assign;
00128 double  (*fptr)(char *);
00129 {
00130     int  oldlibsize = libsize;
00131     char *cp;
00132     register LIBR  *lp;
00133                                           /* check for context */
00134     for (cp = fname; *cp; cp++)
00135        ;
00136     if (cp == fname)
00137        return;
00138     if (cp[-1] == CNTXMARK)
00139        *--cp = '\0';
00140     if ((lp = liblookup(fname)) == NULL) {       /* insert */
00141        if (libsize >= MAXLIB) {
00142            eputs("Too many library functons!\n");
00143            quit(1);
00144        }
00145        for (lp = &library[libsize]; lp > library; lp--)
00146            if (strcmp(lp[-1].fname, fname) > 0) {
00147               lp[0].fname = lp[-1].fname;
00148               lp[0].nargs = lp[-1].nargs;
00149               lp[0].atyp = lp[-1].atyp;
00150               lp[0].f = lp[-1].f;
00151            } else
00152               break;
00153        libsize++;
00154     }
00155     if (fptr == NULL) {                          /* delete */
00156        while (lp < &library[libsize-1]) {
00157            lp[0].fname = lp[1].fname;
00158            lp[0].nargs = lp[1].nargs;
00159            lp[0].atyp = lp[1].atyp;
00160            lp[0].f = lp[1].f;
00161            lp++;
00162        }
00163        libsize--;
00164     } else {                              /* or assign */
00165        lp[0].fname = fname;        /* string must be static! */
00166        lp[0].nargs = nargs;
00167        lp[0].atyp = assign;
00168        lp[0].f = fptr;
00169     }
00170     if (libsize != oldlibsize)
00171        libupdate(fname);                  /* relink library */
00172 }
00173 
00174 
00175 int
00176 nargum()                    /* return number of available arguments */
00177 {
00178     register int  n;
00179 
00180     if (curact == NULL)
00181        return(0);
00182     if (curact->fun == NULL) {
00183        for (n = 0; (1L<<n) & curact->an; n++)
00184            ;
00185        return(n);
00186     }
00187     return(nekids(curact->fun) - 1);
00188 }
00189 
00190 
00191 double
00192 argument(n)                 /* return nth argument for active function */
00193 register int  n;
00194 {
00195     register ACTIVATION  *actp = curact;
00196     register EPNODE  *ep = NULL;
00197     double  aval;
00198 
00199     if (actp == NULL || --n < 0) {
00200        eputs("Bad call to argument!\n");
00201        quit(1);
00202     }
00203                                           /* already computed? */
00204     if (n < AFLAGSIZ && 1L<<n & actp->an)
00205        return(actp->ap[n]);
00206 
00207     if (actp->fun == NULL || (ep = ekid(actp->fun, n+1)) == NULL) {
00208        eputs(actp->name);
00209        eputs(": too few arguments\n");
00210        quit(1);
00211     }
00212     curact = actp->prev;                  /* pop environment */
00213     aval = evalue(ep);                           /* compute argument */
00214     curact = actp;                        /* push back environment */
00215     if (n < ALISTSIZ) {                          /* save value */
00216        actp->ap[n] = aval;
00217        actp->an |= 1L<<n;
00218     }
00219     return(aval);
00220 }
00221 
00222 
00223 VARDEF *
00224 argf(n)                            /* return function def for nth argument */
00225 int  n;
00226 {
00227     register ACTIVATION  *actp;
00228     register EPNODE  *ep;
00229 
00230     for (actp = curact; actp != NULL; actp = actp->prev) {
00231 
00232        if (n <= 0)
00233            break;
00234 
00235        if (actp->fun == NULL)
00236            goto badarg;
00237 
00238        if ((ep = ekid(actp->fun, n)) == NULL) {
00239            eputs(actp->name);
00240            eputs(": too few arguments\n");
00241            quit(1);
00242        }
00243        if (ep->type == VAR)
00244            return(ep->v.ln);                     /* found it */
00245 
00246        if (ep->type != ARG)
00247            goto badarg;
00248 
00249        n = ep->v.chan;                           /* try previous context */
00250     }
00251     eputs("Bad call to argf!\n");
00252     quit(1);
00253 
00254 badarg:
00255     eputs(actp->name);
00256     eputs(": argument not a function\n");
00257     quit(1);
00258        return NULL; /* pro forma return */
00259 }
00260 
00261 
00262 char *
00263 argfun(n)                   /* return function name for nth argument */
00264 int  n;
00265 {
00266     return(argf(n)->name);
00267 }
00268 
00269 
00270 double
00271 efunc(ep)                          /* evaluate a function */
00272 register EPNODE  *ep;
00273 {
00274     ACTIVATION  act;
00275     double  alist[ALISTSIZ];
00276     double  rval;
00277     register VARDEF  *dp;
00278                                    /* push environment */
00279     dp = resolve(ep->v.kid);
00280     act.name = dp->name;
00281     act.prev = curact;
00282     act.ap = alist;
00283     act.an = 0;
00284     act.fun = ep;
00285     curact = &act;
00286 
00287     if (dp->def == NULL || dp->def->v.kid->type != FUNC)
00288        rval = libfunc(act.name, dp);
00289     else
00290        rval = evalue(dp->def->v.kid->sibling);
00291     
00292     curact = act.prev;                    /* pop environment */
00293     return(rval);
00294 }
00295 
00296 
00297 LIBR *
00298 liblookup(fname)            /* look up a library function */
00299 char  *fname;
00300 {
00301     int  upper, lower;
00302     register int  cm, i;
00303 
00304     lower = 0;
00305     upper = cm = libsize;
00306 
00307     while ((i = (lower + upper) >> 1) != cm) {
00308        cm = strcmp(fname, library[i].fname);
00309        if (cm > 0)
00310            lower = i;
00311        else if (cm < 0)
00312            upper = i;
00313        else
00314            return(&library[i]);
00315        cm = i;
00316     }
00317     return(NULL);
00318 }
00319 
00320 
00321 /*
00322  *  The following routines are for internal use:
00323  */
00324 
00325 
00326 static double
00327 libfunc(fname, vp)                 /* execute library function */
00328 char  *fname;
00329 VARDEF  *vp;
00330 {
00331     register LIBR  *lp;
00332     double  d;
00333     int  lasterrno;
00334 
00335     if (vp != NULL)
00336        lp = vp->lib;
00337     else
00338        lp = liblookup(fname);
00339     if (lp == NULL) {
00340        eputs(fname);
00341        eputs(": undefined function\n");
00342        quit(1);
00343     }
00344     lasterrno = errno;
00345     errno = 0;
00346     d = (*lp->f)(lp->fname);
00347 #ifdef  isnan
00348     if (errno == 0)
00349        if (isnan(d))
00350            errno = EDOM;
00351        else if (isinf(d))
00352            errno = ERANGE;
00353 #endif
00354     if (errno == EDOM || errno == ERANGE) {
00355        wputs(fname);
00356        if (errno == EDOM)
00357               wputs(": domain error\n");
00358        else if (errno == ERANGE)
00359               wputs(": range error\n");
00360        else
00361               wputs(": error in call\n");
00362        return(0.0);
00363     }
00364     errno = lasterrno;
00365     return(d);
00366 }
00367 
00368 
00369 /*
00370  *  Library functions:
00371  */
00372 
00373 
00374 static double
00375 l_if(char *nm)              /* if(cond, then, else) conditional expression */
00376                      /* cond evaluates true if greater than zero */
00377 {
00378     if (argument(1) > 0.0)
00379        return(argument(2));
00380     else
00381        return(argument(3));
00382 }
00383 
00384 
00385 static double
00386 l_select(char *nm)   /* return argument #(A1+1) */
00387 {
00388        register int  n;
00389 
00390        n = (int)(argument(1) + .5);
00391        if (n == 0)
00392               return(nargum()-1);
00393        if (n < 1 || n > nargum()-1) {
00394               errno = EDOM;
00395               return(0.0);
00396        }
00397        return(argument(n+1));
00398 }
00399 
00400 
00401 static double
00402 l_rand(char *nm)            /* random function between 0 and 1 */
00403 {
00404     double  x;
00405 
00406     x = argument(1);
00407     x *= 1.0/(1.0 + x*x) + 2.71828182845904;
00408     x += .785398163397447 - floor(x);
00409     x = 1e5 / x;
00410     return(x - floor(x));
00411 }
00412 
00413 
00414 static double
00415 l_floor(char *nm)           /* return largest integer not greater than arg1 */
00416 {
00417     return(floor(argument(1)));
00418 }
00419 
00420 
00421 static double
00422 l_ceil(char *nm)            /* return smallest integer not less than arg1 */
00423 {
00424     return(ceil(argument(1)));
00425 }
00426 
00427 
00428 static double
00429 l_sqrt(char *nm)
00430 {
00431     return(sqrt(argument(1)));
00432 }
00433 
00434 
00435 static double
00436 l_sin(char *nm)
00437 {
00438     return(sin(argument(1)));
00439 }
00440 
00441 
00442 static double
00443 l_cos(char *nm)
00444 {
00445     return(cos(argument(1)));
00446 }
00447 
00448 
00449 static double
00450 l_tan(char *nm)
00451 {
00452     return(tan(argument(1)));
00453 }
00454 
00455 
00456 static double
00457 l_asin(char *nm)
00458 {
00459     return(asin(argument(1)));
00460 }
00461 
00462 
00463 static double
00464 l_acos(char *nm)
00465 {
00466     return(acos(argument(1)));
00467 }
00468 
00469 
00470 static double
00471 l_atan(char *nm)
00472 {
00473     return(atan(argument(1)));
00474 }
00475 
00476 
00477 static double
00478 l_atan2(char *nm)
00479 {
00480     return(atan2(argument(1), argument(2)));
00481 }
00482 
00483 
00484 static double
00485 l_exp(char *nm)
00486 {
00487     return(exp(argument(1)));
00488 }
00489 
00490 
00491 static double
00492 l_log(char *nm)
00493 {
00494     return(log(argument(1)));
00495 }
00496 
00497 
00498 static double
00499 l_log10(char *nm)
00500 {
00501     return(log10(argument(1)));
00502 }