src/common/caldefn.c

/* Copyright (c) 1997 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  hash(s)        (shash(s)%NHASH)

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

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

static double  dvalue();

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 */
#ifdef  OUTCHAN
static EPNODE  *ochpos;                 /* ...dnext */
static EPNODE  *outchan;
#endif

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


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

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


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

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


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


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


#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 (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;
    int  hv;
    
    if ((vp = varlookup(name)) != NULL) {
        vp->nlinks++;
        return(vp);
    }
    vp = (VARDEF *)emalloc(sizeof(VARDEF));
#ifdef  FUNCTION
    vp->lib = liblookup(name);
#else
    vp->lib = NULL;
#endif
    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);
}


#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 && epcmp(ep, vdef->def)) {
                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;
    }
#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 = 0;
        addekid(ep2, ep1);
        ep1 = newnode();
        ep1->type = NUM;
        addekid(ep2, ep1);
    }

#ifdef  FUNCTION
    curfunc = NULL;
#endif

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