src/common/caldefn.c

#ifndef lint
static const char       RCSid[] = "$Id: caldefn.c,v 2.37 2023/10/01 18:02:23 greg Exp $";
#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.
 */

#include "copyright.h"

#include  <ctype.h>

#include  "rterror.h"
#include  "rtio.h"
#include  "rtmisc.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(char  *name, EPNODE *d);

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

static int  optimized = 0;              /* are we optimized? */

EPNODE  *curfunc = NULL;


void
fcompile(                       /* 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);
    }
#ifdef getc_unlocked                    /* avoid stupid semaphores */
    flockfile(fp);
#endif
   initfile(fp, fname, 0);
    while (nextc != EOF)
        getstatement();
    if (fname != NULL)
        fclose(fp);
#ifdef getc_unlocked
    else
        funlockfile(fp);
#endif
}


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


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


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

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


void
varset(         /* set a variable's value */
        char  *vname,
        int  assign,
        double  val
)
{
    char  *qname;
    EPNODE  *ep1, *ep2;
                                        /* get qualified name */
    qname = qualname(vname, 0);
                                        /* check for quick set */
    if ((ep1 = dlookup(qname)) != NULL && ep1->v.kid->type == SYM &&
                (ep1->type == ':') <= (assign == ':')) {
        ep2 = ep1->v.kid->sibling;
        if (ep2->type == NUM) {
            ep2->v.num = val;
            ep1->type = assign;
            return;
        }
    }
    if (ep1 != NULL && esupport&E_REDEFW) {
        wputs(qname);
        if (ep1->type == ':')
            wputs(": reset constant expression\n");
        else
            wputs(": reset expression\n");
    }
                                        /* 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);
    if (assign == ':')
        dremove(qname);
    else
        dclear(qname);
    dpush(qname, ep1);
}


void
dclear(                 /* delete variable definitions of name */
        char  *name
)
{
    VARDEF  *vp;
    EPNODE  *dp;

    while ((vp = varlookup(name)) != NULL &&
                (dp = vp->def) != NULL && dp->type == '=') {
        vp->def = dp->sibling;
        epfree(dp,1);
        varfree(vp);
    }
}


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

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


int
vardefined(     /* return '=' or ':' if variable/constant defined */
        char  *name
)
{
    EPNODE  *dp = dlookup(name);

    if (dp == NULL || dp->v.kid->type != SYM)
        return(0);

    return(dp->type);
}


char *
calcontext(                     /* set a new context path */
        char  *ctx
)
{
    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(            /* push on another context */
        char  *ctx
)
{
    char  oldcontext[MAXCNTX+1];
    int  n;

    strcpy(oldcontext, context);        /* save old context */
    calcontext(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(void)                        /* pop off top context */
{
    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(               /* get qualified name */
        char  *nam,
        int  lvl
)
{
    static char  nambuf[RMAXWORD+1];
    char  *cp = nambuf, *cpp;
                                /* check for explicit local */
    if (*nam == CNTXMARK) {
        if (lvl > 0)            /* only action is to refuse search */
            return(NULL);
        nam++;
    } else if (nam == nambuf)   /* check for repeat call */
        return(lvl > 0 ? NULL : nam);
                                /* copy name to static buffer */
    while (*nam) {
        if (cp >= nambuf+RMAXWORD)
                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) {              /* add remaining context to name */
        if (cp >= nambuf+RMAXWORD)
            goto toolong;
        *cp++ = *cpp++;
    }
toolong:
    *cp = '\0';
    return(nambuf);             /* return qualified name */
}


int
incontext(                      /* is qualified name in current context? */
        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(                        /* set output channels */
        void  (*cs)(int n, double v)
)
{
    EPNODE  *ep;

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

}


void
doptimize(int activate)         /* optimize current and future definitions? */
{
    EPNODE      *ep;

    if (activate && optimized)
        return;                 /* already going */

    if (!(optimized = activate))
        return;                 /* switching off */

    for (ep = dfirst(); ep != NULL; ep = dnext())
        epoptimize(ep);
}


void
dcleanup(               /* clear definitions (0->vars,1->output,2->consts) */
        int  lvl
)
{
    int  i;
    VARDEF  *vp;
    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)
        while (outchan != NULL) {
            ep = outchan;
            outchan = ep->sibling;
            epfree(ep,1);
        }
}


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


VARDEF *
varlookup(                      /* look up a variable */
        char  *name
)
{
    int  lvl = 0;
    char  *qname;
    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(                      /* get a link to a variable */
        char  *name
)
{
    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(                      /* update library links */
        char  *fn
)
{
    int  i;
    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(                                /* release link to variable */
        VARDEF   *ln
)
{
    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(ln);
}


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


EPNODE *
dnext(void)                             /* return pointer to next definition */
{
    EPNODE  *ep;
    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(                   /* pop a definition */
        char  *name
)
{
    VARDEF  *vp;
    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(                  /* push on a definition */
        char  *nm,
        EPNODE   *ep
)
{
    VARDEF  *vp;

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


void
addchan(                        /* add an output channel assignment */
        EPNODE  *sp
)
{
    int  ch = sp->v.kid->v.chan;
    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,1);
            }
            return;
        }
    if (epl != NULL)
        epl->sibling = sp;
    else
        outchan = sp;
    sp->sibling = NULL;

}


void
getstatement(void)                      /* get next statement */
{
    EPNODE  *ep;
    char  *qname;
    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(dfn_name(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();
    }
    if (optimized)
        epoptimize(ep);                 /* optimize new statement */
}


EPNODE *
getdefn(void)
        /* A -> SYM = E1 */
        /*      SYM : E1 */
        /*      FUNC(SYM,..) = E1 */
        /*      FUNC(SYM,..) : E1 */
{
    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 parameter name");
            ep2 = newnode();
            ep2->type = SYM;
            ep2->v.name = savestr(getname());
            if (strchr(ep2->v.name, CNTXMARK) != NULL)
                syntax("illegal parameter name");
            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 = CLKT;
        ep1->v.tick = 0;
        addekid(ep2, ep1);
        ep1 = newnode();
        ep1->type = NUM;
        addekid(ep2, ep1);
    }
    curfunc = NULL;

    return(ep2);
}


EPNODE *
getchan(void)                   /* A -> $N = E1 */
{
    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                   /* evaluate a variable */
dvalue(char *name, EPNODE *d)
{
    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 */
    if (esupport&E_RCONST && d->type == ':') {
        wputs(name);
        wputs(": assigned non-constant value\n");
    }
    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.38
Committed:	Fri Feb 23 03:47:57 2024 UTC (2 months, 3 weeks ago) by greg
Content type:	text/plain
Branch:	MAIN
CVS Tags:	HEAD
Changes since 2.37:	+25 -6 lines
Log Message:	perf: Added array index optimization to calcomp routines
#	User	Rev	Content
1	greg	1.1	#ifndef lint
2	greg	2.38	static const char RCSid[] = "$Id: caldefn.c,v 2.37 2023/10/01 18:02:23 greg Exp $";
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	greg	2.13	#include "copyright.h"
29	greg	1.1
30			#include <ctype.h>
31
32	schorsch	2.18	#include "rterror.h"
33	schorsch	2.22	#include "rtio.h"
34	schorsch	2.21	#include "rtmisc.h"
35	greg	1.1	#include "calcomp.h"
36
37	greg	2.4	#ifndef NHASH
38			#define NHASH 521 /* hash size (a prime!) */
39	greg	1.1	#endif
40
41	greg	2.5	#define hash(s) (shash(s)%NHASH)
42
43	greg	2.4	#define newnode() (EPNODE *)ecalloc(1, sizeof(EPNODE))
44	greg	1.1
45	schorsch	2.18	static double dvalue(char name, EPNODE d);
46	greg	1.1
47	greg	2.12	#define MAXCLOCK (1L<<31) /* clock wrap value */
48	greg	1.1
49	greg	2.8	unsigned long eclock = 0; /* value storage timer */
50	greg	1.1
51	greg	2.11	#define MAXCNTX 1023 /* maximum context length */
52	greg	1.13
53	greg	2.11	static char context[MAXCNTX+1]; /* current context path */
54
55	greg	1.1	static VARDEF hashtbl[NHASH]; / definition list */
56			static int htndx; /* index for */
57			static VARDEF htpos; / ...dfirst() and */
58			static EPNODE ochpos; / ...dnext */
59			static EPNODE *outchan;
60
61	greg	2.38	static int optimized = 0; /* are we optimized? */
62
63	greg	2.10	EPNODE *curfunc = NULL;
64	greg	1.1
65
66	greg	2.12	void
67	schorsch	2.16	fcompile( /* get definitions from a file */
68			char *fname
69			)
70	greg	1.1	{
71			FILE *fp;
72
73			if (fname == NULL)
74			fp = stdin;
75			else if ((fp = fopen(fname, "r")) == NULL) {
76			eputs(fname);
77			eputs(": cannot open\n");
78			quit(1);
79			}
80	greg	2.34	#ifdef getc_unlocked /* avoid stupid semaphores */
81			flockfile(fp);
82			#endif
83			initfile(fp, fname, 0);
84	greg	1.1	while (nextc != EOF)
85	greg	1.13	getstatement();
86	greg	1.1	if (fname != NULL)
87			fclose(fp);
88	greg	2.34	#ifdef getc_unlocked
89			else
90			funlockfile(fp);
91			#endif
92	greg	1.1	}
93
94
95	greg	2.12	void
96	schorsch	2.16	scompile( /* get definitions from a string */
97			char *str,
98			char *fn,
99			int ln
100			)
101	greg	1.1	{
102	greg	1.4	initstr(str, fn, ln);
103	greg	1.1	while (nextc != EOF)
104	greg	1.13	getstatement();
105	greg	1.1	}
106
107
108			double
109	schorsch	2.16	varvalue( /* return a variable's value */
110			char *vname
111			)
112	greg	1.1	{
113			return(dvalue(vname, dlookup(vname)));
114			}
115
116
117			double
118	schorsch	2.16	evariable( /* evaluate a variable */
119			EPNODE *ep
120			)
121	greg	1.1	{
122	greg	2.25	VARDEF *dp = ep->v.ln;
123	greg	1.1
124			return(dvalue(dp->name, dp->def));
125			}
126
127
128	greg	2.12	void
129	schorsch	2.16	varset( /* set a variable's value */
130			char *vname,
131			int assign,
132			double val
133			)
134	greg	1.1	{
135	greg	1.13	char *qname;
136	greg	2.25	EPNODE ep1, ep2;
137	greg	1.13	/* get qualified name */
138			qname = qualname(vname, 0);
139	greg	1.1	/* check for quick set */
140	greg	2.25	if ((ep1 = dlookup(qname)) != NULL && ep1->v.kid->type == SYM &&
141			(ep1->type == ':') <= (assign == ':')) {
142	greg	1.1	ep2 = ep1->v.kid->sibling;
143			if (ep2->type == NUM) {
144			ep2->v.num = val;
145	greg	1.8	ep1->type = assign;
146	greg	1.1	return;
147			}
148			}
149	greg	2.26	if (ep1 != NULL && esupport&E_REDEFW) {
150			wputs(qname);
151			if (ep1->type == ':')
152			wputs(": reset constant expression\n");
153			else
154			wputs(": reset expression\n");
155			}
156	greg	1.1	/* hand build definition */
157			ep1 = newnode();
158	greg	1.8	ep1->type = assign;
159	greg	1.1	ep2 = newnode();
160			ep2->type = SYM;
161			ep2->v.name = savestr(vname);
162			addekid(ep1, ep2);
163			ep2 = newnode();
164			ep2->type = NUM;
165			ep2->v.num = val;
166			addekid(ep1, ep2);
167	greg	2.25	if (assign == ':')
168			dremove(qname);
169			else
170			dclear(qname);
171	greg	1.13	dpush(qname, ep1);
172	greg	1.1	}
173
174
175	greg	2.12	void
176	schorsch	2.16	dclear( /* delete variable definitions of name */
177			char *name
178			)
179	greg	1.1	{
180	greg	2.37	VARDEF *vp;
181			EPNODE *dp;
182	greg	1.1
183	greg	2.37	while ((vp = varlookup(name)) != NULL &&
184			(dp = vp->def) != NULL && dp->type == '=') {
185			vp->def = dp->sibling;
186	greg	2.38	epfree(dp,1);
187	greg	2.37	varfree(vp);
188	greg	1.8	}
189			}
190
191
192	greg	2.12	void
193	schorsch	2.16	dremove( /* delete all definitions of name */
194			char *name
195			)
196	greg	1.8	{
197	greg	2.25	EPNODE *ep;
198	greg	1.8
199	greg	1.1	while ((ep = dpop(name)) != NULL)
200	greg	2.38	epfree(ep,1);
201	greg	1.1	}
202
203
204	greg	2.12	int
205	greg	2.30	vardefined( /* return '=' or ':' if variable/constant defined */
206	schorsch	2.16	char *name
207			)
208	greg	1.1	{
209	greg	2.31	EPNODE *dp = dlookup(name);
210	greg	1.1
211	greg	2.31	if (dp == NULL \|\| dp->v.kid->type != SYM)
212	greg	2.30	return(0);
213	greg	2.31
214	greg	2.30	return(dp->type);
215	greg	1.1	}
216
217
218	greg	1.13	char *
219	greg	2.32	calcontext( /* set a new context path */
220	greg	2.25	char *ctx
221	schorsch	2.16	)
222	greg	1.13	{
223	greg	2.25	char *cpp;
224	greg	1.13
225			if (ctx == NULL)
226			return(context); /* just asking */
227	greg	2.6	while (*ctx == CNTXMARK)
228			ctx++; /* skip past marks */
229	greg	1.13	if (!*ctx) {
230	greg	2.6	context[0] = '\0'; /* empty means clear context */
231	greg	1.13	return(context);
232			}
233	greg	2.6	cpp = context; /* start context with mark */
234			*cpp++ = CNTXMARK;
235			do { /* carefully copy new context */
236	greg	2.11	if (cpp >= context+MAXCNTX)
237	greg	1.18	break; /* just copy what we can */
238	greg	1.13	if (isid(*ctx))
239			cpp++ = ctx++;
240			else {
241			*cpp++ = '_'; ctx++;
242			}
243			} while (*ctx);
244	greg	2.6	while (cpp[-1] == CNTXMARK) /* cannot end in context mark */
245			cpp--;
246	greg	1.13	*cpp = '\0';
247	greg	2.6	return(context);
248			}
249
250
251			char *
252	schorsch	2.16	pushcontext( /* push on another context */
253			char *ctx
254			)
255	greg	2.6	{
256	greg	2.11	char oldcontext[MAXCNTX+1];
257	greg	2.25	int n;
258	greg	2.6
259			strcpy(oldcontext, context); /* save old context */
260	greg	2.32	calcontext(ctx); /* set new context */
261	greg	2.6	n = strlen(context); /* tack on old */
262	greg	2.11	if (n+strlen(oldcontext) > MAXCNTX) {
263			strncpy(context+n, oldcontext, MAXCNTX-n);
264			context[MAXCNTX] = '\0';
265	greg	2.6	} else
266			strcpy(context+n, oldcontext);
267			return(context);
268			}
269
270
271			char *
272	schorsch	2.16	popcontext(void) /* pop off top context */
273	greg	2.6	{
274	greg	2.25	char cp1, cp2;
275	greg	2.6
276			if (!context[0]) /* nothing left to pop */
277			return(context);
278			cp2 = context; /* find mark */
279			while (++cp2 && cp2 != CNTXMARK)
280			;
281			cp1 = context; /* copy tail to front */
282	schorsch	2.20	while ( (cp1++ = cp2++) )
283	greg	2.6	;
284	greg	1.13	return(context);
285			}
286
287
288			char *
289	schorsch	2.16	qualname( /* get qualified name */
290	greg	2.25	char *nam,
291	schorsch	2.16	int lvl
292			)
293	greg	1.13	{
294	schorsch	2.17	static char nambuf[RMAXWORD+1];
295	greg	2.25	char cp = nambuf, cpp;
296	greg	1.17	/* check for explicit local */
297	greg	2.36	if (*nam == CNTXMARK) {
298	greg	1.17	if (lvl > 0) /* only action is to refuse search */
299			return(NULL);
300	greg	2.36	nam++;
301			} else if (nam == nambuf) /* check for repeat call */
302	greg	1.17	return(lvl > 0 ? NULL : nam);
303	greg	1.13	/* copy name to static buffer */
304			while (*nam) {
305	schorsch	2.17	if (cp >= nambuf+RMAXWORD)
306	greg	1.13	goto toolong;
307	greg	1.17	cp++ = nam++;
308	greg	1.13	}
309	greg	1.17	/* check for explicit global */
310			if (cp > nambuf && cp[-1] == CNTXMARK) {
311	greg	1.13	if (lvl > 0)
312	greg	1.17	return(NULL);
313			*--cp = '\0';
314			return(nambuf); /* already qualified */
315			}
316			cpp = context; /* else skip the requested levels */
317			while (lvl-- > 0) {
318			if (!*cpp)
319			return(NULL); /* return NULL if past global level */
320			while (++cpp && cpp != CNTXMARK)
321			;
322			}
323	greg	2.37	while (cpp) { / add remaining context to name */
324	schorsch	2.17	if (cp >= nambuf+RMAXWORD)
325	greg	1.13	goto toolong;
326			cp++ = cpp++;
327			}
328	greg	1.18	toolong:
329	greg	1.13	*cp = '\0';
330			return(nambuf); /* return qualified name */
331			}
332
333
334	greg	2.12	int
335	schorsch	2.16	incontext( /* is qualified name in current context? */
336	greg	2.25	char *qn
337	schorsch	2.16	)
338	greg	1.14	{
339	greg	2.9	if (!context[0]) /* global context accepts all */
340			return(1);
341	greg	1.14	while (qn && qn != CNTXMARK) /* find context mark */
342	greg	1.19	qn++;
343	greg	1.14	return(!strcmp(qn, context));
344			}
345
346
347	greg	2.12	void
348	schorsch	2.16	chanout( /* set output channels */
349			void (*cs)(int n, double v)
350			)
351	greg	1.1	{
352	greg	2.25	EPNODE *ep;
353	greg	1.1
354			for (ep = outchan; ep != NULL; ep = ep->sibling)
355	greg	1.6	(*cs)(ep->v.kid->v.chan, evalue(ep->v.kid->sibling));
356	greg	1.1
357			}
358
359
360	greg	2.12	void
361	greg	2.38	doptimize(int activate) /* optimize current and future definitions? */
362			{
363			EPNODE *ep;
364
365			if (activate && optimized)
366			return; /* already going */
367
368			if (!(optimized = activate))
369			return; /* switching off */
370
371			for (ep = dfirst(); ep != NULL; ep = dnext())
372			epoptimize(ep);
373			}
374
375
376			void
377	schorsch	2.16	dcleanup( /* clear definitions (0->vars,1->output,2->consts) */
378			int lvl
379			)
380	greg	1.1	{
381	greg	2.25	int i;
382			VARDEF *vp;
383			EPNODE *ep;
384	greg	1.14	/* if context is global, clear all */
385	greg	1.1	for (i = 0; i < NHASH; i++)
386			for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
387	schorsch	2.19	if (incontext(vp->name)) {
388	greg	1.14	if (lvl >= 2)
389			dremove(vp->name);
390			else
391			dclear(vp->name);
392	schorsch	2.19	}
393	greg	2.35	if (lvl >= 1)
394			while (outchan != NULL) {
395			ep = outchan;
396			outchan = ep->sibling;
397	greg	2.38	epfree(ep,1);
398	greg	2.35	}
399	greg	1.1	}
400
401
402			EPNODE *
403	schorsch	2.16	dlookup( /* look up a definition */
404			char *name
405			)
406	greg	1.1	{
407	greg	2.25	VARDEF *vp;
408	greg	1.1
409			if ((vp = varlookup(name)) == NULL)
410	greg	2.4	return(NULL);
411	greg	1.1	return(vp->def);
412			}
413
414
415			VARDEF *
416	schorsch	2.16	varlookup( /* look up a variable */
417			char *name
418			)
419	greg	1.1	{
420	greg	2.4	int lvl = 0;
421	greg	2.25	char *qname;
422			VARDEF *vp;
423	greg	2.4	/* find most qualified match */
424	greg	1.13	while ((qname = qualname(name, lvl++)) != NULL)
425			for (vp = hashtbl[hash(qname)]; vp != NULL; vp = vp->next)
426			if (!strcmp(vp->name, qname))
427			return(vp);
428	greg	1.1	return(NULL);
429			}
430
431
432			VARDEF *
433	schorsch	2.16	varinsert( /* get a link to a variable */
434			char *name
435			)
436	greg	1.1	{
437	greg	2.25	VARDEF *vp;
438	greg	2.4	int hv;
439	greg	1.1
440	greg	1.13	if ((vp = varlookup(name)) != NULL) {
441			vp->nlinks++;
442			return(vp);
443			}
444	greg	2.3	vp = (VARDEF *)emalloc(sizeof(VARDEF));
445			vp->lib = liblookup(name);
446			if (vp->lib == NULL) /* if name not in library */
447	greg	1.16	name = qualname(name, 0); /* use fully qualified version */
448	greg	1.1	hv = hash(name);
449			vp->name = savestr(name);
450			vp->nlinks = 1;
451			vp->def = NULL;
452			vp->next = hashtbl[hv];
453			hashtbl[hv] = vp;
454			return(vp);
455			}
456	greg	2.2
457
458	greg	2.12	void
459	schorsch	2.16	libupdate( /* update library links */
460			char *fn
461			)
462	greg	2.2	{
463	greg	2.25	int i;
464			VARDEF *vp;
465	greg	2.2	/* if fn is NULL then relink all */
466			for (i = 0; i < NHASH; i++)
467			for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
468	greg	2.33	if ((vp->lib != NULL) \| (fn == NULL) \|\| !strcmp(fn, vp->name))
469	greg	2.2	vp->lib = liblookup(vp->name);
470			}
471	greg	1.1
472
473	greg	2.12	void
474	schorsch	2.16	varfree( /* release link to variable */
475	greg	2.25	VARDEF *ln
476	schorsch	2.16	)
477	greg	1.1	{
478	greg	2.25	VARDEF *vp;
479	greg	2.4	int hv;
480	greg	1.1
481			if (--ln->nlinks > 0)
482	greg	2.4	return; /* still active */
483	greg	1.1
484			hv = hash(ln->name);
485			vp = hashtbl[hv];
486			if (vp == ln)
487	greg	2.4	hashtbl[hv] = vp->next;
488	greg	1.1	else {
489	greg	2.4	while (vp->next != ln) /* must be in list */
490			vp = vp->next;
491			vp->next = ln->next;
492	greg	1.1	}
493			freestr(ln->name);
494	greg	2.35	efree(ln);
495	greg	1.1	}
496
497
498			EPNODE *
499	schorsch	2.16	dfirst(void) /* return pointer to first definition */
500	greg	1.1	{
501			htndx = 0;
502			htpos = NULL;
503			ochpos = outchan;
504			return(dnext());
505			}
506
507
508			EPNODE *
509	schorsch	2.16	dnext(void) /* return pointer to next definition */
510	greg	1.1	{
511	greg	2.25	EPNODE *ep;
512			char *nm;
513	greg	1.1
514			while (htndx < NHASH) {
515	greg	2.4	if (htpos == NULL)
516			htpos = hashtbl[htndx++];
517			while (htpos != NULL) {
518			ep = htpos->def;
519	greg	1.19	nm = htpos->name;
520	greg	2.4	htpos = htpos->next;
521			if (ep != NULL && incontext(nm))
522			return(ep);
523			}
524	greg	1.1	}
525			if ((ep = ochpos) != NULL)
526	greg	2.4	ochpos = ep->sibling;
527	greg	1.1	return(ep);
528			}
529
530
531			EPNODE *
532	schorsch	2.16	dpop( /* pop a definition */
533			char *name
534			)
535	greg	1.1	{
536	greg	2.25	VARDEF *vp;
537			EPNODE *dp;
538	greg	1.1
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	schorsch	2.16	dpush( /* push on a definition */
550			char *nm,
551	greg	2.25	EPNODE *ep
552	schorsch	2.16	)
553	greg	1.1	{
554	greg	2.25	VARDEF *vp;
555	greg	1.1
556	greg	1.13	vp = varinsert(nm);
557	greg	1.1	ep->sibling = vp->def;
558			vp->def = ep;
559			}
560
561
562	greg	2.12	void
563	schorsch	2.16	addchan( /* add an output channel assignment */
564			EPNODE *sp
565			)
566	greg	1.1	{
567	greg	2.4	int ch = sp->v.kid->v.chan;
568	greg	2.25	EPNODE ep, epl;
569	greg	1.1
570			for (epl = NULL, ep = outchan; ep != NULL; epl = ep, ep = ep->sibling)
571			if (ep->v.kid->v.chan >= ch) {
572			if (epl != NULL)
573			epl->sibling = sp;
574			else
575			outchan = sp;
576			if (ep->v.kid->v.chan > ch)
577			sp->sibling = ep;
578			else {
579			sp->sibling = ep->sibling;
580	greg	2.38	epfree(ep,1);
581	greg	1.1	}
582			return;
583			}
584			if (epl != NULL)
585			epl->sibling = sp;
586			else
587			outchan = sp;
588			sp->sibling = NULL;
589
590			}
591
592
593	greg	2.12	void
594	schorsch	2.16	getstatement(void) /* get next statement */
595	greg	1.1	{
596	greg	2.25	EPNODE *ep;
597	greg	1.13	char *qname;
598	greg	2.25	VARDEF *vdef;
599	greg	1.1
600			if (nextc == ';') { /* empty statement */
601			scan();
602			return;
603			}
604	greg	2.12	if (esupport&E_OUTCHAN &&
605			nextc == '$') { /* channel assignment */
606	greg	1.1	ep = getchan();
607			addchan(ep);
608	greg	2.12	} else { /* ordinary definition */
609	greg	1.1	ep = getdefn();
610	greg	2.36	qname = qualname(dfn_name(ep), 0);
611	schorsch	2.19	if (esupport&E_REDEFW && (vdef = varlookup(qname)) != NULL) {
612	greg	2.7	if (vdef->def != NULL && epcmp(ep, vdef->def)) {
613	greg	1.16	wputs(qname);
614			if (vdef->def->type == ':')
615			wputs(": redefined constant expression\n");
616			else
617			wputs(": redefined\n");
618	greg	2.12	} else if (ep->v.kid->type == FUNC && vdef->lib != NULL) {
619	greg	1.16	wputs(qname);
620			wputs(": definition hides library function\n");
621			}
622	schorsch	2.19	}
623	greg	1.10	if (ep->type == ':')
624	greg	1.13	dremove(qname);
625	greg	1.10	else
626	greg	1.13	dclear(qname);
627			dpush(qname, ep);
628	greg	1.1	}
629			if (nextc != EOF) {
630			if (nextc != ';')
631			syntax("';' expected");
632			scan();
633			}
634	greg	2.38	if (optimized)
635			epoptimize(ep); /* optimize new statement */
636	greg	1.1	}
637
638
639			EPNODE *
640	schorsch	2.16	getdefn(void)
641			/* A -> SYM = E1 */
642			/* SYM : E1 */
643			/* FUNC(SYM,..) = E1 */
644			/* FUNC(SYM,..) : E1 */
645	greg	1.1	{
646	greg	2.25	EPNODE ep1, ep2;
647	greg	1.1
648	greg	2.33	if (!isalpha(nextc) & (nextc != CNTXMARK))
649	greg	1.1	syntax("illegal variable name");
650
651			ep1 = newnode();
652			ep1->type = SYM;
653			ep1->v.name = savestr(getname());
654
655	greg	2.12	if (esupport&E_FUNCTION && nextc == '(') {
656	greg	1.1	ep2 = newnode();
657			ep2->type = FUNC;
658			addekid(ep2, ep1);
659			ep1 = ep2;
660			do {
661			scan();
662			if (!isalpha(nextc))
663	greg	2.24	syntax("illegal parameter name");
664	greg	1.1	ep2 = newnode();
665			ep2->type = SYM;
666			ep2->v.name = savestr(getname());
667	greg	2.29	if (strchr(ep2->v.name, CNTXMARK) != NULL)
668			syntax("illegal parameter name");
669	greg	1.1	addekid(ep1, ep2);
670			} while (nextc == ',');
671			if (nextc != ')')
672			syntax("')' expected");
673			scan();
674			curfunc = ep1;
675	greg	2.10	}
676	greg	1.1
677	greg	2.33	if ((nextc != '=') & (nextc != ':'))
678	greg	1.8	syntax("'=' or ':' expected");
679	greg	1.1
680			ep2 = newnode();
681	greg	1.8	ep2->type = nextc;
682			scan();
683	greg	1.1	addekid(ep2, ep1);
684			addekid(ep2, getE1());
685
686	greg	2.12	if (ep1->type == SYM && ep1->sibling->type != NUM) {
687	greg	1.1	ep1 = newnode();
688	greg	2.23	ep1->type = CLKT;
689	greg	2.8	ep1->v.tick = 0;
690	greg	1.1	addekid(ep2, ep1);
691			ep1 = newnode();
692			ep1->type = NUM;
693			addekid(ep2, ep1);
694			}
695	greg	2.10	curfunc = NULL;
696	greg	1.1
697			return(ep2);
698			}
699
700
701			EPNODE *
702	schorsch	2.16	getchan(void) /* A -> $N = E1 */
703	greg	1.1	{
704	greg	2.25	EPNODE ep1, ep2;
705	greg	1.1
706			if (nextc != '$')
707			syntax("missing '$'");
708			scan();
709
710			ep1 = newnode();
711			ep1->type = CHAN;
712			ep1->v.chan = getinum();
713
714			if (nextc != '=')
715			syntax("'=' expected");
716			scan();
717
718			ep2 = newnode();
719			ep2->type = '=';
720			addekid(ep2, ep1);
721			addekid(ep2, getE1());
722
723			return(ep2);
724			}
725
726
727
728			/*
729			* The following routines are for internal use only:
730			*/
731
732
733	schorsch	2.18	static double /* evaluate a variable */
734	greg	2.28	dvalue(char name, EPNODE d)
735	greg	1.1	{
736	greg	2.25	EPNODE ep1, ep2;
737	greg	1.1
738			if (d == NULL \|\| d->v.kid->type != SYM) {
739			eputs(name);
740			eputs(": undefined variable\n");
741			quit(1);
742			}
743			ep1 = d->v.kid->sibling; /* get expression */
744	greg	1.5	if (ep1->type == NUM)
745			return(ep1->v.num); /* return if number */
746	greg	2.28	if (esupport&E_RCONST && d->type == ':') {
747			wputs(name);
748			wputs(": assigned non-constant value\n");
749			}
750	greg	1.1	ep2 = ep1->sibling; /* check time */
751	greg	2.12	if (eclock >= MAXCLOCK)
752			eclock = 1; /* wrap clock counter */
753			if (ep2->v.tick < MAXCLOCK &&
754	schorsch	2.20	(ep2->v.tick == 0) \| (ep2->v.tick != eclock)) {
755	greg	2.12	ep2->v.tick = d->type == ':' ? MAXCLOCK : eclock;
756	greg	1.1	ep2 = ep2->sibling;
757	greg	1.5	ep2->v.num = evalue(ep1); /* needs new value */
758	greg	1.1	} else
759	greg	1.5	ep2 = ep2->sibling; /* else reuse old value */
760	greg	1.1
761			return(ep2->v.num);
762			}