src/common/caldefn.c

#ifndef lint
static const char       RCSid[] = "$Id: caldefn.c,v 2.20 2003/07/27 22:12:01 schorsch Exp $";
#endif
/*
 *  Store variable definitions.
 *
 *  7/1/85  Greg Ward
 *
 *  11/11/85  Added conditional compiles (OUTCHAN) for control output.
 *
 *  4/2/86  Added conditional compiles for function definitions (FUNCTION).
 *
 *  1/15/88  Added clock for caching of variable values.
 *
 *  11/16/88  Added VARDEF structure for hard linking.
 *
 *  5/31/90  Added conditional compile (REDEFW) for redefinition warning.
 *
 *  4/23/91  Added ':' assignment for constant expressions
 *
 *  8/7/91  Added optional context path to append to variable names
 *
 *  5/17/2001  Fixed clock counter wrapping behavior
 *
 *  2/19/03     Eliminated conditional compiles in favor of esupport extern.
 */

#include "copyright.h"

#include  <stdio.h>
#include  <string.h>
#include  <ctype.h>

#include  "rterror.h"
#include  "rtmisc.h"
#include  "calcomp.h"

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

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

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

static double  dvalue(char  *name, EPNODE *d);

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

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

#define  MAXCNTX        1023            /* maximum context length */

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

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

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


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

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


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


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


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

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


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


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

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


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

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


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

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


char *
setcontext(                     /* 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(            /* push on another context */
        char  *ctx
)
{
    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(void)                        /* 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(               /* get qualified name */
        register char  *nam,
        int  lvl
)
{
    static char  nambuf[RMAXWORD+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+RMAXWORD)
                goto toolong;
        *cp++ = *nam++;
    }
                                /* check for explicit global */
    if (cp > nambuf && cp[-1] == CNTXMARK) {
        if (lvl > 0)
            return(NULL);
        *--cp = '\0';
        return(nambuf);         /* already qualified */
    }
    cpp = context;              /* else skip the requested levels */
    while (lvl-- > 0) {
        if (!*cpp)
            return(NULL);       /* return NULL if past global level */
        while (*++cpp && *cpp != CNTXMARK)
            ;
    }
    while (*cpp) {              /* copy context to static buffer */
        if (cp >= nambuf+RMAXWORD)
            goto toolong;
        *cp++ = *cpp++;
    }
toolong:
    *cp = '\0';
    return(nambuf);             /* return qualified name */
}


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


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

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

}


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


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


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


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


void
varfree(                                /* 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(void)                    /* return pointer to first definition */
{
    htndx = 0;
    htpos = NULL;
    ochpos = outchan;
    return(dnext());
}


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

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


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


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

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


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

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

}


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

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


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

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

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

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

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

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

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

    return(ep2);
}


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

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

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

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

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

    return(ep2);
}


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


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

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