1 /* xlsym - symbol handling routines */
2 /*	Copyright (c) 1985, by David Michael Betz
3         All Rights Reserved
4         Permission is granted for unrestricted non-commercial use	*/
5 
6 /* HISTORY
7  * 28-apr-03 DM  eliminate some compiler warnings
8  * 12-oct-90 RBD added xlatomcount to keep track of how many atoms there are.
9  *	(something I need for writing out score files).
10  */
11 
12 #include "string.h"
13 #include "xlisp.h"
14 
15 extern int xlatomcount;
16 
17 /* forward declarations */
18 FORWARD LVAL findprop(LVAL sym, LVAL prp);
19 
20 #ifdef FRAME_DEBUG
21 /* these routines were used to debug a missing call to protect().
22  * The routines can check for a consistent set of frames.  Note
23  * that frames must be pushed on the stack declared here because
24  * XLisp keeps frame pointers as local variables in C routines.
25  * I deleted the calls to push_xlenv etc throughout the XLisp
26  * sources, but decided to leave the following code for possible
27  * future debugging. - RBD
28  */
29 int envstack_top = 0;
30 LVAL envstack[envstack_max];
31 LVAL *fpstack[envstack_max];
32 extern long cons_count;
33 
34 FORWARD LOCAL void test_one_env(LVAL environment, int i, char *s);
35 
push_xlenv(void)36 void push_xlenv(void)
37 {
38     char s[10];
39     /* sprintf(s, "<%d ", envstack_top);
40     stdputstr(s); */
41     if (envstack_top >= envstack_max) {
42             xlabort("envstack overflow");
43     } else {
44             fpstack[envstack_top] = xlfp;
45             envstack[envstack_top++] = xlenv;
46     }
47 }
48 
49 
pop_xlenv(void)50 void pop_xlenv(void)
51 {
52     char s[10];
53     if (envstack_top <= 0) {
54             sprintf(s, ", %d! ", envstack_top);
55             stdputstr(s);
56             xlabort("envstack underflow!");
57     } else envstack_top--;
58     /* sprintf(s, "%d> ", envstack_top);
59     stdputstr(s); */
60 }
61 
62 
pop_multiple_xlenv(void)63 void pop_multiple_xlenv(void)
64 {
65     int i;
66     for (i = envstack_top - 1; i >= 0; i--) {
67             if (envstack[i] == xlenv) {
68                 char s[10];
69                 envstack_top = i + 1;
70                 /* sprintf(s, "%d] ", envstack_top);
71                 stdputstr(s); */
72                 return;
73             }
74     }
75 }
76 
77 
testenv(char * s)78 void testenv(char *s)
79 {
80     int i;
81 
82     for (i = envstack_top - 1; i >= 0; i--) {
83         test_one_env(envstack[i], i, s);
84     }
85 }
86 
report_exit(char * msg,int i)87 LOCAL void report_exit(char *msg, int i)
88 {
89     sprintf(buf, "env stack index: %d, cons_count %ld, Function: ", i, cons_count);
90     errputstr(buf);
91     stdprint(fpstack[i][1]);
92     xlabort(msg);
93 }
94 
test_one_env(LVAL environment,int i,char * s)95 LOCAL void test_one_env(LVAL environment, int i, char *s)
96 {
97     register LVAL fp,ep;
98     LVAL val;
99 
100     /* check the environment list */
101     for (fp = environment; fp; fp = cdr(fp)) {
102             /* check that xlenv is good */
103             if (!consp(fp)) {
104                 snprintf(buf, STRMAX, "%s: xlenv 0x%lx, frame 0x%lx, type(frame) %d\n",
105                          s, xlenv, fp, ntype(fp));
106             errputstr(buf);
107             report_exit("xlenv points to a bad list", i);
108         }
109 
110         /* check for an instance variable */
111         if ((ep = car(fp)) && objectp(car(ep))) {
112             /* do nothing */
113         }
114 
115         /* check an environment stack frame */
116         else {
117             for (; ep; ep = cdr(ep)) {
118                     /* check that ep is good */
119                     if (!consp(ep)) {
120                          snprintf(buf, STRMAX, "%s: fp 0x%lx, ep 0x%lx, type(ep) %d\n",
121                                  s, fp, ep, ntype(ep));
122                     errputstr(buf);
123                     report_exit("car(fp) points to a bad list", i);
124                 }
125 
126                     /* check that car(ep) is nonnull */
127                     if (!car(ep)) {
128                          snprintf(buf, STRMAX, "%s: ep 0x%lx, car(ep) 0x%lx\n",
129                                   s, ep, car(ep));
130                     errputstr(buf);
131                     report_exit("car(ep) (an association) is NULL", i);
132                 }
133                     /* check that car(ep) is a cons */
134                     if (!consp(car(ep))) {
135                          snprintf(buf, STRMAX, "%s: ep 0x%lx, car(ep) 0x%lx, type(car(ep)) %d\n",
136                                   s, ep, car(ep), ntype(car(ep)));
137                     errputstr(buf);
138                     report_exit("car(ep) (an association) is not a cons", i);
139                 }
140 
141                     /* check that car(car(ep)) is a symbol */
142                     if (!symbolp(car(car(ep)))) {
143                          snprintf(buf, STRMAX, "%s: ep 0x%lx, car(ep) 0x%lx, car(car(ep)) 0x%lx, type(car(car(ep))) %d\n",
144                                   s, ep, car(ep), car(car(ep)), ntype(car(car(ep))));
145                     errputstr(buf);
146                     report_exit("car(car(ep)) is not a symbol", i);
147                 }
148             }
149         }
150     }
151 }
152 #endif
153 
154 
155 /* xlenter - enter a symbol into the obarray */
xlenter(const char * name)156 LVAL xlenter(const char *name)
157 {
158     LVAL sym,array;
159     int i;
160 
161     /* check for nil */
162     if (strcmp(name,"NIL") == 0)
163         return (NIL);
164 
165     /* check for symbol already in table */
166     array = getvalue(obarray);
167     i = hash(name,HSIZE);
168     for (sym = getelement(array,i); sym; sym = cdr(sym))
169         if (strcmp(name,(char *) getstring(getpname(car(sym)))) == 0)
170             return (car(sym));
171 
172     /* make a new symbol node and link it into the list */
173     xlsave1(sym);
174     sym = consd(getelement(array,i));
175     rplaca(sym,xlmakesym(name));
176     setelement(array,i,sym);
177     xlpop();
178 
179     /* return the new symbol */
180     return (car(sym));
181 }
182 
183 /* xlmakesym - make a new symbol node */
xlmakesym(const char * name)184 LVAL xlmakesym(const char *name)
185 {
186     LVAL sym;
187     sym = cvsymbol(name);
188     if (*name == ':')
189         setvalue(sym,sym);
190     return (sym);
191 }
192 
193 /* xlgetvalue - get the value of a symbol (with check) */
xlgetvalue(LVAL sym)194 LVAL xlgetvalue(LVAL sym)
195 {
196     LVAL val;
197 
198     /* look for the value of the symbol */
199     while ((val = xlxgetvalue(sym)) == s_unbound)
200         xlunbound(sym);
201 
202     /* return the value */
203     return (val);
204 }
205 
206 /* xlxgetvalue - get the value of a symbol */
xlxgetvalue(LVAL sym)207 LVAL xlxgetvalue(LVAL sym)
208 {
209     register LVAL fp,ep;
210     LVAL val;
211 
212     /* check the environment list */
213     for (fp = xlenv; fp; fp = cdr(fp))
214 
215         /* check for an instance variable */
216         if ((ep = car(fp)) && objectp(car(ep))) {
217             if (xlobgetvalue(ep,sym,&val))
218                 return (val);
219         }
220 
221         /* check an environment stack frame */
222         else {
223             for (; ep; ep = cdr(ep))
224                 if (sym == car(car(ep)))
225                     return (cdr(car(ep)));
226         }
227 
228     /* return the global value */
229     return (getvalue(sym));
230 }
231 
232 /* xlsetvalue - set the value of a symbol */
xlsetvalue(LVAL sym,LVAL val)233 void xlsetvalue(LVAL sym, LVAL val)
234 {
235     register LVAL fp,ep;
236 
237     /* look for the symbol in the environment list */
238     for (fp = xlenv; fp; fp = cdr(fp))
239 
240         /* check for an instance variable */
241         if ((ep = car(fp)) && objectp(car(ep))) {
242             if (xlobsetvalue(ep,sym,val))
243                 return;
244         }
245 
246         /* check an environment stack frame */
247         else {
248             for (; ep; ep = cdr(ep))
249                 if (sym == car(car(ep))) {
250                     rplacd(car(ep),val);
251                     return;
252                 }
253         }
254 
255     /* store the global value */
256     setvalue(sym,val);
257 }
258 
259 /* xlgetfunction - get the functional value of a symbol (with check) */
xlgetfunction(LVAL sym)260 LVAL xlgetfunction(LVAL sym)
261 {
262     LVAL val;
263 
264     /* look for the functional value of the symbol */
265     while ((val = xlxgetfunction(sym)) == s_unbound)
266         xlfunbound(sym);
267 
268     /* return the value */
269     return (val);
270 }
271 
272 /* xlxgetfunction - get the functional value of a symbol */
xlxgetfunction(LVAL sym)273 LVAL xlxgetfunction(LVAL sym)
274 {
275     register LVAL fp,ep;
276 
277     /* check the environment list */
278     for (fp = xlfenv; fp; fp = cdr(fp))
279         for (ep = car(fp); ep; ep = cdr(ep))
280             if (sym == car(car(ep)))
281                 return (cdr(car(ep)));
282 
283     /* return the global value */
284     return (getfunction(sym));
285 }
286 
287 /* xlsetfunction - set the functional value of a symbol */
xlsetfunction(LVAL sym,LVAL val)288 void xlsetfunction(LVAL sym, LVAL val)
289 {
290     register LVAL fp,ep;
291 
292     /* look for the symbol in the environment list */
293     for (fp = xlfenv; fp; fp = cdr(fp))
294         for (ep = car(fp); ep; ep = cdr(ep))
295             if (sym == car(car(ep))) {
296                 rplacd(car(ep),val);
297                 return;
298             }
299 
300     /* store the global value */
301     setfunction(sym,val);
302 }
303 
304 /* xlgetprop - get the value of a property */
xlgetprop(LVAL sym,LVAL prp)305 LVAL xlgetprop(LVAL sym, LVAL prp)
306 {
307     LVAL p;
308     return ((p = findprop(sym,prp)) ? car(p) : NIL);
309 }
310 
311 /* xlputprop - put a property value onto the property list */
xlputprop(LVAL sym,LVAL val,LVAL prp)312 void xlputprop(LVAL sym, LVAL val, LVAL prp)
313 {
314     LVAL pair;
315     if ((pair = findprop(sym,prp)))
316         rplaca(pair,val);
317     else
318         setplist(sym,cons(prp,cons(val,getplist(sym))));
319 }
320 
321 /* xlremprop - remove a property from a property list */
xlremprop(LVAL sym,LVAL prp)322 void xlremprop(LVAL sym, LVAL prp)
323 {
324     LVAL last,p;
325     last = NIL;
326     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
327         if (car(p) == prp) {
328             if (last)
329                 rplacd(last,cdr(cdr(p)));
330             else
331                 setplist(sym,cdr(cdr(p)));
332         }
333         last = cdr(p);
334     }
335 }
336 
337 /* findprop - find a property pair */
findprop(LVAL sym,LVAL prp)338 LVAL findprop(LVAL sym, LVAL prp)
339 {
340     LVAL p;
341     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
342         if (car(p) == prp)
343             return (cdr(p));
344     return (NIL);
345 }
346 
347 /* hash - hash a symbol name string */
hash(const char * str,int len)348 int hash(const char *str, int len)
349 {
350     int i;
351     for (i = 0; *str; )
352         i = (i << 2) ^ *str++;
353     i %= len;
354     return (i < 0 ? -i : i);
355 }
356 
357 /* xlsinit - symbol initialization routine */
xlsinit(void)358 void xlsinit(void)
359 {
360     LVAL array,p;
361 
362     /* initialize the obarray */
363     obarray = xlmakesym("*OBARRAY*");
364     array = newvector(HSIZE);
365     setvalue(obarray,array);
366 
367     /* add the symbol *OBARRAY* to the obarray */
368     p = consa(obarray);
369     setelement(array,hash("*OBARRAY*",HSIZE),p);
370 }
371