src/common/caldefn.c

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

#ifndef lint
static char SCCSid[] = "$SunId$ LBL";
#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
 */

#include  <stdio.h>

#include  <ctype.h>

#include  "calcomp.h"

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

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

extern char  *ecalloc(), *savestr(), *strcpy();

static double  dvalue();

long  eclock = -1;                      /* value storage timer */

static char  context[MAXWORD];          /* current context path */

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

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


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


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


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


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


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

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


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 */
    if (!*ctx) {
        context[0] = '\0';              /* clear context */
        return(context);
    }
    cpp = context;                      /* else copy it (carefully!) */
    if (*ctx != CNTXMARK)
        *cpp++ = CNTXMARK;              /* make sure there's a mark */
    do {
        if (cpp >= context+MAXWORD-1) {
            *cpp = '\0';
            wputs(context);
            wputs(": context path too long\n");
            return(NULL);
        }
        if (isid(*ctx))
            *cpp++ = *ctx++;
        else {
            *cpp++ = '_'; ctx++;
        }
    } while (*ctx);
    *cpp = '\0';
    return(context);
}


char *
qualname(nam, lvl)              /* get qualified name */
register char  *nam;
int  lvl;
{
    static char  nambuf[MAXWORD];
    register char  *cp = nambuf, *cpp = context;
                                /* check for repeat call */
    if (nam == nambuf)
        return(lvl > 0 ? NULL : nambuf);
                                /* copy name to static buffer */
    while (*nam) {
        if (cp >= nambuf+MAXWORD-1)
                goto toolong;
        if ((*cp++ = *nam++) == CNTXMARK)
            cpp = NULL;         /* flag a qualified name */
    }
    if (cpp == NULL) {
        if (lvl > 0)
            return(NULL);               /* no higher level */
        if (cp[-1] == CNTXMARK) {
            cp--; cpp = context;        /* current context explicitly */
        } else
            cpp = "";                   /* else fully qualified */
    } else                      /* 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-1)
            goto toolong;
        *cp++ = *cpp++;
    }
    *cp = '\0';
    return(nambuf);             /* return qualified name */
toolong:
    *cp = '\0';
    wputs(nambuf);
    wputs(": name too long\n");
    return(NULL);
}


#ifdef  OUTCHAN
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));

}
#endif


dcleanup(lvl)           /* clear definitions (0->vars,1->output,2->consts) */
int  lvl;
{
    register int  i;
    register VARDEF  *vp;
    register EPNODE  *ep;

    for (i = 0; i < NHASH; i++)
        for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
            if (lvl >= 2)
                dremove(vp->name);
            else
                dclear(vp->name);
#ifdef  OUTCHAN
    if (lvl >= 1) {
        for (ep = outchan; ep != NULL; ep = ep->sibling)
            epfree(ep);
        outchan = NULL;
    }
#endif
}


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);
    }
    name = qualname(name, 0);           /* use fully qualified name */
    hv = hash(name);
    vp = (VARDEF *)emalloc(sizeof(VARDEF));
    vp->name = savestr(name);
    vp->nlinks = 1;
    vp->def = NULL;
    vp->lib = NULL;
    vp->next = hashtbl[hv];
    hashtbl[hv] = vp;
    return(vp);
}


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;
#ifdef  OUTCHAN
    ochpos = outchan;
#endif
    return(dnext());
}


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

    while (htndx < NHASH) {
        if (htpos == NULL)
                htpos = hashtbl[htndx++];
        while (htpos != NULL) {
            ep = htpos->def;
            htpos = htpos->next;
            if (ep != NULL)
                return(ep);
        }
    }
#ifdef  OUTCHAN
    if ((ep = ochpos) != NULL)
        ochpos = ep->sibling;
    return(ep);
#else
    return(NULL);
#endif
}


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


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


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

}
#endif


getstatement()                  /* get next statement */
{
    register EPNODE  *ep;
    char  *qname;
    EPNODE  *lastdef;

    if (nextc == ';') {         /* empty statement */
        scan();
        return;
    }
#ifdef  OUTCHAN
    if (nextc == '$') {         /* channel assignment */
        ep = getchan();
        addchan(ep);
    } else
#endif
    {                           /* ordinary definition */
        ep = getdefn();
        qname = qualname(dname(ep), 0);
#ifdef  REDEFW
        if ((lastdef = dlookup(qname)) != NULL) {
            wputs(qname);
            if (lastdef->type == ':')
                wputs(": redefined constant expression\n");
            else
                wputs(": redefined\n");
        }
#ifdef  FUNCTION
        else if (ep->v.kid->type == FUNC && liblookup(qname) != NULL) {
            wputs(qname);
            wputs(": definition hides library function\n");
        }
#endif
#endif
        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))
        syntax("illegal variable name");

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

#ifdef  FUNCTION
    if (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;
    } else
        curfunc = NULL;
#endif

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

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

    if (
#ifdef  FUNCTION
            ep1->type == SYM &&
#endif
            ep1->sibling->type != NUM) {
        ep1 = newnode();
        ep1->type = TICK;
        ep1->v.tick = -1;
        addekid(ep2, ep1);
        ep1 = newnode();
        ep1->type = NUM;
        addekid(ep2, ep1);
    }

    return(ep2);
}


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


/*
 *  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 (ep2->v.tick < 0 || ep2->v.tick < eclock) {
        ep2->v.tick = d->type == ':' ? 1L<<30 : eclock;
        ep2 = ep2->sibling;
        ep2->v.num = evalue(ep1);               /* needs new value */
    } else
        ep2 = ep2->sibling;                     /* else reuse old value */

    return(ep2->v.num);
}


static int
hash(s)                         /* hash a string */
register char  *s;
{
    register int  rval = 0;

    while (*s)
        rval += *s++;
    
    return(rval % NHASH);
}
Revision:	1.13
Committed:	Thu Aug 8 11:22:06 1991 UTC (32 years, 8 months ago) by greg
Content type:	text/plain
Branch:	MAIN
Changes since 1.12:	+118 -27 lines
Log Message:	added contexts to definition naming
#	User	Rev	Content
1	greg	1.9	/* Copyright (c) 1991 Regents of the University of California */
2	greg	1.1
3			#ifndef lint
4			static char SCCSid[] = "$SunId$ LBL";
5			#endif
6
7			/*
8			* Store variable definitions.
9			*
10			* 7/1/85 Greg Ward
11			*
12			* 11/11/85 Added conditional compiles (OUTCHAN) for control output.
13			*
14			* 4/2/86 Added conditional compiles for function definitions (FUNCTION).
15			*
16			* 1/15/88 Added clock for caching of variable values.
17			*
18			* 11/16/88 Added VARDEF structure for hard linking.
19	greg	1.2	*
20			* 5/31/90 Added conditional compile (REDEFW) for redefinition warning.
21	greg	1.8	*
22	greg	1.10	* 4/23/91 Added ':' assignment for constant expressions
23	greg	1.13	*
24			* 8/7/91 Added optional context path to append to variable names
25	greg	1.1	*/
26
27			#include <stdio.h>
28
29			#include <ctype.h>
30
31			#include "calcomp.h"
32
33			#ifndef NHASH
34			#define NHASH 521 /* hash size (a prime!) */
35			#endif
36
37			#define newnode() (EPNODE *)ecalloc(1, sizeof(EPNODE))
38
39	greg	1.13	extern char ecalloc(), savestr(), *strcpy();
40	greg	1.1
41	greg	1.3	static double dvalue();
42	greg	1.1
43			long eclock = -1; /* value storage timer */
44
45	greg	1.13	static char context[MAXWORD]; /* current context path */
46
47	greg	1.1	static VARDEF hashtbl[NHASH]; / definition list */
48			static int htndx; /* index for */
49			static VARDEF htpos; / ...dfirst() and */
50			#ifdef OUTCHAN
51			static EPNODE ochpos; / ...dnext */
52			static EPNODE *outchan;
53			#endif
54
55			#ifdef FUNCTION
56			EPNODE *curfunc;
57			#define dname(ep) ((ep)->v.kid->type == SYM ? \
58			(ep)->v.kid->v.name : \
59			(ep)->v.kid->v.kid->v.name)
60			#else
61			#define dname(ep) ((ep)->v.kid->v.name)
62			#endif
63
64
65			fcompile(fname) /* get definitions from a file */
66			char *fname;
67			{
68			FILE *fp;
69
70			if (fname == NULL)
71			fp = stdin;
72			else if ((fp = fopen(fname, "r")) == NULL) {
73			eputs(fname);
74			eputs(": cannot open\n");
75			quit(1);
76			}
77	greg	1.4	initfile(fp, fname, 0);
78	greg	1.1	while (nextc != EOF)
79	greg	1.13	getstatement();
80	greg	1.1	if (fname != NULL)
81			fclose(fp);
82			}
83
84
85	greg	1.4	scompile(str, fn, ln) /* get definitions from a string */
86	greg	1.1	char *str;
87	greg	1.4	char *fn;
88			int ln;
89	greg	1.1	{
90	greg	1.4	initstr(str, fn, ln);
91	greg	1.1	while (nextc != EOF)
92	greg	1.13	getstatement();
93	greg	1.1	}
94
95
96			double
97			varvalue(vname) /* return a variable's value */
98			char *vname;
99			{
100			return(dvalue(vname, dlookup(vname)));
101			}
102
103
104			double
105			evariable(ep) /* evaluate a variable */
106			EPNODE *ep;
107			{
108			register VARDEF *dp = ep->v.ln;
109
110			return(dvalue(dp->name, dp->def));
111			}
112
113
114	greg	1.8	varset(vname, assign, val) /* set a variable's value */
115	greg	1.1	char *vname;
116	greg	1.8	int assign;
117	greg	1.1	double val;
118			{
119	greg	1.13	char *qname;
120	greg	1.1	register EPNODE ep1, ep2;
121	greg	1.13	/* get qualified name */
122			qname = qualname(vname, 0);
123	greg	1.1	/* check for quick set */
124	greg	1.13	if ((ep1 = dlookup(qname)) != NULL && ep1->v.kid->type == SYM) {
125	greg	1.1	ep2 = ep1->v.kid->sibling;
126			if (ep2->type == NUM) {
127			ep2->v.num = val;
128	greg	1.8	ep1->type = assign;
129	greg	1.1	return;
130			}
131			}
132			/* hand build definition */
133			ep1 = newnode();
134	greg	1.8	ep1->type = assign;
135	greg	1.1	ep2 = newnode();
136			ep2->type = SYM;
137			ep2->v.name = savestr(vname);
138			addekid(ep1, ep2);
139			ep2 = newnode();
140			ep2->type = NUM;
141			ep2->v.num = val;
142			addekid(ep1, ep2);
143	greg	1.13	dremove(qname);
144			dpush(qname, ep1);
145	greg	1.1	}
146
147
148	greg	1.8	dclear(name) /* delete variable definitions of name */
149	greg	1.1	char *name;
150			{
151			register EPNODE *ep;
152
153	greg	1.8	while ((ep = dpop(name)) != NULL) {
154			if (ep->type == ':') {
155	greg	1.13	dpush(name, ep); /* don't clear constants */
156	greg	1.8	return;
157			}
158			epfree(ep);
159			}
160			}
161
162
163			dremove(name) /* delete all definitions of name */
164			char *name;
165			{
166			register EPNODE *ep;
167
168	greg	1.1	while ((ep = dpop(name)) != NULL)
169			epfree(ep);
170			}
171
172
173			vardefined(name) /* return non-zero if variable defined */
174			char *name;
175			{
176			register EPNODE *dp;
177
178			return((dp = dlookup(name)) != NULL && dp->v.kid->type == SYM);
179			}
180
181
182	greg	1.13	char *
183			setcontext(ctx) /* set a new context path */
184			register char *ctx;
185			{
186			register char *cpp;
187
188			if (ctx == NULL)
189			return(context); /* just asking */
190			if (!*ctx) {
191			context[0] = '\0'; /* clear context */
192			return(context);
193			}
194			cpp = context; /* else copy it (carefully!) */
195			if (*ctx != CNTXMARK)
196			cpp++ = CNTXMARK; / make sure there's a mark */
197			do {
198			if (cpp >= context+MAXWORD-1) {
199			*cpp = '\0';
200			wputs(context);
201			wputs(": context path too long\n");
202			return(NULL);
203			}
204			if (isid(*ctx))
205			cpp++ = ctx++;
206			else {
207			*cpp++ = '_'; ctx++;
208			}
209			} while (*ctx);
210			*cpp = '\0';
211			return(context);
212			}
213
214
215			char *
216			qualname(nam, lvl) /* get qualified name */
217			register char *nam;
218			int lvl;
219			{
220			static char nambuf[MAXWORD];
221			register char cp = nambuf, cpp = context;
222			/* check for repeat call */
223			if (nam == nambuf)
224			return(lvl > 0 ? NULL : nambuf);
225			/* copy name to static buffer */
226			while (*nam) {
227			if (cp >= nambuf+MAXWORD-1)
228			goto toolong;
229			if ((cp++ = nam++) == CNTXMARK)
230			cpp = NULL; /* flag a qualified name */
231			}
232			if (cpp == NULL) {
233			if (lvl > 0)
234			return(NULL); /* no higher level */
235			if (cp[-1] == CNTXMARK) {
236			cp--; cpp = context; /* current context explicitly */
237			} else
238			cpp = ""; /* else fully qualified */
239			} else /* else skip the requested levels */
240			while (lvl-- > 0) {
241			if (!*cpp)
242			return(NULL); /* return NULL if past global level */
243			while (++cpp && cpp != CNTXMARK)
244			;
245			}
246			while (cpp) { / copy context to static buffer */
247			if (cp >= nambuf+MAXWORD-1)
248			goto toolong;
249			cp++ = cpp++;
250			}
251			*cp = '\0';
252			return(nambuf); /* return qualified name */
253			toolong:
254			*cp = '\0';
255			wputs(nambuf);
256			wputs(": name too long\n");
257			return(NULL);
258			}
259
260
261	greg	1.1	#ifdef OUTCHAN
262	greg	1.6	chanout(cs) /* set output channels */
263			int (*cs)();
264	greg	1.1	{
265			register EPNODE *ep;
266
267			for (ep = outchan; ep != NULL; ep = ep->sibling)
268	greg	1.6	(*cs)(ep->v.kid->v.chan, evalue(ep->v.kid->sibling));
269	greg	1.1
270			}
271			#endif
272
273
274	greg	1.12	dcleanup(lvl) /* clear definitions (0->vars,1->output,2->consts) */
275	greg	1.10	int lvl;
276	greg	1.1	{
277			register int i;
278			register VARDEF *vp;
279			register EPNODE *ep;
280
281			for (i = 0; i < NHASH; i++)
282			for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
283	greg	1.12	if (lvl >= 2)
284	greg	1.9	dremove(vp->name);
285			else
286			dclear(vp->name);
287	greg	1.1	#ifdef OUTCHAN
288	greg	1.12	if (lvl >= 1) {
289	greg	1.9	for (ep = outchan; ep != NULL; ep = ep->sibling)
290			epfree(ep);
291			outchan = NULL;
292			}
293	greg	1.1	#endif
294			}
295
296
297			EPNODE *
298			dlookup(name) /* look up a definition */
299			char *name;
300			{
301			register VARDEF *vp;
302
303			if ((vp = varlookup(name)) == NULL)
304			return(NULL);
305			return(vp->def);
306			}
307
308
309			VARDEF *
310			varlookup(name) /* look up a variable */
311			char *name;
312			{
313	greg	1.13	int lvl = 0;
314			register char *qname;
315	greg	1.1	register VARDEF *vp;
316	greg	1.13	/* find most qualified match */
317			while ((qname = qualname(name, lvl++)) != NULL)
318			for (vp = hashtbl[hash(qname)]; vp != NULL; vp = vp->next)
319			if (!strcmp(vp->name, qname))
320			return(vp);
321	greg	1.1	return(NULL);
322			}
323
324
325			VARDEF *
326			varinsert(name) /* get a link to a variable */
327			char *name;
328			{
329			register VARDEF *vp;
330			int hv;
331
332	greg	1.13	if ((vp = varlookup(name)) != NULL) {
333			vp->nlinks++;
334			return(vp);
335			}
336			name = qualname(name, 0); /* use fully qualified name */
337	greg	1.1	hv = hash(name);
338			vp = (VARDEF *)emalloc(sizeof(VARDEF));
339			vp->name = savestr(name);
340			vp->nlinks = 1;
341			vp->def = NULL;
342			vp->lib = NULL;
343			vp->next = hashtbl[hv];
344			hashtbl[hv] = vp;
345			return(vp);
346			}
347
348
349			varfree(ln) /* release link to variable */
350			register VARDEF *ln;
351			{
352			register VARDEF *vp;
353			int hv;
354
355			if (--ln->nlinks > 0)
356			return; /* still active */
357
358			hv = hash(ln->name);
359			vp = hashtbl[hv];
360			if (vp == ln)
361			hashtbl[hv] = vp->next;
362			else {
363			while (vp->next != ln) /* must be in list */
364			vp = vp->next;
365			vp->next = ln->next;
366			}
367			freestr(ln->name);
368			efree((char *)ln);
369			}
370
371
372			EPNODE *
373			dfirst() /* return pointer to first definition */
374			{
375			htndx = 0;
376			htpos = NULL;
377			#ifdef OUTCHAN
378			ochpos = outchan;
379			#endif
380			return(dnext());
381			}
382
383
384			EPNODE *
385			dnext() /* return pointer to next definition */
386			{
387			register EPNODE *ep;
388
389			while (htndx < NHASH) {
390			if (htpos == NULL)
391			htpos = hashtbl[htndx++];
392			while (htpos != NULL) {
393			ep = htpos->def;
394			htpos = htpos->next;
395			if (ep != NULL)
396			return(ep);
397			}
398			}
399			#ifdef OUTCHAN
400			if ((ep = ochpos) != NULL)
401			ochpos = ep->sibling;
402			return(ep);
403			#else
404			return(NULL);
405			#endif
406			}
407
408
409			EPNODE *
410			dpop(name) /* pop a definition */
411			char *name;
412			{
413			register VARDEF *vp;
414			register EPNODE *dp;
415
416			if ((vp = varlookup(name)) == NULL \|\| vp->def == NULL)
417			return(NULL);
418			dp = vp->def;
419			vp->def = dp->sibling;
420			varfree(vp);
421			return(dp);
422			}
423
424
425	greg	1.13	dpush(nm, ep) /* push on a definition */
426			char *nm;
427	greg	1.1	register EPNODE *ep;
428			{
429			register VARDEF *vp;
430
431	greg	1.13	vp = varinsert(nm);
432	greg	1.1	ep->sibling = vp->def;
433			vp->def = ep;
434			}
435
436
437			#ifdef OUTCHAN
438			addchan(sp) /* add an output channel assignment */
439			EPNODE *sp;
440			{
441			int ch = sp->v.kid->v.chan;
442			register EPNODE ep, epl;
443
444			for (epl = NULL, ep = outchan; ep != NULL; epl = ep, ep = ep->sibling)
445			if (ep->v.kid->v.chan >= ch) {
446			if (epl != NULL)
447			epl->sibling = sp;
448			else
449			outchan = sp;
450			if (ep->v.kid->v.chan > ch)
451			sp->sibling = ep;
452			else {
453			sp->sibling = ep->sibling;
454			epfree(ep);
455			}
456			return;
457			}
458			if (epl != NULL)
459			epl->sibling = sp;
460			else
461			outchan = sp;
462			sp->sibling = NULL;
463
464			}
465			#endif
466
467
468	greg	1.13	getstatement() /* get next statement */
469	greg	1.1	{
470			register EPNODE *ep;
471	greg	1.13	char *qname;
472	greg	1.10	EPNODE *lastdef;
473	greg	1.1
474			if (nextc == ';') { /* empty statement */
475			scan();
476			return;
477			}
478			#ifdef OUTCHAN
479			if (nextc == '$') { /* channel assignment */
480			ep = getchan();
481			addchan(ep);
482			} else
483			#endif
484			{ /* ordinary definition */
485			ep = getdefn();
486	greg	1.13	qname = qualname(dname(ep), 0);
487	greg	1.2	#ifdef REDEFW
488	greg	1.13	if ((lastdef = dlookup(qname)) != NULL) {
489			wputs(qname);
490	greg	1.10	if (lastdef->type == ':')
491			wputs(": redefined constant expression\n");
492			else
493	greg	1.2	wputs(": redefined\n");
494			}
495	greg	1.8	#ifdef FUNCTION
496	greg	1.13	else if (ep->v.kid->type == FUNC && liblookup(qname) != NULL) {
497			wputs(qname);
498	greg	1.11	wputs(": definition hides library function\n");
499	greg	1.8	}
500			#endif
501	greg	1.2	#endif
502	greg	1.10	if (ep->type == ':')
503	greg	1.13	dremove(qname);
504	greg	1.10	else
505	greg	1.13	dclear(qname);
506			dpush(qname, ep);
507	greg	1.1	}
508			if (nextc != EOF) {
509			if (nextc != ';')
510			syntax("';' expected");
511			scan();
512			}
513			}
514
515
516			EPNODE *
517			getdefn() /* A -> SYM = E1 */
518	greg	1.8	/* SYM : E1 */
519	greg	1.1	/* FUNC(SYM,..) = E1 */
520	greg	1.8	/* FUNC(SYM,..) : E1 */
521	greg	1.1	{
522			register EPNODE ep1, ep2;
523
524			if (!isalpha(nextc))
525			syntax("illegal variable name");
526
527			ep1 = newnode();
528			ep1->type = SYM;
529			ep1->v.name = savestr(getname());
530
531			#ifdef FUNCTION
532			if (nextc == '(') {
533			ep2 = newnode();
534			ep2->type = FUNC;
535			addekid(ep2, ep1);
536			ep1 = ep2;
537			do {
538			scan();
539			if (!isalpha(nextc))
540			syntax("illegal variable name");
541			ep2 = newnode();
542			ep2->type = SYM;
543			ep2->v.name = savestr(getname());
544			addekid(ep1, ep2);
545			} while (nextc == ',');
546			if (nextc != ')')
547			syntax("')' expected");
548			scan();
549			curfunc = ep1;
550			} else
551			curfunc = NULL;
552			#endif
553
554	greg	1.8	if (nextc != '=' && nextc != ':')
555			syntax("'=' or ':' expected");
556	greg	1.1
557			ep2 = newnode();
558	greg	1.8	ep2->type = nextc;
559			scan();
560	greg	1.1	addekid(ep2, ep1);
561			addekid(ep2, getE1());
562
563	greg	1.7	if (
564	greg	1.1	#ifdef FUNCTION
565	greg	1.7	ep1->type == SYM &&
566	greg	1.1	#endif
567	greg	1.7	ep1->sibling->type != NUM) {
568	greg	1.1	ep1 = newnode();
569			ep1->type = TICK;
570			ep1->v.tick = -1;
571			addekid(ep2, ep1);
572			ep1 = newnode();
573			ep1->type = NUM;
574			addekid(ep2, ep1);
575			}
576
577			return(ep2);
578			}
579
580
581			#ifdef OUTCHAN
582			EPNODE *
583			getchan() /* A -> $N = E1 */
584			{
585			register EPNODE ep1, ep2;
586
587			if (nextc != '$')
588			syntax("missing '$'");
589			scan();
590
591			ep1 = newnode();
592			ep1->type = CHAN;
593			ep1->v.chan = getinum();
594
595			if (nextc != '=')
596			syntax("'=' expected");
597			scan();
598
599			ep2 = newnode();
600			ep2->type = '=';
601			addekid(ep2, ep1);
602			addekid(ep2, getE1());
603
604			return(ep2);
605			}
606			#endif
607
608
609
610			/*
611			* The following routines are for internal use only:
612			*/
613
614
615			static double
616			dvalue(name, d) /* evaluate a variable */
617			char *name;
618			EPNODE *d;
619			{
620			register EPNODE ep1, ep2;
621
622			if (d == NULL \|\| d->v.kid->type != SYM) {
623			eputs(name);
624			eputs(": undefined variable\n");
625			quit(1);
626			}
627			ep1 = d->v.kid->sibling; /* get expression */
628	greg	1.5	if (ep1->type == NUM)
629			return(ep1->v.num); /* return if number */
630	greg	1.1	ep2 = ep1->sibling; /* check time */
631			if (ep2->v.tick < 0 \|\| ep2->v.tick < eclock) {
632	greg	1.8	ep2->v.tick = d->type == ':' ? 1L<<30 : eclock;
633	greg	1.1	ep2 = ep2->sibling;
634	greg	1.5	ep2->v.num = evalue(ep1); /* needs new value */
635	greg	1.1	} else
636	greg	1.5	ep2 = ep2->sibling; /* else reuse old value */
637	greg	1.1
638			return(ep2->v.num);
639			}
640
641
642			static int
643			hash(s) /* hash a string */
644			register char *s;
645			{
646			register int rval = 0;
647
648			while (*s)
649			rval += *s++;
650
651			return(rval % NHASH);
652			}