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