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 int  hash();

static double  dvalue();

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

static char  context[MAXWORD+1];        /* 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)
            break;                      /* just copy what we can */
        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+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 */
}


incontext(qn)                   /* is qualified name in current context? */
register char  *qn;
{
    while (*qn && *qn != CNTXMARK)      /* find context mark */
        qn++;
    return(!strcmp(qn, context));
}


#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;
                                /* if context is global, clear all */
    for (i = 0; i < NHASH; i++)
        for (vp = hashtbl[i]; vp != NULL; vp = vp->next)
            if (!context[0] || incontext(vp->name))
                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;
    register LIBR  *libp;
    int  hv;
    
    if ((vp = varlookup(name)) != NULL) {
        vp->nlinks++;
        return(vp);
    }
#ifdef  FUNCTION
    libp = liblookup(name);
#else
    libp = NULL;
#endif
    if (libp == NULL)                   /* if name not in library */
        name = qualname(name, 0);       /* use fully qualified version */
    hv = hash(name);
    vp = (VARDEF *)emalloc(sizeof(VARDEF));
    vp->name = savestr(name);
    vp->nlinks = 1;
    vp->def = NULL;
    vp->lib = libp;
    vp->next = hashtbl[hv];
    hashtbl[hv] = vp;
    return(vp);
}


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


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;
    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);
        }
    }
#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;
    register VARDEF  *vdef;

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