src/common/caldefn.c

#ifndef lint
static const char       RCSid[] = "$Id$";
#endif
/*
 *  Store variable definitions.
 *
 *  7/1/85  Greg Ward
 *
 *  11/11/85  Added conditional compiles (OUTCHAN) for control output.
 *
 *  4/2/86  Added conditional compiles for function definitions (FUNCTION).
 *
 *  1/15/88  Added clock for caching of variable values.
 *
 *  11/16/88  Added VARDEF structure for hard linking.
 *
 *  5/31/90  Added conditional compile (REDEFW) for redefinition warning.
 *
 *  4/23/91  Added ':' assignment for constant expressions
 *
 *  8/7/91  Added optional context path to append to variable names
 *
 *  5/17/2001  Fixed clock counter wrapping behavior
 *
 *  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  <string.h>

#include  <ctype.h>

#include  "calcomp.h"

#ifndef  NHASH
#define  NHASH          521             /* hash size (a prime!) */
#endif

#define  hash(s)        (shash(s)%NHASH)

#define  newnode()      (EPNODE *)ecalloc(1, sizeof(EPNODE))

static double  dvalue();

#define  MAXCLOCK       (1L<<31)        /* clock wrap value */

unsigned long  eclock = 0;              /* value storage timer */

#define  MAXCNTX        1023            /* maximum context length */

static char  context[MAXCNTX+1];        /* current context path */

static VARDEF  *hashtbl[NHASH];         /* definition list */
static int  htndx;                      /* index for */         
static VARDEF  *htpos;                  /* ...dfirst() and */
static EPNODE  *ochpos;                 /* ...dnext */
static EPNODE  *outchan;

EPNODE  *curfunc = NULL;
#define  dname(ep)      ((ep)->v.kid->type == SYM ? \
                        (ep)->v.kid->v.name : \
                        (ep)->v.kid->v.kid->v.name)


void
fcompile(fname)                 /* get definitions from a file */
char  *fname;
{
    FILE  *fp;

    if (fname == NULL)
        fp = stdin;
    else if ((fp = fopen(fname, "r")) == NULL) {
        eputs(fname);
        eputs(": cannot open\n");
        quit(1);
    }
    initfile(fp, fname, 0);
    while (nextc != EOF)
        getstatement();
    if (fname != NULL)
        fclose(fp);
}


void
scompile(str, fn, ln)           /* get definitions from a string */
char  *str;
char  *fn;
int  ln;
{
    initstr(str, fn, ln);
    while (nextc != EOF)
        getstatement();
}


double
varvalue(vname)                 /* return a variable's value */
char  *vname;
{
    return(dvalue(vname, dlookup(vname)));
}


double
evariable(ep)                   /* evaluate a variable */
EPNODE  *ep;
{
    register VARDEF  *dp = ep->v.ln;

    return(dvalue(dp->name, dp->def));
}


void
varset(vname, assign, val)      /* set a variable's value */
char  *vname;
int  assign;
double  val;
{
    char  *qname;
    register EPNODE  *ep1, *ep2;
                                        /* get qualified name */
    qname = qualname(vname, 0);
                                        /* check for quick set */
    if ((ep1 = dlookup(qname)) != NULL && ep1->v.kid->type == SYM) {
        ep2 = ep1->v.kid->sibling;
        if (ep2->type == NUM) {
            ep2->v.num = val;
            ep1->type = assign;
            return;
        }
    }
                                        /* hand build definition */
    ep1 = newnode();
    ep1->type = assign;
    ep2 = newnode();
    ep2->type = SYM;
    ep2->v.name = savestr(vname);
    addekid(ep1, ep2);
    ep2 = newnode();
    ep2->type = NUM;
    ep2->v.num = val;
    addekid(ep1, ep2);
    dremove(qname);
    dpush(qname, ep1);
}


void
dclear(name)                    /* delete variable definitions of name */
char  *name;
{
    register EPNODE  *ep;

    while ((ep = dpop(name)) != NULL) {
        if (ep->type == ':') {
            dpush(name, ep);            /* don't clear constants */
            return;
        }
        epfree(ep);
    }
}


void
dremove(name)                   /* delete all definitions of name */
char  *name;
{
    register EPNODE  *ep;

    while ((ep = dpop(name)) != NULL)
        epfree(ep);
}


int
vardefined(name)        /* return non-zero if variable defined */
char  *name;
{
    register EPNODE  *dp;

    return((dp = dlookup(name)) != NULL && dp->v.kid->type == SYM);
}


char *
setcontext(ctx)                 /* set a new context path */
register char  *ctx;
{
    register char  *cpp;

    if (ctx == NULL)
        return(context);                /* just asking */
    while (*ctx == CNTXMARK)
        ctx++;                          /* skip past marks */
    if (!*ctx) {
        context[0] = '\0';              /* empty means clear context */
        return(context);
    }
    cpp = context;                      /* start context with mark */
    *cpp++ = CNTXMARK;
    do {                                /* carefully copy new context */
        if (cpp >= context+MAXCNTX)
            break;                      /* just copy what we can */
        if (isid(*ctx))
            *cpp++ = *ctx++;
        else {
            *cpp++ = '_'; ctx++;
        }
    } while (*ctx);
    while (cpp[-1] == CNTXMARK)         /* cannot end in context mark */
        cpp--;
    *cpp = '\0';
    return(context);
}


char *
pushcontext(ctx)                /* push on another context */
char  *ctx;
{
    extern char  *strncpy(), *strcpy();
    char  oldcontext[MAXCNTX+1];
    register int  n;

    strcpy(oldcontext, context);        /* save old context */
    setcontext(ctx);                    /* set new context */
    n = strlen(context);                /* tack on old */
    if (n+strlen(oldcontext) > MAXCNTX) {
        strncpy(context+n, oldcontext, MAXCNTX-n);
        context[MAXCNTX] = '\0';
    } else
        strcpy(context+n, oldcontext);
    return(context);
}


char *
popcontext()                    /* pop off top context */
{
    register char  *cp1, *cp2;

    if (!context[0])                    /* nothing left to pop */
        return(context);
    cp2 = context;                      /* find mark */
    while (*++cp2 && *cp2 != CNTXMARK)
        ;
    cp1 = context;                      /* copy tail to front */
    while (*cp1++ = *cp2++)
        ;
    return(context);
}


char *
qualname(nam, lvl)              /* get qualified name */
register char  *nam;
int  lvl;
{
    static char  nambuf[MAXWORD+1];
    register char  *cp = nambuf, *cpp;
                                /* check for explicit local */
    if (*nam == CNTXMARK)
        if (lvl > 0)            /* only action is to refuse search */
            return(NULL);
        else
            nam++;
    else if (nam == nambuf)     /* check for repeat call */
        return(lvl > 0 ? NULL : nam);
                                /* copy name to static buffer */
    while (*nam) {
        if (cp >= nambuf+MAXWORD)
                goto toolong;
        *cp++ = *nam++;
    }
                                /* check for explicit global */
    if (cp > nambuf && cp[-1] == CNTXMARK) {
        if (lvl > 0)
            return(NULL);
        *--cp = '\0';
        return(nambuf);         /* already qualified */
    }
    cpp = context;              /* else skip the requested levels */
    while (lvl-- > 0) {
        if (!*cpp)
            return(NULL);       /* return NULL if past global level */
        while (*++cpp && *cpp != CNTXMARK)
            ;
    }
    while (*cpp) {              /* copy context to static buffer */
        if (cp >= nambuf+MAXWORD)
            goto toolong;
        *cp++ = *cpp++;
    }
toolong:
    *cp = '\0';
    return(nambuf);             /* return qualified name */
}


int
incontext(qn)                   /* is qualified name in current context? */
register char  *qn;
{
    if (!context[0])                    /* global context accepts all */
        return(1);
    while (*qn && *qn != CNTXMARK)      /* find context mark */
        qn++;
    return(!strcmp(qn, context));
}


void
chanout(cs)                     /* set output channels */
int  (*cs)();
{
    register EPNODE  *ep;

    for (ep = outchan; ep != NULL; ep = ep->sibling)
        (*cs)(ep->v.kid->v.chan, evalue(ep->v.kid->sibling));

}


void
dcleanup(lvl)           /* clear definitions (0->vars,1->output,2->consts) */
int  lvl;
{
    register int  i;
    register VARDEF  *vp;
    register EPNODE  *ep;
                                /* if context is global, clear all */
    for (i = 0; i < NHASH; i++)
        for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
            if (incontext(vp->name))
                if (lvl >= 2)
                    dremove(vp->name);
                else
                    dclear(vp->name);
    if (lvl >= 1) {
        for (ep = outchan; ep != NULL; ep = ep->sibling)
            epfree(ep);
        outchan = NULL;
    }
}


EPNODE *
dlookup(name)                   /* look up a definition */
char  *name;
{
    register VARDEF  *vp;
    
    if ((vp = varlookup(name)) == NULL)
        return(NULL);
    return(vp->def);
}


VARDEF *
varlookup(name)                 /* look up a variable */
char  *name;
{
    int  lvl = 0;
    register char  *qname;
    register VARDEF  *vp;
                                /* find most qualified match */
    while ((qname = qualname(name, lvl++)) != NULL)
        for (vp = hashtbl[hash(qname)]; vp != NULL; vp = vp->next)
            if (!strcmp(vp->name, qname))
                return(vp);
    return(NULL);
}


VARDEF *
varinsert(name)                 /* get a link to a variable */
char  *name;
{
    register VARDEF  *vp;
    int  hv;
    
    if ((vp = varlookup(name)) != NULL) {
        vp->nlinks++;
        return(vp);
    }
    vp = (VARDEF *)emalloc(sizeof(VARDEF));
    vp->lib = liblookup(name);
    if (vp->lib == NULL)                /* if name not in library */
        name = qualname(name, 0);       /* use fully qualified version */
    hv = hash(name);
    vp->name = savestr(name);
    vp->nlinks = 1;
    vp->def = NULL;
    vp->next = hashtbl[hv];
    hashtbl[hv] = vp;
    return(vp);
}


void
libupdate(fn)                   /* update library links */
char  *fn;
{
    register int  i;
    register VARDEF  *vp;
                                        /* if fn is NULL then relink all */
    for (i = 0; i < NHASH; i++)
        for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
            if (vp->lib != NULL || fn == NULL || !strcmp(fn, vp->name))
                vp->lib = liblookup(vp->name);
}


void
varfree(ln)                             /* release link to variable */
register VARDEF  *ln;
{
    register VARDEF  *vp;
    int  hv;

    if (--ln->nlinks > 0)
        return;                         /* still active */

    hv = hash(ln->name);
    vp = hashtbl[hv];
    if (vp == ln)
        hashtbl[hv] = vp->next;
    else {
        while (vp->next != ln)          /* must be in list */
                vp = vp->next;
        vp->next = ln->next;
    }
    freestr(ln->name);
    efree((char *)ln);
}


EPNODE *
dfirst()                        /* return pointer to first definition */
{
    htndx = 0;
    htpos = NULL;
    ochpos = outchan;
    return(dnext());
}


EPNODE *
dnext()                         /* return pointer to next definition */
{
    register EPNODE  *ep;
    register char  *nm;

    while (htndx < NHASH) {
        if (htpos == NULL)
                htpos = hashtbl[htndx++];
        while (htpos != NULL) {
            ep = htpos->def;
            nm = htpos->name;
            htpos = htpos->next;
            if (ep != NULL && incontext(nm))
                return(ep);
        }
    }
    if ((ep = ochpos) != NULL)
        ochpos = ep->sibling;
    return(ep);
}


EPNODE *
dpop(name)                      /* pop a definition */
char  *name;
{
    register VARDEF  *vp;
    register EPNODE  *dp;
    
    if ((vp = varlookup(name)) == NULL || vp->def == NULL)
        return(NULL);
    dp = vp->def;
    vp->def = dp->sibling;
    varfree(vp);
    return(dp);
}


void
dpush(nm, ep)                   /* push on a definition */
char  *nm;
register EPNODE  *ep;
{
    register VARDEF  *vp;

    vp = varinsert(nm);
    ep->sibling = vp->def;
    vp->def = ep;
}


void
addchan(sp)                     /* add an output channel assignment */
EPNODE  *sp;
{
    int  ch = sp->v.kid->v.chan;
    register EPNODE  *ep, *epl;

    for (epl = NULL, ep = outchan; ep != NULL; epl = ep, ep = ep->sibling)
        if (ep->v.kid->v.chan >= ch) {
            if (epl != NULL)
                epl->sibling = sp;
            else
                outchan = sp;
            if (ep->v.kid->v.chan > ch)
                sp->sibling = ep;
            else {
                sp->sibling = ep->sibling;
                epfree(ep);
            }
            return;
        }
    if (epl != NULL)
        epl->sibling = sp;
    else
        outchan = sp;
    sp->sibling = NULL;

}


void
getstatement()                  /* get next statement */
{
    register EPNODE  *ep;
    char  *qname;
    register VARDEF  *vdef;

    if (nextc == ';') {         /* empty statement */
        scan();
        return;
    }
    if (esupport&E_OUTCHAN &&
                nextc == '$') {         /* channel assignment */
        ep = getchan();
        addchan(ep);
    } else {                            /* ordinary definition */
        ep = getdefn();
        qname = qualname(dname(ep), 0);
        if (esupport&E_REDEFW && (vdef = varlookup(qname)) != NULL)
            if (vdef->def != NULL && epcmp(ep, vdef->def)) {
                wputs(qname);
                if (vdef->def->type == ':')
                    wputs(": redefined constant expression\n");
                else
                    wputs(": redefined\n");
            } else if (ep->v.kid->type == FUNC && vdef->lib != NULL) {
                wputs(qname);
                wputs(": definition hides library function\n");
            }
        if (ep->type == ':')
            dremove(qname);
        else
            dclear(qname);
        dpush(qname, ep);
    }
    if (nextc != EOF) {
        if (nextc != ';')
            syntax("';' expected");
        scan();
    }
}


EPNODE *
getdefn()                       /* A -> SYM = E1 */
                                /*      SYM : E1 */
                                /*      FUNC(SYM,..) = E1 */
                                /*      FUNC(SYM,..) : E1 */
{
    register EPNODE  *ep1, *ep2;

    if (!isalpha(nextc) && nextc != CNTXMARK)
        syntax("illegal variable name");

    ep1 = newnode();
    ep1->type = SYM;
    ep1->v.name = savestr(getname());

    if (esupport&E_FUNCTION && nextc == '(') {
        ep2 = newnode();
        ep2->type = FUNC;
        addekid(ep2, ep1);
        ep1 = ep2;
        do {
            scan();
            if (!isalpha(nextc))
                syntax("illegal variable name");
            ep2 = newnode();
            ep2->type = SYM;
            ep2->v.name = savestr(getname());
            addekid(ep1, ep2);
        } while (nextc == ',');
        if (nextc != ')')
            syntax("')' expected");
        scan();
        curfunc = ep1;
    }

    if (nextc != '=' && nextc != ':')
        syntax("'=' or ':' expected");

    ep2 = newnode();
    ep2->type = nextc;
    scan();
    addekid(ep2, ep1);
    addekid(ep2, getE1());

    if (ep1->type == SYM && ep1->sibling->type != NUM) {
        ep1 = newnode();
        ep1->type = TICK;
        ep1->v.tick = 0;
        addekid(ep2, ep1);
        ep1 = newnode();
        ep1->type = NUM;
        addekid(ep2, ep1);
    }
    curfunc = NULL;

    return(ep2);
}


EPNODE *
getchan()                       /* A -> $N = E1 */
{
    register EPNODE  *ep1, *ep2;

    if (nextc != '$')
        syntax("missing '$'");
    scan();

    ep1 = newnode();
    ep1->type = CHAN;
    ep1->v.chan = getinum();

    if (nextc != '=')
        syntax("'=' expected");
    scan();

    ep2 = newnode();
    ep2->type = '=';
    addekid(ep2, ep1);
    addekid(ep2, getE1());

    return(ep2);
}


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


static double
dvalue(name, d)                 /* evaluate a variable */
char  *name;
EPNODE  *d;
{
    register EPNODE  *ep1, *ep2;
    
    if (d == NULL || d->v.kid->type != SYM) {
        eputs(name);
        eputs(": undefined variable\n");
        quit(1);
    }
    ep1 = d->v.kid->sibling;                    /* get expression */
    if (ep1->type == NUM)
        return(ep1->v.num);                     /* return if number */
    ep2 = ep1->sibling;                         /* check time */
    if (eclock >= MAXCLOCK)
        eclock = 1;                             /* wrap clock counter */
    if (ep2->v.tick < MAXCLOCK &&
                ep2->v.tick == 0 | ep2->v.tick != eclock) {
        ep2->v.tick = d->type == ':' ? MAXCLOCK : eclock;
        ep2 = ep2->sibling;
        ep2->v.num = evalue(ep1);               /* needs new value */
    } else
        ep2 = ep2->sibling;                     /* else reuse old value */

    return(ep2->v.num);
}
Revision:	2.12
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.11:	+92 -57 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.12	static const char RCSid[] = "$Id$";
3	greg	1.1	#endif
4			/*
5			* Store variable definitions.
6			*
7			* 7/1/85 Greg Ward
8			*
9			* 11/11/85 Added conditional compiles (OUTCHAN) for control output.
10			*
11			* 4/2/86 Added conditional compiles for function definitions (FUNCTION).
12			*
13			* 1/15/88 Added clock for caching of variable values.
14			*
15			* 11/16/88 Added VARDEF structure for hard linking.
16	greg	1.2	*
17			* 5/31/90 Added conditional compile (REDEFW) for redefinition warning.
18	greg	1.8	*
19	greg	1.10	* 4/23/91 Added ':' assignment for constant expressions
20	greg	1.13	*
21			* 8/7/91 Added optional context path to append to variable names
22	greg	2.12	*
23			* 5/17/2001 Fixed clock counter wrapping behavior
24			*
25			* 2/19/03 Eliminated conditional compiles in favor of esupport extern.
26			*/
27
28			/* ====================================================================
29			* The Radiance Software License, Version 1.0
30			*
31			* Copyright (c) 1990 - 2002 The Regents of the University of California,
32			* through Lawrence Berkeley National Laboratory. All rights reserved.
33			*
34			* Redistribution and use in source and binary forms, with or without
35			* modification, are permitted provided that the following conditions
36			* are met:
37			*
38			* 1. Redistributions of source code must retain the above copyright
39			* notice, this list of conditions and the following disclaimer.
40			*
41			* 2. Redistributions in binary form must reproduce the above copyright
42			* notice, this list of conditions and the following disclaimer in
43			* the documentation and/or other materials provided with the
44			* distribution.
45			*
46			* 3. The end-user documentation included with the redistribution,
47			* if any, must include the following acknowledgment:
48			* "This product includes Radiance software
49			* (http://radsite.lbl.gov/)
50			* developed by the Lawrence Berkeley National Laboratory
51			* (http://www.lbl.gov/)."
52			* Alternately, this acknowledgment may appear in the software itself,
53			* if and wherever such third-party acknowledgments normally appear.
54			*
55			* 4. The names "Radiance," "Lawrence Berkeley National Laboratory"
56			* and "The Regents of the University of California" must
57			* not be used to endorse or promote products derived from this
58			* software without prior written permission. For written
59			* permission, please contact [email protected].
60			*
61			* 5. Products derived from this software may not be called "Radiance",
62			* nor may "Radiance" appear in their name, without prior written
63			* permission of Lawrence Berkeley National Laboratory.
64			*
65			* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
66			* WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
67			* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
68			* DISCLAIMED. IN NO EVENT SHALL Lawrence Berkeley National Laboratory OR
69			* ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
70			* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
71			* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
72			* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
73			* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
74			* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
75			* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
76			* SUCH DAMAGE.
77			* ====================================================================
78			*
79			* This software consists of voluntary contributions made by many
80			* individuals on behalf of Lawrence Berkeley National Laboratory. For more
81			* information on Lawrence Berkeley National Laboratory, please see
82			* <http://www.lbl.gov/>.
83	greg	1.1	*/
84
85			#include <stdio.h>
86
87	greg	2.12	#include <string.h>
88
89	greg	1.1	#include <ctype.h>
90
91			#include "calcomp.h"
92
93	greg	2.4	#ifndef NHASH
94			#define NHASH 521 /* hash size (a prime!) */
95	greg	1.1	#endif
96
97	greg	2.5	#define hash(s) (shash(s)%NHASH)
98
99	greg	2.4	#define newnode() (EPNODE *)ecalloc(1, sizeof(EPNODE))
100	greg	1.1
101	greg	2.12	static double dvalue();
102	greg	1.1
103	greg	2.12	#define MAXCLOCK (1L<<31) /* clock wrap value */
104	greg	1.1
105	greg	2.8	unsigned long eclock = 0; /* value storage timer */
106	greg	1.1
107	greg	2.11	#define MAXCNTX 1023 /* maximum context length */
108	greg	1.13
109	greg	2.11	static char context[MAXCNTX+1]; /* current context path */
110
111	greg	1.1	static VARDEF hashtbl[NHASH]; / definition list */
112			static int htndx; /* index for */
113			static VARDEF htpos; / ...dfirst() and */
114			static EPNODE ochpos; / ...dnext */
115			static EPNODE *outchan;
116
117	greg	2.10	EPNODE *curfunc = NULL;
118	greg	2.4	#define dname(ep) ((ep)->v.kid->type == SYM ? \
119	greg	1.1	(ep)->v.kid->v.name : \
120			(ep)->v.kid->v.kid->v.name)
121
122
123	greg	2.12	void
124	greg	1.1	fcompile(fname) /* get definitions from a file */
125			char *fname;
126			{
127			FILE *fp;
128
129			if (fname == NULL)
130			fp = stdin;
131			else if ((fp = fopen(fname, "r")) == NULL) {
132			eputs(fname);
133			eputs(": cannot open\n");
134			quit(1);
135			}
136	greg	1.4	initfile(fp, fname, 0);
137	greg	1.1	while (nextc != EOF)
138	greg	1.13	getstatement();
139	greg	1.1	if (fname != NULL)
140			fclose(fp);
141			}
142
143
144	greg	2.12	void
145	greg	1.4	scompile(str, fn, ln) /* get definitions from a string */
146	greg	1.1	char *str;
147	greg	1.4	char *fn;
148			int ln;
149	greg	1.1	{
150	greg	1.4	initstr(str, fn, ln);
151	greg	1.1	while (nextc != EOF)
152	greg	1.13	getstatement();
153	greg	1.1	}
154
155
156			double
157			varvalue(vname) /* return a variable's value */
158			char *vname;
159			{
160			return(dvalue(vname, dlookup(vname)));
161			}
162
163
164			double
165			evariable(ep) /* evaluate a variable */
166	greg	2.4	EPNODE *ep;
167	greg	1.1	{
168			register VARDEF *dp = ep->v.ln;
169
170			return(dvalue(dp->name, dp->def));
171			}
172
173
174	greg	2.12	void
175	greg	1.8	varset(vname, assign, val) /* set a variable's value */
176	greg	1.1	char *vname;
177	greg	1.8	int assign;
178	greg	2.4	double val;
179	greg	1.1	{
180	greg	1.13	char *qname;
181	greg	1.1	register EPNODE ep1, ep2;
182	greg	1.13	/* get qualified name */
183			qname = qualname(vname, 0);
184	greg	1.1	/* check for quick set */
185	greg	1.13	if ((ep1 = dlookup(qname)) != NULL && ep1->v.kid->type == SYM) {
186	greg	1.1	ep2 = ep1->v.kid->sibling;
187			if (ep2->type == NUM) {
188			ep2->v.num = val;
189	greg	1.8	ep1->type = assign;
190	greg	1.1	return;
191			}
192			}
193			/* hand build definition */
194			ep1 = newnode();
195	greg	1.8	ep1->type = assign;
196	greg	1.1	ep2 = newnode();
197			ep2->type = SYM;
198			ep2->v.name = savestr(vname);
199			addekid(ep1, ep2);
200			ep2 = newnode();
201			ep2->type = NUM;
202			ep2->v.num = val;
203			addekid(ep1, ep2);
204	greg	1.13	dremove(qname);
205			dpush(qname, ep1);
206	greg	1.1	}
207
208
209	greg	2.12	void
210	greg	1.8	dclear(name) /* delete variable definitions of name */
211	greg	1.1	char *name;
212			{
213			register EPNODE *ep;
214
215	greg	1.8	while ((ep = dpop(name)) != NULL) {
216			if (ep->type == ':') {
217	greg	1.13	dpush(name, ep); /* don't clear constants */
218	greg	1.8	return;
219			}
220			epfree(ep);
221			}
222			}
223
224
225	greg	2.12	void
226	greg	1.8	dremove(name) /* delete all definitions of name */
227			char *name;
228			{
229			register EPNODE *ep;
230
231	greg	1.1	while ((ep = dpop(name)) != NULL)
232			epfree(ep);
233			}
234
235
236	greg	2.12	int
237	greg	1.1	vardefined(name) /* return non-zero if variable defined */
238			char *name;
239			{
240			register EPNODE *dp;
241
242			return((dp = dlookup(name)) != NULL && dp->v.kid->type == SYM);
243			}
244
245
246	greg	1.13	char *
247			setcontext(ctx) /* set a new context path */
248			register char *ctx;
249			{
250			register char *cpp;
251
252			if (ctx == NULL)
253			return(context); /* just asking */
254	greg	2.6	while (*ctx == CNTXMARK)
255			ctx++; /* skip past marks */
256	greg	1.13	if (!*ctx) {
257	greg	2.6	context[0] = '\0'; /* empty means clear context */
258	greg	1.13	return(context);
259			}
260	greg	2.6	cpp = context; /* start context with mark */
261			*cpp++ = CNTXMARK;
262			do { /* carefully copy new context */
263	greg	2.11	if (cpp >= context+MAXCNTX)
264	greg	1.18	break; /* just copy what we can */
265	greg	1.13	if (isid(*ctx))
266			cpp++ = ctx++;
267			else {
268			*cpp++ = '_'; ctx++;
269			}
270			} while (*ctx);
271	greg	2.6	while (cpp[-1] == CNTXMARK) /* cannot end in context mark */
272			cpp--;
273	greg	1.13	*cpp = '\0';
274	greg	2.6	return(context);
275			}
276
277
278			char *
279			pushcontext(ctx) /* push on another context */
280			char *ctx;
281			{
282			extern char strncpy(), strcpy();
283	greg	2.11	char oldcontext[MAXCNTX+1];
284	greg	2.6	register int n;
285
286			strcpy(oldcontext, context); /* save old context */
287			setcontext(ctx); /* set new context */
288			n = strlen(context); /* tack on old */
289	greg	2.11	if (n+strlen(oldcontext) > MAXCNTX) {
290			strncpy(context+n, oldcontext, MAXCNTX-n);
291			context[MAXCNTX] = '\0';
292	greg	2.6	} else
293			strcpy(context+n, oldcontext);
294			return(context);
295			}
296
297
298			char *
299			popcontext() /* pop off top context */
300			{
301			register char cp1, cp2;
302
303			if (!context[0]) /* nothing left to pop */
304			return(context);
305			cp2 = context; /* find mark */
306			while (++cp2 && cp2 != CNTXMARK)
307			;
308			cp1 = context; /* copy tail to front */
309			while (cp1++ = cp2++)
310			;
311	greg	1.13	return(context);
312			}
313
314
315			char *
316			qualname(nam, lvl) /* get qualified name */
317			register char *nam;
318			int lvl;
319			{
320	greg	2.4	static char nambuf[MAXWORD+1];
321	greg	1.17	register char cp = nambuf, cpp;
322			/* check for explicit local */
323	greg	1.15	if (*nam == CNTXMARK)
324	greg	1.17	if (lvl > 0) /* only action is to refuse search */
325			return(NULL);
326			else
327			nam++;
328			else if (nam == nambuf) /* check for repeat call */
329			return(lvl > 0 ? NULL : nam);
330	greg	1.13	/* copy name to static buffer */
331			while (*nam) {
332	greg	1.18	if (cp >= nambuf+MAXWORD)
333	greg	1.13	goto toolong;
334	greg	1.17	cp++ = nam++;
335	greg	1.13	}
336	greg	1.17	/* check for explicit global */
337			if (cp > nambuf && cp[-1] == CNTXMARK) {
338	greg	1.13	if (lvl > 0)
339	greg	1.17	return(NULL);
340			*--cp = '\0';
341			return(nambuf); /* already qualified */
342			}
343			cpp = context; /* else skip the requested levels */
344			while (lvl-- > 0) {
345			if (!*cpp)
346			return(NULL); /* return NULL if past global level */
347			while (++cpp && cpp != CNTXMARK)
348			;
349			}
350	greg	1.13	while (cpp) { / copy context to static buffer */
351	greg	1.18	if (cp >= nambuf+MAXWORD)
352	greg	1.13	goto toolong;
353			cp++ = cpp++;
354			}
355	greg	1.18	toolong:
356	greg	1.13	*cp = '\0';
357			return(nambuf); /* return qualified name */
358			}
359
360
361	greg	2.12	int
362	greg	1.14	incontext(qn) /* is qualified name in current context? */
363			register char *qn;
364			{
365	greg	2.9	if (!context[0]) /* global context accepts all */
366			return(1);
367	greg	1.14	while (qn && qn != CNTXMARK) /* find context mark */
368	greg	1.19	qn++;
369	greg	1.14	return(!strcmp(qn, context));
370			}
371
372
373	greg	2.12	void
374	greg	1.6	chanout(cs) /* set output channels */
375			int (*cs)();
376	greg	1.1	{
377			register EPNODE *ep;
378
379			for (ep = outchan; ep != NULL; ep = ep->sibling)
380	greg	1.6	(*cs)(ep->v.kid->v.chan, evalue(ep->v.kid->sibling));
381	greg	1.1
382			}
383
384
385	greg	2.12	void
386	greg	1.12	dcleanup(lvl) /* clear definitions (0->vars,1->output,2->consts) */
387	greg	1.10	int lvl;
388	greg	1.1	{
389			register int i;
390			register VARDEF *vp;
391			register EPNODE *ep;
392	greg	1.14	/* if context is global, clear all */
393	greg	1.1	for (i = 0; i < NHASH; i++)
394			for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
395	greg	2.9	if (incontext(vp->name))
396	greg	1.14	if (lvl >= 2)
397			dremove(vp->name);
398			else
399			dclear(vp->name);
400	greg	1.12	if (lvl >= 1) {
401	greg	1.9	for (ep = outchan; ep != NULL; ep = ep->sibling)
402			epfree(ep);
403			outchan = NULL;
404			}
405	greg	1.1	}
406
407
408			EPNODE *
409			dlookup(name) /* look up a definition */
410			char *name;
411			{
412			register VARDEF *vp;
413
414			if ((vp = varlookup(name)) == NULL)
415	greg	2.4	return(NULL);
416	greg	1.1	return(vp->def);
417			}
418
419
420			VARDEF *
421			varlookup(name) /* look up a variable */
422			char *name;
423			{
424	greg	2.4	int lvl = 0;
425	greg	1.13	register char *qname;
426	greg	1.1	register VARDEF *vp;
427	greg	2.4	/* find most qualified match */
428	greg	1.13	while ((qname = qualname(name, lvl++)) != NULL)
429			for (vp = hashtbl[hash(qname)]; vp != NULL; vp = vp->next)
430			if (!strcmp(vp->name, qname))
431			return(vp);
432	greg	1.1	return(NULL);
433			}
434
435
436			VARDEF *
437			varinsert(name) /* get a link to a variable */
438			char *name;
439			{
440			register VARDEF *vp;
441	greg	2.4	int hv;
442	greg	1.1
443	greg	1.13	if ((vp = varlookup(name)) != NULL) {
444			vp->nlinks++;
445			return(vp);
446			}
447	greg	2.3	vp = (VARDEF *)emalloc(sizeof(VARDEF));
448			vp->lib = liblookup(name);
449			if (vp->lib == NULL) /* if name not in library */
450	greg	1.16	name = qualname(name, 0); /* use fully qualified version */
451	greg	1.1	hv = hash(name);
452			vp->name = savestr(name);
453			vp->nlinks = 1;
454			vp->def = NULL;
455			vp->next = hashtbl[hv];
456			hashtbl[hv] = vp;
457			return(vp);
458			}
459	greg	2.2
460
461	greg	2.12	void
462	greg	2.2	libupdate(fn) /* update library links */
463			char *fn;
464			{
465			register int i;
466			register VARDEF *vp;
467			/* if fn is NULL then relink all */
468			for (i = 0; i < NHASH; i++)
469			for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
470			if (vp->lib != NULL \|\| fn == NULL \|\| !strcmp(fn, vp->name))
471			vp->lib = liblookup(vp->name);
472			}
473	greg	1.1
474
475	greg	2.12	void
476	greg	1.1	varfree(ln) /* release link to variable */
477	greg	2.4	register VARDEF *ln;
478	greg	1.1	{
479			register VARDEF *vp;
480	greg	2.4	int hv;
481	greg	1.1
482			if (--ln->nlinks > 0)
483	greg	2.4	return; /* still active */
484	greg	1.1
485			hv = hash(ln->name);
486			vp = hashtbl[hv];
487			if (vp == ln)
488	greg	2.4	hashtbl[hv] = vp->next;
489	greg	1.1	else {
490	greg	2.4	while (vp->next != ln) /* must be in list */
491			vp = vp->next;
492			vp->next = ln->next;
493	greg	1.1	}
494			freestr(ln->name);
495			efree((char *)ln);
496			}
497
498
499			EPNODE *
500			dfirst() /* return pointer to first definition */
501			{
502			htndx = 0;
503			htpos = NULL;
504			ochpos = outchan;
505			return(dnext());
506			}
507
508
509			EPNODE *
510			dnext() /* return pointer to next definition */
511			{
512			register EPNODE *ep;
513	greg	1.19	register char *nm;
514	greg	1.1
515			while (htndx < NHASH) {
516	greg	2.4	if (htpos == NULL)
517			htpos = hashtbl[htndx++];
518			while (htpos != NULL) {
519			ep = htpos->def;
520	greg	1.19	nm = htpos->name;
521	greg	2.4	htpos = htpos->next;
522			if (ep != NULL && incontext(nm))
523			return(ep);
524			}
525	greg	1.1	}
526			if ((ep = ochpos) != NULL)
527	greg	2.4	ochpos = ep->sibling;
528	greg	1.1	return(ep);
529			}
530
531
532			EPNODE *
533			dpop(name) /* pop a definition */
534			char *name;
535			{
536			register VARDEF *vp;
537			register EPNODE *dp;
538
539			if ((vp = varlookup(name)) == NULL \|\| vp->def == NULL)
540	greg	2.4	return(NULL);
541	greg	1.1	dp = vp->def;
542			vp->def = dp->sibling;
543			varfree(vp);
544			return(dp);
545			}
546
547
548	greg	2.12	void
549	greg	1.13	dpush(nm, ep) /* push on a definition */
550			char *nm;
551	greg	2.4	register EPNODE *ep;
552	greg	1.1	{
553			register VARDEF *vp;
554
555	greg	1.13	vp = varinsert(nm);
556	greg	1.1	ep->sibling = vp->def;
557			vp->def = ep;
558			}
559
560
561	greg	2.12	void
562	greg	1.1	addchan(sp) /* add an output channel assignment */
563	greg	2.4	EPNODE *sp;
564	greg	1.1	{
565	greg	2.4	int ch = sp->v.kid->v.chan;
566	greg	1.1	register EPNODE ep, epl;
567
568			for (epl = NULL, ep = outchan; ep != NULL; epl = ep, ep = ep->sibling)
569			if (ep->v.kid->v.chan >= ch) {
570			if (epl != NULL)
571			epl->sibling = sp;
572			else
573			outchan = sp;
574			if (ep->v.kid->v.chan > ch)
575			sp->sibling = ep;
576			else {
577			sp->sibling = ep->sibling;
578			epfree(ep);
579			}
580			return;
581			}
582			if (epl != NULL)
583			epl->sibling = sp;
584			else
585			outchan = sp;
586			sp->sibling = NULL;
587
588			}
589
590
591	greg	2.12	void
592	greg	1.13	getstatement() /* get next statement */
593	greg	1.1	{
594			register EPNODE *ep;
595	greg	1.13	char *qname;
596	greg	1.16	register VARDEF *vdef;
597	greg	1.1
598			if (nextc == ';') { /* empty statement */
599			scan();
600			return;
601			}
602	greg	2.12	if (esupport&E_OUTCHAN &&
603			nextc == '$') { /* channel assignment */
604	greg	1.1	ep = getchan();
605			addchan(ep);
606	greg	2.12	} else { /* ordinary definition */
607	greg	1.1	ep = getdefn();
608	greg	1.13	qname = qualname(dname(ep), 0);
609	greg	2.12	if (esupport&E_REDEFW && (vdef = varlookup(qname)) != NULL)
610	greg	2.7	if (vdef->def != NULL && epcmp(ep, vdef->def)) {
611	greg	1.16	wputs(qname);
612			if (vdef->def->type == ':')
613			wputs(": redefined constant expression\n");
614			else
615			wputs(": redefined\n");
616	greg	2.12	} else if (ep->v.kid->type == FUNC && vdef->lib != NULL) {
617	greg	1.16	wputs(qname);
618			wputs(": definition hides library function\n");
619			}
620	greg	1.10	if (ep->type == ':')
621	greg	1.13	dremove(qname);
622	greg	1.10	else
623	greg	1.13	dclear(qname);
624			dpush(qname, ep);
625	greg	1.1	}
626			if (nextc != EOF) {
627			if (nextc != ';')
628			syntax("';' expected");
629			scan();
630			}
631			}
632
633
634			EPNODE *
635			getdefn() /* A -> SYM = E1 */
636	greg	1.8	/* SYM : E1 */
637	greg	2.4	/* FUNC(SYM,..) = E1 */
638	greg	1.8	/* FUNC(SYM,..) : E1 */
639	greg	1.1	{
640			register EPNODE ep1, ep2;
641
642	greg	1.18	if (!isalpha(nextc) && nextc != CNTXMARK)
643	greg	1.1	syntax("illegal variable name");
644
645			ep1 = newnode();
646			ep1->type = SYM;
647			ep1->v.name = savestr(getname());
648
649	greg	2.12	if (esupport&E_FUNCTION && nextc == '(') {
650	greg	1.1	ep2 = newnode();
651			ep2->type = FUNC;
652			addekid(ep2, ep1);
653			ep1 = ep2;
654			do {
655			scan();
656			if (!isalpha(nextc))
657			syntax("illegal variable name");
658			ep2 = newnode();
659			ep2->type = SYM;
660			ep2->v.name = savestr(getname());
661			addekid(ep1, ep2);
662			} while (nextc == ',');
663			if (nextc != ')')
664			syntax("')' expected");
665			scan();
666			curfunc = ep1;
667	greg	2.10	}
668	greg	1.1
669	greg	1.8	if (nextc != '=' && nextc != ':')
670			syntax("'=' or ':' expected");
671	greg	1.1
672			ep2 = newnode();
673	greg	1.8	ep2->type = nextc;
674			scan();
675	greg	1.1	addekid(ep2, ep1);
676			addekid(ep2, getE1());
677
678	greg	2.12	if (ep1->type == SYM && ep1->sibling->type != NUM) {
679	greg	1.1	ep1 = newnode();
680			ep1->type = TICK;
681	greg	2.8	ep1->v.tick = 0;
682	greg	1.1	addekid(ep2, ep1);
683			ep1 = newnode();
684			ep1->type = NUM;
685			addekid(ep2, ep1);
686			}
687	greg	2.10	curfunc = NULL;
688	greg	1.1
689			return(ep2);
690			}
691
692
693			EPNODE *
694			getchan() /* A -> $N = E1 */
695			{
696			register EPNODE ep1, ep2;
697
698			if (nextc != '$')
699			syntax("missing '$'");
700			scan();
701
702			ep1 = newnode();
703			ep1->type = CHAN;
704			ep1->v.chan = getinum();
705
706			if (nextc != '=')
707			syntax("'=' expected");
708			scan();
709
710			ep2 = newnode();
711			ep2->type = '=';
712			addekid(ep2, ep1);
713			addekid(ep2, getE1());
714
715			return(ep2);
716			}
717
718
719
720			/*
721			* The following routines are for internal use only:
722			*/
723
724
725			static double
726			dvalue(name, d) /* evaluate a variable */
727			char *name;
728	greg	2.4	EPNODE *d;
729	greg	1.1	{
730			register EPNODE ep1, ep2;
731
732			if (d == NULL \|\| d->v.kid->type != SYM) {
733			eputs(name);
734			eputs(": undefined variable\n");
735			quit(1);
736			}
737			ep1 = d->v.kid->sibling; /* get expression */
738	greg	1.5	if (ep1->type == NUM)
739			return(ep1->v.num); /* return if number */
740	greg	1.1	ep2 = ep1->sibling; /* check time */
741	greg	2.12	if (eclock >= MAXCLOCK)
742			eclock = 1; /* wrap clock counter */
743			if (ep2->v.tick < MAXCLOCK &&
744			ep2->v.tick == 0 \| ep2->v.tick != eclock) {
745			ep2->v.tick = d->type == ':' ? MAXCLOCK : eclock;
746	greg	1.1	ep2 = ep2->sibling;
747	greg	1.5	ep2->v.num = evalue(ep1); /* needs new value */
748	greg	1.1	} else
749	greg	1.5	ep2 = ep2->sibling; /* else reuse old value */
750	greg	1.1
751			return(ep2->v.num);
752			}